fortran-lang-fpm-90bb83a/ 0000775 0001750 0001750 00000000000 15145116760 015470 5 ustar alastair alastair fortran-lang-fpm-90bb83a/manifest-reference.md 0000664 0001750 0001750 00000000132 15145116760 021550 0 ustar alastair alastair # 301 - Moved
This document now lives at https://fpm.fortran-lang.org/spec/manifest.html
fortran-lang-fpm-90bb83a/fpm.toml 0000664 0001750 0001750 00000002164 15145116760 017152 0 ustar alastair alastair name = "fpm"
version = "0.13.0"
license = "MIT"
author = "fpm maintainers"
maintainer = "@fortran-lang/fpm"
copyright = "2020-2026 fpm contributors"
homepage = "https://fpm.fortran-lang.org/"
description = "Fortran Package Manager"
[preprocess]
[preprocess.cpp]
macros=["FPM_RELEASE_VERSION={version}"]
[dependencies]
toml-f.git = "https://github.com/toml-f/toml-f"
toml-f.rev = "d7b892b1d074b7cfc5d75c3e0eb36ebc1f7958c1"
M_CLI2.git = "https://github.com/urbanjost/M_CLI2.git"
M_CLI2.rev = "7264878cdb1baff7323cc48596d829ccfe7751b8"
fortran-regex.git = "https://github.com/perazz/fortran-regex"
fortran-regex.tag = "1.1.2"
jonquil.git = "https://github.com/toml-f/jonquil"
jonquil.rev = "4fbd4cf34d577c0fd25e32667ee9e41bf231ece8"
fortran-shlex.git = "https://github.com/perazz/fortran-shlex"
fortran-shlex.tag = "2.0.1"
[[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"
fortran-lang-fpm-90bb83a/.github/ 0000775 0001750 0001750 00000000000 15145116760 017030 5 ustar alastair alastair fortran-lang-fpm-90bb83a/.github/dependabot.yml 0000664 0001750 0001750 00000000167 15145116760 021664 0 ustar alastair alastair version: 2
updates:
- package-ecosystem: "github-actions"
directory: "/"
schedule:
interval: "monthly"
fortran-lang-fpm-90bb83a/.github/ISSUE_TEMPLATE/ 0000775 0001750 0001750 00000000000 15145116760 021213 5 ustar alastair alastair fortran-lang-fpm-90bb83a/.github/ISSUE_TEMPLATE/03_feature.yaml 0000664 0001750 0001750 00000001431 15145116760 024033 0 ustar alastair alastair name: Feature request
description: An idea for a new feature
labels: [enhancement]
body:
- type: textarea
id: description
attributes:
label: Description
placeholder: |
Please describe the feature, please provide examples
Use codefences (```) to add literal codeblocks for examples
validations:
required: true
- type: textarea
id: solution
attributes:
label: Possible Solution
placeholder: |
Please describe possible solutions or currently available workarounds if available.
validations:
required: false
- type: textarea
id: additional
attributes:
label: Additional Information
placeholder: Further relevant context, i.e. links to other issues
validations:
required: false
fortran-lang-fpm-90bb83a/.github/ISSUE_TEMPLATE/04_specification.yaml 0000664 0001750 0001750 00000002260 15145116760 025222 0 ustar alastair alastair name: Specification Proposal
description: Suggestion for extending the package manifest, command line interface, ...
labels: [specification]
body:
- type: textarea
id: motivation
attributes:
label: Motivation
placeholder: |
What is the purpose of this proposal. Please provide usage examples for the new functionality as well.
validations:
required: true
- type: textarea
id: description
attributes:
label: Specification
placeholder: |
Please provide possible realisations of this proposal, i.e. an example how this would work in the manifest.
Use code fences to provide the example.
```toml
[extra]
fpm = "feature"
```
validations:
required: true
- type: textarea
id: prior-art
attributes:
label: Prior Art
placeholder: |
Include links and references to other package manager or build systems if available.
validations:
required: false
- type: textarea
id: additional
attributes:
label: Additional Information
placeholder: Further relevant context, i.e. links to other issues
validations:
required: false
fortran-lang-fpm-90bb83a/.github/ISSUE_TEMPLATE/config.yml 0000664 0001750 0001750 00000000623 15145116760 023204 0 ustar alastair alastair contact_links:
- name: Fpm discussion board
url: https://github.com/fortran-lang/fpm/discussions
about: Discussion about fpm related topics
- name: Fortran-lang discourse
url: https://fortran-lang.discourse.group/
about: Discussion about all things Fortran
- name: Fortran-lang mailing list
url: https://groups.io/g/fortran-lang
about: Mailinglist for the Fortran language
fortran-lang-fpm-90bb83a/.github/ISSUE_TEMPLATE/05_free.md 0000664 0001750 0001750 00000000157 15145116760 022765 0 ustar alastair alastair ---
name: Free Form
about: If the topic doesn't fit anything above and is not suitable for the lists below
---
fortran-lang-fpm-90bb83a/.github/ISSUE_TEMPLATE/02_packaging.yaml 0000664 0001750 0001750 00000001536 15145116760 024331 0 ustar alastair alastair name: Packaging Issue
description: Porting or packaging a project to fpm
labels: [packaging]
body:
- type: input
id: project
attributes:
label: Upstream Project
placeholder: URL for the upstream project
validations:
required: true
- type: textarea
id: description
attributes:
label: Description
placeholder: Please describe the issue with porting or packaging a project with fpm
validations:
required: true
- type: input
id: fpm-version
attributes:
label: Version of fpm
placeholder: 0.4.0, 04da9a1ce99e8fce1abdb7eb9a2073f3188038ea, ...
validations:
required: true
- type: textarea
id: additional
attributes:
label: Additional Information
placeholder: Further relevant context, i.e. links to other issues
validations:
required: false
fortran-lang-fpm-90bb83a/.github/ISSUE_TEMPLATE/01_bug.yaml 0000664 0001750 0001750 00000002030 15145116760 023147 0 ustar alastair alastair name: Bug Report
description: Something is not working
labels: [bug]
body:
- type: textarea
id: description
attributes:
label: Description
placeholder: Please include steps to reproduce your issue, provide example code snippets if possible
validations:
required: true
- type: textarea
id: expected
attributes:
label: Expected Behaviour
placeholder: What did you expect to happen instead
validations:
required: true
- type: input
id: fpm-version
attributes:
label: Version of fpm
placeholder: 0.4.0, 04da9a1ce99e8fce1abdb7eb9a2073f3188038ea, ...
validations:
required: true
- type: input
id: platform
attributes:
label: Platform and Architecture
placeholder: MacOS/ARM, Windows, OpenBSD, ...
validations:
required: true
- type: textarea
id: additional
attributes:
label: Additional Information
placeholder: Further relevant context, i.e. links to other issues
validations:
required: false
fortran-lang-fpm-90bb83a/.github/actions/ 0000775 0001750 0001750 00000000000 15145116760 020470 5 ustar alastair alastair fortran-lang-fpm-90bb83a/.github/actions/setup-intel/ 0000775 0001750 0001750 00000000000 15145116760 022741 5 ustar alastair alastair fortran-lang-fpm-90bb83a/.github/actions/setup-intel/action.yml 0000664 0001750 0001750 00000013633 15145116760 024747 0 ustar alastair alastair name: 'Setup Intel oneAPI Environment'
description: 'Sets up Intel oneAPI C++, Fortran compilers and MPI on Windows or Ubuntu runners.'
inputs:
os:
description: 'Operating system of the runner. Must contain "windows" or "ubuntu".'
required: true
type: string
version:
description: 'Intel oneAPI installer version for Ubuntu (e.g. 2024.1.0).'
required: false
default: '2024.1.0'
type: string
runs:
using: "composite"
steps:
- name: (Windows) Setup VS Build environment
if: contains(inputs.os, 'windows')
uses: seanmiddleditch/gha-setup-vsdevenv@v4
- name: (Windows) Retrieve and Install Intel toolchain
if: contains(inputs.os, 'windows')
shell: pwsh
run: |
$tempDir = "C:\TEMP\intel_install"
New-Item -ItemType Directory -Force -Path $tempDir
cd $tempDir
$installerName = "w_HPCKit_p_2023.0.0.25931_offline.exe" # Consider using inputs.intel_version_windows if added
$installerUrl = "https://registrationcenter-download.intel.com/akdlm/irc_nas/19085/$installerName"
Write-Host "Downloading Intel oneAPI installer..."
curl.exe --output $installerName --url $installerUrl --retry 5 --retry-delay 5 -L # Added -L for potential redirects
Write-Host "Extracting installer..."
Start-Process -FilePath ".\$installerName" -ArgumentList "-s -x -f oneAPI --log extract.log" -Wait -NoNewWindow
Remove-Item ".\$installerName" -Force
Write-Host "Installing oneAPI components..."
# Install C++, Fortran, and MPI development tools silently
Start-Process -FilePath ".\oneAPI\bootstrapper.exe" -ArgumentList "-s --action install --eula=accept --components=""intel.oneapi.win.cpp-compiler:intel.oneapi.win.ifort-compiler:intel.oneapi.win.mpi.devel"" -p=NEED_VS2017_INTEGRATION=0 -p=NEED_VS2019_INTEGRATION=0 -p=NEED_VS2022_INTEGRATION=0 --log-dir=." -Wait -NoNewWindow
Write-Host "Cleaning up extracted files..."
Remove-Item ".\oneAPI" -Force -Recurse
cd ..
Remove-Item $tempDir -Force -Recurse
- name: (Windows) Test that OneAPI is installed
if: contains(inputs.os, 'windows')
shell: pwsh
run: |
$setvarsPath = "C:\Program Files (x86)\Intel\oneAPI\setvars.bat"
$compilerVarsPath = "C:\Program Files (x86)\Intel\oneAPI\compiler\latest\env\vars.bat"
if (-not (Test-Path -Path $setvarsPath -PathType Leaf)) {
Write-Error "Intel oneAPI setvars.bat not found at $setvarsPath"
exit 1
}
if (-not (Test-Path -Path $compilerVarsPath -PathType Leaf)) {
Write-Warning "Intel oneAPI compiler vars.bat not found at $compilerVarsPath. MPI might still work."
# Depending on requirements, you might want to 'exit 1' here too
}
Write-Host "Intel oneAPI installation paths verified."
- name: (Windows) Load OneAPI environment variables
if: contains(inputs.os, 'windows')
shell: cmd
run: |
call "C:\Program Files (x86)\Intel\oneAPI\setvars.bat" > NUL
echo "Setting Intel environment variables..."
echo "PATH=%PATH%" >> %GITHUB_ENV%
echo "INCLUDE=%INCLUDE%" >> %GITHUB_ENV%
echo "LIB=%LIB%" >> %GITHUB_ENV%
REM Add any other specific vars if needed, e.g., for MPI
echo "I_MPI_ROOT=%I_MPI_ROOT%" >> %GITHUB_ENV%
echo "FI_PROVIDER_PATH=%FI_PROVIDER_PATH%" >> %GITHUB_ENV%
echo "MPI_BIN=%MPI_BIN%" >> %GITHUB_ENV%
# --- Ubuntu Intel Setup ---
- name: (Ubuntu) Install prerequisites and Intel GPG key
if: contains(inputs.os, 'ubuntu')
shell: bash
run: |
sudo apt-get update -y -qq
sudo apt-get install -y -qq gpg wget ca-certificates curl gpg-agent software-properties-common
wget -O- https://apt.repos.intel.com/intel-gpg-keys/GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB | gpg --dearmor | sudo tee /usr/share/keyrings/oneapi-archive-keyring.gpg > /dev/null
- name: (Ubuntu) Add Intel oneAPI repository
if: contains(inputs.os, 'ubuntu')
shell: bash
run: |
echo "deb [signed-by=/usr/share/keyrings/oneapi-archive-keyring.gpg] https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list
sudo apt-get update -y -qq
- name: (Ubuntu) Install Intel oneAPI Compilers using fortran-lang action
if: contains(inputs.os, 'ubuntu')
uses: fortran-lang/setup-fortran@v1
with:
compiler: intel
version: ${{ inputs.version }}
- name: (Ubuntu) Install Intel oneAPI MPI and build dependencies
if: contains(inputs.os, 'ubuntu')
shell: bash
run: |
# Install MPI devel package and common build tools
# The compilers (icc, ifort) should already be installed by setup-fortran action
sudo apt-get install -y -q intel-oneapi-mpi-devel intel-oneapi-mkl ninja-build cmake libcurl4-gnutls-dev
- name: (Ubuntu) Source oneAPI environment and add to GITHUB_ENV
if: contains(inputs.os, 'ubuntu')
shell: bash
run: |
# Source the main setvars script to set up the environment for this step
# Use --force as we might be in a non-interactive shell
source /opt/intel/oneapi/setvars.sh --force > /dev/null 2>&1
echo "Sourced setvars.sh. Adding key variables to GITHUB_ENV..."
# Explicitly add key variables to GITHUB_ENV for subsequent steps
echo "PATH=$PATH" >> $GITHUB_ENV
echo "LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >> $GITHUB_ENV
echo "LIBRARY_PATH=$LIBRARY_PATH" >> $GITHUB_ENV
echo "CPATH=$CPATH" >> $GITHUB_ENV
echo "CMPLR_ROOT=$CMPLR_ROOT" >> $GITHUB_ENV # Example compiler root
echo "MPI_ROOT=$MPI_ROOT" >> $GITHUB_ENV # MPI root (check actual variable name if needed, e.g., I_MPI_ROOT)
echo "I_MPI_ROOT=$I_MPI_ROOT" >> $GITHUB_ENV # Common variable name for Intel MPI root
echo "FI_PROVIDER_PATH=$FI_PROVIDER_PATH" >> $GITHUB_ENV # Often needed for MPI
fortran-lang-fpm-90bb83a/.github/workflows/ 0000775 0001750 0001750 00000000000 15145116760 021065 5 ustar alastair alastair fortran-lang-fpm-90bb83a/.github/workflows/release.yml 0000664 0001750 0001750 00000012275 15145116760 023237 0 ustar alastair alastair name: Release
on:
push:
pull_request:
release:
types: [published]
jobs:
source-archive:
runs-on: ubuntu-latest
strategy:
fail-fast: false
matrix:
format: [zip]
env:
FORMAT: ${{ matrix.format }}
steps:
- name: Checkout code
uses: actions/checkout@v6
with:
fetch-depth: 0
- name: Get version number
run: |
VERSION=$(git describe --tags --match 'v*' --always | tr -d 'v')
echo "VERSION=${VERSION}" >> $GITHUB_ENV
- name: Create archive
run: |
echo "OUTPUT=${{ env.OUTPUT }}" >> $GITHUB_ENV
git archive --prefix ${{ env.PREFIX }} --format ${{ env.FORMAT }} HEAD > ${{ env.OUTPUT }}
env:
OUTPUT: fpm-${{ env.VERSION }}.${{ env.FORMAT }}
PREFIX: fpm-${{ env.VERSION }}/
- name: Upload artifact
uses: actions/upload-artifact@v6
with:
name: ${{ env.OUTPUT }}
path: ${{ env.OUTPUT }}
source-single-file:
runs-on: ubuntu-latest
steps:
- name: Checkout code
uses: actions/checkout@v6
with:
fetch-depth: 0
- name: Get version number
run: |
VERSION=$(git describe --tags --match 'v*' --always | tr -d 'v')
echo "VERSION=${VERSION}" >> $GITHUB_ENV
echo ${{ env.VERSION }}
- name: Get manifest version
run: |
MANIFEST_VERSION=$(grep version fpm.toml | head -1 | tr -d ' ' | tr -d 'version=')
echo "MANIFEST_VERSION=${MANIFEST_VERSION}" >> $GITHUB_ENV
echo ${{ env.MANIFEST_VERSION }}
# Note: this step is meant to remove the test targets from the package manifest,
# a change in the package manifest might require to regenerate the patch file.
- name: Remove tests
run: |
patch -p1 < ./ci/single-file.patch
- name: Install fpm
uses: fortran-lang/setup-fpm@v9
with:
fpm-version: 'v0.8.0'
- name: Create single file version
run: |
echo "OUTPUT=${{ env.OUTPUT }}" >> $GITHUB_ENV
echo "#define FPM_BOOTSTRAP" > fpm-${{ env.VERSION }}.F90
# We need to pass the exact version string that a fpm build command would send
echo "#define FPM_RELEASE_VERSION ${{ env.MANIFEST_VERSION }}" >> fpm-${{ env.VERSION }}.F90
# Intel compiler predefines "linux" and "unix" which causes inadvertent substitutions
echo "#undef linux" >> fpm-${{ env.VERSION }}.F90
echo "#undef unix" >> fpm-${{ env.VERSION }}.F90
fpm build --compiler ./ci/single-file-gfortran.sh
env:
OUTPUT: fpm-${{ env.VERSION }}.F90
OMP_NUM_THREADS: 1
# Building the bootstrap version from the single source version is the most expensive
# step in this workflow, since we have to compile several thousand lines of source.
- name: Build single source version
run: |
echo "EXE=${{ env.BUILD_DIR }}/fpm" >> $GITHUB_ENV
mkdir ${{ env.BUILD_DIR }}
gfortran ${{ env.OUTPUT }} -J ${{ env.BUILD_DIR }} -o ${{ env.BUILD_DIR }}/fpm
env:
BUILD_DIR: build/bootstrap
- name: Undo patch
run: |
patch -p1 -R < ./ci/single-file.patch
- name: Build fpm with bootstrap version
run: |
${{ env.EXE }} build
- name: Upload artifact
uses: actions/upload-artifact@v6
with:
name: ${{ env.OUTPUT }}
path: ${{ env.OUTPUT }}
upload-artifacts:
if: ${{ github.event_name == 'release' && contains(github.ref, 'v') || github.event_name == 'push' }}
runs-on: ubuntu-latest
needs:
- source-archive
- source-single-file
steps:
- id: deploy-on-push
if: ${{ github.event_name == 'push' }}
run:
echo "::set-output name=result::${{ env.DEPLOY_BRANCH }}"
env:
DEPLOY_BRANCH: ${{ secrets.DEPLOY_BRANCH && contains(github.ref, secrets.DEPLOY_BRANCH) && 1 || 0 }}
- uses: actions/checkout@v6
if: ${{ github.event_name == 'push' }}
- name: Download Artifacts
uses: actions/download-artifact@v7
with:
path: fpm-cd-artifacts
merge-multiple: true
- name: Normalize file names for continuous delivery
if: ${{ github.event_name == 'push' }}
run: |
cd fpm-cd-artifacts
for output in fpm-*; do
mv -v $(basename $output) $(basename $output | sed -E '${{ env.replace }}')
done
env:
replace: 's/-([0-9]+\.[0-9]+\.[0-9]+-[0-9]+-g)?[0-9a-f]+//'
- name: Create SHA256 checksums
run: |
cd fpm-cd-artifacts
for output in fpm-*; do
sha256sum $(basename "$output") | tee $(basename "$output").sha256
done
- name: Move/Create continuous tag
if: ${{ github.event_name == 'push' && steps.deploy-on-push.outputs.result != 0 }}
run: |
git tag --force 'current' ${{ github.sha }}
git push --tags --force
- name: Upload assets
if: ${{ github.event_name == 'release' || steps.deploy-on-push.outputs.result != 0 }}
uses: svenstaro/upload-release-action@v2
with:
repo_token: ${{ secrets.GITHUB_TOKEN }}
file: fpm-cd-artifacts/*
file_glob: true
tag: ${{ github.event_name == 'release' && github.ref || 'current'}}
overwrite: true
fortran-lang-fpm-90bb83a/.github/workflows/docs.yml 0000664 0001750 0001750 00000001247 15145116760 022544 0 ustar alastair alastair name: docs
on: [push, pull_request]
jobs:
build-and-deploy:
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v6
- uses: actions/setup-python@v6
with:
python-version: '3.x'
- name: Install dependencies
run: pip install ford
- name: Build Documentation
run: ford docs.md
- uses: JamesIves/github-pages-deploy-action@v4.7.6
if: github.event_name == 'push' && github.repository == 'fortran-lang/fpm' && ( startsWith( github.ref, 'refs/tags/' ) || github.ref == 'refs/heads/main' )
with:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
BRANCH: gh-pages
FOLDER: fpm-doc
CLEAN: true
fortran-lang-fpm-90bb83a/.github/workflows/meta.yml 0000664 0001750 0001750 00000040221 15145116760 022535 0 ustar alastair alastair name: metapackage-tests
on:
# On push, only run if any of the metapackage files has changed
push:
paths:
- 'src/*meta*.f90'
- 'src/fpm/*meta*.f90'
- 'src/fpm/manifest/*meta*.f90'
- 'src/ci/meta_tests.sh'
- 'src/.github/workflows/meta.yml'
# Always run on PR or release
pull_request:
release:
types: [published]
# Allow manual triggering
workflow_dispatch:
env:
CI: "ON" # We can detect this in the build system and other vendors implement it
HOMEBREW_NO_ANALYTICS: 1 # Make Homebrew installation a little quicker
HOMEBREW_NO_AUTO_UPDATE: 1
HOMEBREW_NO_BOTTLE_SOURCE_FALLBACK: 1
HOMEBREW_NO_GITHUB_API: 1
HOMEBREW_NO_INSTALL_CLEANUP: 1
HOMEBREW_NO_INSTALLED_DEPENDENTS_CHECK: 1
jobs:
build:
runs-on: ${{ matrix.os }}
strategy:
fail-fast: false
matrix:
include:
- os: ubuntu-latest
mpi: openmpi
release-flags: --flag ' -Wno-external-argument-mismatch'
- os: ubuntu-latest
mpi: mpich
release-flags: --flag ' -Wno-external-argument-mismatch'
- os: macos-14
mpi: openmpi
release-flags: --flag ' -Wno-external-argument-mismatch'
- os: macos-14
mpi: mpich
release-flags: --flag ' -Wno-external-argument-mismatch'
- os: ubuntu-latest
mpi: intel
intel_version: "2024.1.0"
release-flags: "" # override: no GCC flags
- os: ubuntu-latest
mpi: intel
intel_version: "2025.0"
release-flags: "" # override: no GCC flags
steps:
- name: Checkout code
uses: actions/checkout@v6
- name: (Ubuntu) setup gcc version
if: contains(matrix.os,'ubuntu')
run: |
echo "GCC_V=14" >> $GITHUB_ENV
- name: (macOS) setup gcc version
if: contains(matrix.os,'macos')
run: |
echo "GCC_V=15" >> $GITHUB_ENV
- name: (Windows) Install MSYS2
uses: msys2/setup-msys2@v2
if: contains(matrix.os,'windows') && contains(matrix.mpi,'msmpi')
with:
msystem: MINGW64
update: true
install: >-
git
base-devel
wget
unzip
curl
hdf5
netcdf
netcdf-fortran
- name: (Ubuntu) Install gfortran
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/bin/gcov gcov /usr/bin/gcov-${GCC_V}
- name: (Ubuntu) Install OpenMPI
if: contains(matrix.os,'ubuntu') && contains(matrix.mpi,'openmpi')
run: |
sudo apt-get update
sudo apt install -y -q openmpi-bin libopenmpi-dev hwloc fabric libhdf5-dev \
libhdf5-fortran-102 libnetcdf-dev libnetcdff-dev libopenblas-dev
- name: (Ubuntu) Install MPICH
if: contains(matrix.os,'ubuntu') && contains(matrix.mpi,'mpich')
run: |
sudo apt-get update
sudo apt install -y -q mpich hwloc fabric libhdf5-dev libhdf5-fortran-102 \
libnetcdf-dev libnetcdff-dev libopenblas-dev
# Intel
- name: Setup Intel Environment
if: contains(matrix.mpi, 'intel')
uses: ./.github/actions/setup-intel
with:
os: ${{ matrix.os }}
version: ${{ matrix.intel_version }}
- name: (Ubuntu) Build and Install HDF5 from source
if: contains(matrix.os, 'ubuntu') && contains(matrix.mpi, 'intel')
# Needs checkout if source code isn't available, adjust if needed
# Ensure compilers are available from the previous step's environment setup
shell: bash
run: |
# Source again just in case shell context is lost (shouldn't be, but safer)
source /opt/intel/oneapi/setvars.sh --force
# Download HDF5
curl -O -L https://github.com/HDFGroup/hdf5/archive/refs/tags/snapshot-1.14.tar.gz
tar zxf snapshot-1.14.tar.gz
cd hdf5-snapshot-1.14
# Configure HDF5 with Intel compilers
cmake -B build -DCMAKE_Fortran_COMPILER=ifx -DCMAKE_C_COMPILER=icx -DCMAKE_CXX_COMPILER=icpx -DHDF5_BUILD_FORTRAN=ON -DCMAKE_INSTALL_PREFIX=/usr
cd build
make -j $(nproc)
sudo make install
cd ../.. # Go back to workspace directory
rm -rf hdf5-snapshot-1.14 snapshot-1.14.tar.gz # Clean up
- name: (Ubuntu) Build and Install NetCDF-C from source
if: contains(matrix.os, 'ubuntu') && contains(matrix.mpi, 'intel')
shell: bash
run: |
source /opt/intel/oneapi/setvars.sh --force
# Download NetCDF-C
curl -L https://github.com/Unidata/netcdf-c/archive/refs/tags/v4.9.2.tar.gz -o - | tar xz
cd netcdf-c-4.9.2
# Configure NetCDF-C with Intel Compilers, referencing installed HDF5
# Set CC/CXX/FC explicitly in environment for configure script
export CC=icx CXX=icpx FC=ifx
./configure --prefix=/usr --enable-netcdf-4 --with-hdf5=/usr
make -j $(nproc)
sudo make install
cd .. # Go back to workspace directory
rm -rf netcdf-c-4.9.2 # Clean up
- name: (Ubuntu) Build and Install NetCDF-Fortran from source
if: contains(matrix.os, 'ubuntu') && contains(matrix.mpi, 'intel')
shell: bash
run: |
source /opt/intel/oneapi/setvars.sh --force
# Download NetCDF-Fortran
curl -L https://github.com/Unidata/netcdf-fortran/archive/refs/tags/v4.6.1.tar.gz -o - | tar xz
cd netcdf-fortran-4.6.1
# Configure NetCDF-Fortran with Intel Compilers using CMake
cmake -B build -DCMAKE_Fortran_COMPILER=ifx -DCMAKE_C_COMPILER=icx -DCMAKE_CXX_COMPILER=icpx -DCMAKE_INSTALL_PREFIX=/usr
cd build
make -j $(nproc)
sudo make install
cd ../.. # Go back to workspace directory
rm -rf netcdf-fortran-4.6.1 # Clean up
- name: (Windows) Put MSYS2_MinGW64 on PATH
if: contains(matrix.os,'windows') && (!contains(matrix.mpi,'intel'))
# there is not yet an environment variable for this path from msys2/setup-msys2
run: echo "${{ runner.temp }}/msys64/mingw64/bin" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append
- name: (Windows) download MS-MPI setup (SDK is from MSYS2)
if: contains(matrix.os,'windows') && contains(matrix.mpi,'msmpi')
# run: curl -L -O https://github.com/microsoft/Microsoft-MPI/releases/download/v10.1.2/msmpisetup.exe 10.1.1
run: curl -L -O https://download.microsoft.com/download/a/5/2/a5207ca5-1203-491a-8fb8-906fd68ae623/msmpisetup.exe # 10.1.2
- name: (Windows) Install mpiexec.exe (-force needed to bypass GUI on headless)
if: contains(matrix.os,'windows') && contains(matrix.mpi,'msmpi')
run: .\msmpisetup.exe -unattend -force
- name: (Windows) test that mpiexec.exe exists
if: contains(matrix.os,'windows') && contains(matrix.mpi,'msmpi')
# can't use MSMPI_BIN as Actions doesn't update PATH from msmpisetup.exe
run: Test-Path "C:\Program Files\Microsoft MPI\Bin\mpiexec.exe" -PathType leaf
- name: (Windows) put MSMPI_BIN on PATH (where mpiexec is)
if: contains(matrix.os,'windows') && contains(matrix.mpi,'msmpi')
run: |
echo "C:\Program Files\Microsoft MPI\Bin\" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append
echo "/c/Program Files/Microsoft MPI/Bin/" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append
echo "MSMPI_BIN=C:\Program Files\Microsoft MPI\Bin\" | Out-File -FilePath $env:GITHUB_ENV -Append
- name: (Windows) Install MSYS2 msmpi package
if: contains(matrix.os,'windows') && contains(matrix.mpi,'msmpi')
shell: msys2 {0}
run: pacman --noconfirm -S mingw-w64-x86_64-msmpi
- name: (macOS) Set up Homebrew
if: contains(matrix.os,'macos')
id: set-up-homebrew
uses: Homebrew/actions/setup-homebrew@master
- name: (macOS) Install Homebrew gfortran
if: contains(matrix.os, 'macos')
run: |
# Only install gcc if not already available
which gfortran-${{ env.GCC_V }} || brew install gcc@${{ env.GCC_V }}
which gfortran-${{ env.GCC_V }}
BREW_PREFIX=$(brew --prefix)
which gfortran || ln -s ${BREW_PREFIX}/bin/gfortran-${{ env.GCC_V }} ${BREW_PREFIX}/bin/gfortran
- name: (macOS) Install homebrew MPICH
if: contains(matrix.mpi,'mpich') && contains(matrix.os,'macos')
run: |
brew install mpich
- name: (macOS) Install homebrew OpenMPI
if: contains(matrix.mpi,'openmpi') && contains(matrix.os,'macos')
run: |
brew install openmpi
- name: (macOS) Install homebrew HDF5
if: contains(matrix.os,'macos')
run: |
brew install hdf5
- name: (macOS) Install homebrew NetCDF
if: contains(matrix.os,'macos')
run: |
brew install netcdf
brew install netcdf-fortran
# Phase 1: Bootstrap fpm with existing version
- name: Install fpm
uses: fortran-lang/setup-fpm@v9
with:
fpm-version: 'v0.12.0'
# Backport gfortran shared libraries to the paths expected by the bootstrap fpm binary.
# The macOS x86_64 release used for bootstrapping has hardcoded library paths from the gcc version
# it was built with. If the versions match, skip this step. Otherwise, create symlinks.
# On ARM64 it runs under Rosetta 2 and needs /usr/local paths.
- name: MacOS patch libgfortran
if: contains(matrix.os, 'macos')
run: |
which gfortran-${{ env.GCC_V }}
which gfortran || true
BREW_PREFIX=$(brew --prefix)
# Query the actual library paths that fpm expects
echo "Checking library dependencies of fpm bootstrap binary..."
otool -L $(which fpm)
# Extract the gcc version from the bootstrap binary's library paths
BOOTSTRAP_GCC_VERSION=$(otool -L $(which fpm) | grep -o 'gcc@[0-9]\+' | head -n 1 | cut -d@ -f2)
if [ -z "$BOOTSTRAP_GCC_VERSION" ]; then
# Try alternative pattern: /lib/gcc/13/ -> extract 13
BOOTSTRAP_GCC_VERSION=$(otool -L $(which fpm) | grep libgfortran | grep -o '/lib/gcc/[0-9]\+/' | grep -o '[0-9]\+' | head -n 1)
fi
echo "Bootstrap fpm built with gcc@$BOOTSTRAP_GCC_VERSION"
echo "Current toolchain: gcc@${{ env.GCC_V }}"
if [ "$BOOTSTRAP_GCC_VERSION" == "${{ env.GCC_V }}" ]; then
echo "✓ Bootstrap gcc version matches current toolchain - no patching needed"
exit 0
fi
echo "⚠ Version mismatch detected - creating compatibility symlinks..."
# Find the actual Cellar path by following the symlink
if [ -L "${BREW_PREFIX}/opt/gcc@${{ env.GCC_V }}" ]; then
GCC_CELLAR_PATH=$(cd -P "${BREW_PREFIX}/opt/gcc@${{ env.GCC_V }}" && pwd)
else
GCC_CELLAR_PATH="${BREW_PREFIX}/Cellar/gcc@${{ env.GCC_V }}"/*
fi
echo "GCC Cellar path: $GCC_CELLAR_PATH"
# Find the actual library files
CURRENT_GFORTRAN=$(find "$GCC_CELLAR_PATH"/lib/gcc/${{ env.GCC_V }} -name "libgfortran.*.dylib" 2>/dev/null | head -n 1)
CURRENT_QUADMATH=$(find "$GCC_CELLAR_PATH"/lib/gcc/${{ env.GCC_V }} -name "libquadmath.*.dylib" 2>/dev/null | head -n 1)
CURRENT_GCC_S=$(find "$GCC_CELLAR_PATH"/lib/gcc/${{ env.GCC_V }} -name "libgcc_s.*.dylib" 2>/dev/null | head -n 1)
echo "Current gcc@${{ env.GCC_V }} libraries:"
echo " libgfortran: $CURRENT_GFORTRAN"
echo " libquadmath: $CURRENT_QUADMATH"
echo " libgcc_s: $CURRENT_GCC_S"
# Extract the expected libgfortran path and create symlink
LIBGFORTRAN_PATH=$(otool -L $(which fpm) | grep libgfortran | awk '{print $1}' | head -n 1)
if [ -n "$LIBGFORTRAN_PATH" ] && [ -n "$CURRENT_GFORTRAN" ]; then
TARGET_DIR=$(dirname "$LIBGFORTRAN_PATH")
echo "Creating directory: $TARGET_DIR"
sudo mkdir -p "$TARGET_DIR"
echo "Linking $CURRENT_GFORTRAN to $LIBGFORTRAN_PATH"
sudo ln -fs "$CURRENT_GFORTRAN" "$LIBGFORTRAN_PATH"
fi
# Extract the expected libquadmath path and create symlink
LIBQUADMATH_PATH=$(otool -L $(which fpm) | grep libquadmath | awk '{print $1}' | head -n 1)
if [ -n "$LIBQUADMATH_PATH" ] && [ -n "$CURRENT_QUADMATH" ]; then
TARGET_DIR=$(dirname "$LIBQUADMATH_PATH")
echo "Creating directory: $TARGET_DIR"
sudo mkdir -p "$TARGET_DIR"
echo "Linking $CURRENT_QUADMATH to $LIBQUADMATH_PATH"
sudo ln -fs "$CURRENT_QUADMATH" "$LIBQUADMATH_PATH"
fi
# Extract the expected libgcc_s path and create symlink
LIBGCC_PATH=$(otool -L $(which fpm) | grep libgcc_s | awk '{print $1}' | head -n 1)
if [ -n "$LIBGCC_PATH" ] && [ -n "$CURRENT_GCC_S" ]; then
TARGET_DIR=$(dirname "$LIBGCC_PATH")
echo "Creating directory: $TARGET_DIR"
sudo mkdir -p "$TARGET_DIR"
echo "Linking $CURRENT_GCC_S to $LIBGCC_PATH"
sudo ln -fs "$CURRENT_GCC_S" "$LIBGCC_PATH"
fi
- name: Remove fpm from path
shell: bash
run: |
mv $(which fpm) fpm-bootstrap${{ matrix.exe }}
echo "BOOTSTRAP=$PWD/fpm-bootstrap" >> $GITHUB_ENV
- name: (macOS/Ubuntu) Use gcc/g++ instead of Clang for C/C++ / ifx to build fpm
if: contains(matrix.os,'macOS') || contains(matrix.os,'ubuntu')
shell: bash
run: |
echo "FPM_FC=gfortran-${{ env.GCC_V }}" >> $GITHUB_ENV
echo "FPM_CC=gcc-${{ env.GCC_V }}" >> $GITHUB_ENV
echo "FPM_CXX=g++-${{ env.GCC_V }}" >> $GITHUB_ENV
- name: Build Fortran fpm (bootstrap)
shell: bash
run: |
${{ env.BOOTSTRAP }} build
- name: Run Fortran fpm (bootstrap)
shell: bash
run: |
${{ env.BOOTSTRAP }} run
${{ env.BOOTSTRAP }} run -- --version
${{ env.BOOTSTRAP }} run -- --help
- name: Test Fortran fpm (bootstrap)
if: (!contains(matrix.mpi,'intel'))
shell: bash
run: |
${{ env.BOOTSTRAP }} test ${{ matrix.release-flags }}
- name: Install Fortran fpm (bootstrap)
shell: bash
run: |
${{ env.BOOTSTRAP }} install
# Phase 2: Bootstrap fpm with itself
- name: Replace bootstrapping version
shell: bash
run: |
${{ env.BOOTSTRAP }} run --runner cp -- fpm-debug${{ matrix.exe }}
rm -v ${{ env.BOOTSTRAP }}
echo "FPM=$PWD/fpm-debug" >> $GITHUB_ENV
- name: Get version (normal)
if: github.event_name != 'release'
shell: bash
run: |
VERSION=$(git rev-parse --short HEAD)
echo "VERSION=$VERSION" >> $GITHUB_ENV
- name: Get version (release)
if: github.event_name == 'release'
shell: bash
run: |
VERSION=$(echo ${{ github.ref }} | cut -dv -f2)
echo "VERSION=$VERSION" >> $GITHUB_ENV
FPM_VERSION=$(${{ env.FPM }} --version | grep -o '${{ env.REGEX }}')
[ "$VERSION" = "$FPM_VERSION" ]
env:
REGEX: '[0-9]\{1,4\}\.[0-9]\{1,4\}\.[0-9]\{1,4\}'
- name: Build Fortran fpm
shell: bash
run: |
${{ env.FPM }} build ${{ matrix.release-flags }}
- name: Run Fortran fpm
shell: bash
run: |
${{ env.FPM }} run ${{ matrix.release-flags }}
${{ env.FPM }} run ${{ matrix.release-flags }} -- --version
${{ env.FPM }} run ${{ matrix.release-flags }} -- --help
- name: Install Fortran fpm
shell: bash
run: |
${{ env.FPM }} install ${{ matrix.release-flags }}
- name: Package release version
shell: bash
run: |
${{ env.FPM }} run ${{ matrix.release-flags }} --runner cp -- ${{ env.EXE }}
rm -v ${{ env.FPM }}
echo "FPM_RELEASE=${{ env.EXE }}" >> $GITHUB_ENV
env:
EXE: fpm-${{ env.VERSION }}-${{ matrix.os-arch }}${{ matrix.exe }}
- name: Use Intel compiler for the metapackage tests
if: contains(matrix.mpi,'intel')
shell: bash
run: |
echo "FPM_FC=ifx" >> $GITHUB_ENV
echo "FPM_CC=icx" >> $GITHUB_ENV
echo "FPM_CXX=icpx" >> $GITHUB_ENV
- name: Run metapackage tests using the release version
shell: bash
run: |
ci/meta_tests.sh "$PWD/${{ env.FPM_RELEASE }}"
fortran-lang-fpm-90bb83a/.github/workflows/CI.yml 0000664 0001750 0001750 00000037467 15145116760 022124 0 ustar alastair alastair name: CI
on:
push:
pull_request:
release:
types: [published]
env:
CI: "ON" # We can detect this in the build system and other vendors implement it
HOMEBREW_NO_ANALYTICS: "ON" # Make Homebrew installation a little quicker
HOMEBREW_NO_AUTO_UPDATE: "ON"
HOMEBREW_NO_BOTTLE_SOURCE_FALLBACK: "ON"
HOMEBREW_NO_GITHUB_API: "ON"
HOMEBREW_NO_INSTALL_CLEANUP: "ON"
jobs:
build:
runs-on: ${{ matrix.os }}
strategy:
fail-fast: false
matrix:
os: [ubuntu-latest, macos-14, macos-15-intel, windows-latest]
toolchain:
- {compiler: gcc, version: 10}
- {compiler: gcc, version: 11}
- {compiler: gcc, version: 12}
- {compiler: gcc, version: 13}
- {compiler: gcc, version: 14}
- {compiler: gcc, version: 15}
- {compiler: intel, version: 2025.2}
exclude:
- os: macos-14 # No Intel on MacOS anymore since 2024
toolchain: {compiler: intel, version: '2025.1'}
- os: macos-14 # Intel compiler does not support ARM (macos-14)
toolchain: {compiler: intel, version: '2025.2'}
- os: macos-14 # gcc@10 not available on macos-14 (ARM64)
toolchain: {compiler: gcc, version: 10}
- os: macos-15-intel # Intel compiler not available on macOS
toolchain: {compiler: intel, version: '2025.2'}
- os: macos-15-intel # gcc@10 not available on macos-15
toolchain: {compiler: gcc, version: 10}
- os: windows-latest # Doesn't pass build and tests yet
toolchain: {compiler: intel, version: '2025.2'}
- os: windows-latest # gcc 14 not available on Windows yet
toolchain: {compiler: gcc, version: 14}
- os: windows-latest # gcc 15 not available on Windows yet
toolchain: {compiler: gcc, version: 15}
- os: ubuntu-latest # gcc 15 not available on Ubuntu via setup-fortran yet
toolchain: {compiler: gcc, version: 15}
include:
- os: ubuntu-latest
os-arch: linux-x86_64
release-flags: --flag '--static -g -fbacktrace -O3'
- os: macos-14
os-arch: macos-arm64
release-flags: --flag '-g -fbacktrace -O3'
- os: macos-15-intel
os-arch: macos-x86_64
release-flags: --flag '-g -fbacktrace -O3'
- os: windows-latest
os-arch: windows-x86_64
release-flags: --flag '--static -g -fbacktrace -O3'
exe: .exe
- os: macos-14
toolchain: {compiler: gcc, version: 15}
release-flags: --flag '-g -fbacktrace -Og -fcheck=all,no-recursion -Wno-external-argument-mismatch'
steps:
- name: Checkout code
uses: actions/checkout@v6
- name: Setup Fortran compiler
uses: fortran-lang/setup-fortran@v1.8.1
id: setup-fortran
with:
compiler: ${{ matrix.toolchain.compiler }}
version: ${{ matrix.toolchain.version }}
# Phase 1: Bootstrap fpm with existing version
- name: Install fpm
uses: fortran-lang/setup-fpm@v9
with:
fpm-version: 'v0.12.0'
# Backport gfortran shared libraries to the paths expected by the bootstrap fpm binary.
# The macOS x86_64 release used for bootstrapping has hardcoded library paths from the gcc version
# it was built with. If the versions match, skip this step. Otherwise, create symlinks.
# On ARM64 it runs under Rosetta 2 and needs /usr/local paths.
- name: MacOS patch libgfortran
if: contains(matrix.os, 'macos')
run: |
which gfortran-${{ matrix.toolchain.version }}
which gfortran
BREW_PREFIX=$(brew --prefix)
# Query the actual library paths that fpm expects
echo "Checking library dependencies of fpm bootstrap binary..."
otool -L $(which fpm)
# Extract the gcc version from the bootstrap binary's library paths
BOOTSTRAP_GCC_VERSION=$(otool -L $(which fpm) | grep -o 'gcc@[0-9]\+' | head -n 1 | cut -d@ -f2)
if [ -z "$BOOTSTRAP_GCC_VERSION" ]; then
# Try alternative pattern: /lib/gcc/13/ -> extract 13
BOOTSTRAP_GCC_VERSION=$(otool -L $(which fpm) | grep libgfortran | grep -o '/lib/gcc/[0-9]\+/' | grep -o '[0-9]\+' | head -n 1)
fi
echo "Bootstrap fpm built with gcc@$BOOTSTRAP_GCC_VERSION"
echo "Current toolchain: gcc@${{ matrix.toolchain.version }}"
if [ "$BOOTSTRAP_GCC_VERSION" == "${{ matrix.toolchain.version }}" ]; then
echo "✓ Bootstrap gcc version matches current toolchain - no patching needed"
exit 0
fi
echo "⚠ Version mismatch detected - creating compatibility symlinks..."
# Find the actual Cellar path by following the symlink
if [ -L "${BREW_PREFIX}/opt/gcc@${{ matrix.toolchain.version }}" ]; then
GCC_CELLAR_PATH=$(cd -P "${BREW_PREFIX}/opt/gcc@${{ matrix.toolchain.version }}" && pwd)
else
GCC_CELLAR_PATH="${BREW_PREFIX}/Cellar/gcc@${{ matrix.toolchain.version }}"/*
fi
echo "GCC Cellar path: $GCC_CELLAR_PATH"
# Find the actual library files
CURRENT_GFORTRAN=$(find "$GCC_CELLAR_PATH"/lib/gcc/${{ matrix.toolchain.version }} -name "libgfortran.*.dylib" 2>/dev/null | head -n 1)
CURRENT_QUADMATH=$(find "$GCC_CELLAR_PATH"/lib/gcc/${{ matrix.toolchain.version }} -name "libquadmath.*.dylib" 2>/dev/null | head -n 1)
CURRENT_GCC_S=$(find "$GCC_CELLAR_PATH"/lib/gcc/${{ matrix.toolchain.version }} -name "libgcc_s.*.dylib" 2>/dev/null | head -n 1)
echo "Current gcc@${{ matrix.toolchain.version }} libraries:"
echo " libgfortran: $CURRENT_GFORTRAN"
echo " libquadmath: $CURRENT_QUADMATH"
echo " libgcc_s: $CURRENT_GCC_S"
# Extract the expected libgfortran path and create symlink
LIBGFORTRAN_PATH=$(otool -L $(which fpm) | grep libgfortran | awk '{print $1}' | head -n 1)
if [ -n "$LIBGFORTRAN_PATH" ] && [ -n "$CURRENT_GFORTRAN" ]; then
TARGET_DIR=$(dirname "$LIBGFORTRAN_PATH")
echo "Creating directory: $TARGET_DIR"
sudo mkdir -p "$TARGET_DIR"
echo "Linking $CURRENT_GFORTRAN to $LIBGFORTRAN_PATH"
sudo ln -fs "$CURRENT_GFORTRAN" "$LIBGFORTRAN_PATH"
fi
# Extract the expected libquadmath path and create symlink
LIBQUADMATH_PATH=$(otool -L $(which fpm) | grep libquadmath | awk '{print $1}' | head -n 1)
if [ -n "$LIBQUADMATH_PATH" ] && [ -n "$CURRENT_QUADMATH" ]; then
TARGET_DIR=$(dirname "$LIBQUADMATH_PATH")
echo "Creating directory: $TARGET_DIR"
sudo mkdir -p "$TARGET_DIR"
echo "Linking $CURRENT_QUADMATH to $LIBQUADMATH_PATH"
sudo ln -fs "$CURRENT_QUADMATH" "$LIBQUADMATH_PATH"
fi
# Extract the expected libgcc_s path and create symlink
LIBGCC_PATH=$(otool -L $(which fpm) | grep libgcc_s | awk '{print $1}' | head -n 1)
if [ -n "$LIBGCC_PATH" ] && [ -n "$CURRENT_GCC_S" ]; then
TARGET_DIR=$(dirname "$LIBGCC_PATH")
echo "Creating directory: $TARGET_DIR"
sudo mkdir -p "$TARGET_DIR"
echo "Linking $CURRENT_GCC_S to $LIBGCC_PATH"
sudo ln -fs "$CURRENT_GCC_S" "$LIBGCC_PATH"
fi
# gcc and g++ will point to clang/clang++: use versioned alias for fpm
- name: MacOS patch C and C++ compilers
if: contains(matrix.os, 'macos')
run: |
echo "CC=gcc-${{ matrix.toolchain.version }}" >> $GITHUB_ENV
echo "FPM_CC=gcc-${{ matrix.toolchain.version }}" >> $GITHUB_ENV
echo "CXX=g++-${{ matrix.toolchain.version }}" >> $GITHUB_ENV
echo "FPM_CXX=g++-${{ matrix.toolchain.version }}" >> $GITHUB_ENV
echo "FPM_LDFLAGS=-lstdc++" >> $GITHUB_ENV
- name: Remove fpm from path
shell: bash
run: |
mv $(which fpm) fpm-bootstrap${{ matrix.exe }}
echo "BOOTSTRAP=$PWD/fpm-bootstrap" >> $GITHUB_ENV
- name: Build Fortran fpm (bootstrap)
shell: bash
run: |
${{ env.BOOTSTRAP }} build
- name: Run Fortran fpm (bootstrap)
shell: bash
run: |
${{ env.BOOTSTRAP }} run
${{ env.BOOTSTRAP }} run -- --version
${{ env.BOOTSTRAP }} run -- --help
- name: Test Fortran fpm (bootstrap)
shell: bash
run: |
${{ env.BOOTSTRAP }} test --flag " -Wno-external-argument-mismatch"
- name: Install Fortran fpm (bootstrap)
shell: bash
run: |
${{ env.BOOTSTRAP }} install
# Phase 2: Bootstrap fpm with itself
- name: Replace bootstrapping version
shell: bash
run: |
${{ env.BOOTSTRAP }} run --runner cp -- fpm-debug${{ matrix.exe }}
rm -v ${{ env.BOOTSTRAP }}
echo "FPM=$PWD/fpm-debug" >> $GITHUB_ENV
- name: Get version (normal)
if: github.event_name != 'release'
shell: bash
run: |
VERSION=$(git rev-parse --short HEAD)
echo "VERSION=$VERSION" >> $GITHUB_ENV
- name: Get version (release)
if: github.event_name == 'release'
shell: bash
run: |
VERSION=$(echo ${{ github.ref }} | cut -dv -f2)
echo "VERSION=$VERSION" >> $GITHUB_ENV
FPM_VERSION=$(${{ env.FPM }} --version | grep -o '${{ env.REGEX }}')
[ "$VERSION" = "$FPM_VERSION" ]
env:
REGEX: '[0-9]\{1,4\}\.[0-9]\{1,4\}\.[0-9]\{1,4\}'
- name: Build Fortran fpm
shell: bash
run: |
${{ env.FPM }} build ${{ matrix.release-flags }}
- name: Run Fortran fpm
shell: bash
run: |
${{ env.FPM }} run ${{ matrix.release-flags }}
${{ env.FPM }} run ${{ matrix.release-flags }} -- --version
${{ env.FPM }} run ${{ matrix.release-flags }} -- --help
- name: Test Fortran fpm
shell: bash
run: |
${{ env.FPM }} test ${{ matrix.release-flags }}
- name: Install Fortran fpm
shell: bash
run: |
${{ env.FPM }} install ${{ matrix.release-flags }}
- name: Package release version
shell: bash
run: |
${{ env.FPM }} run ${{ matrix.release-flags }} --runner cp -- ${{ env.EXE }}
rm -v ${{ env.FPM }}
echo "FPM_RELEASE=${{ env.EXE }}" >> $GITHUB_ENV
env:
EXE: fpm-${{ env.VERSION }}-${{ matrix.os-arch }}-gcc-${{ matrix.toolchain.version }}${{ matrix.exe }}
- name: Run release version
shell: bash
run: |
ci/run_tests.sh "$PWD/${{ env.FPM_RELEASE }}"
- name: Upload artifact
uses: actions/upload-artifact@v6
with:
name: ${{ env.FPM_RELEASE }}
path: ${{ env.FPM_RELEASE }}
make-installer:
if: ${{ github.event_name == 'release' && contains(github.ref, 'v') || github.event_name == 'push' }}
runs-on: windows-latest
needs:
- build
strategy:
fail-fast: false
matrix:
gcc_v: [11,12,13]
steps:
- uses: actions/checkout@v6
- name: Download Artifacts
id: download_windows_artifacts
uses: actions/download-artifact@v7
with:
path: ${{ github.workspace }}
pattern: fpm-*-windows-*-gcc-${{ matrix.gcc_v }}.exe
- name: Get version (normal)
if: github.event_name != 'release'
shell: bash
run: |
VERSION=$(git rev-parse --short HEAD)
echo "VERSION=$VERSION" >> $GITHUB_ENV
- name: Get version (release)
if: github.event_name == 'release'
shell: bash
run: |
VERSION=$(echo ${{ github.ref }} | cut -dv -f2)
echo "VERSION=$VERSION" >> $GITHUB_ENV
env:
REGEX: '[0-9]\{1,4\}\.[0-9]\{1,4\}\.[0-9]\{1,4\}'
- name: Setup MinGW (MSYS2)
uses: msys2/setup-msys2@v2
with:
msystem: MINGW64
update: false
install: >-
wget
unzip
- name: Fetch Windows executable
shell: msys2 {0}
run: |
set -e
download_path='${{ steps.download_windows_artifacts.outputs.download-path }}'
download_path=$(printf '%s\n' "$download_path" | head -n1)
if [ -z "$download_path" ]; then
echo "download-artifact did not report a download path" >&2
exit 1
fi
if command -v cygpath >/dev/null 2>&1; then
posix_path=$(cygpath -u "$download_path")
else
posix_path="$download_path"
fi
exe_path=$(find "$posix_path" -maxdepth 2 -type f -name "fpm-*-windows-*-gcc-${{ matrix.gcc_v }}.exe" | head -n 1)
if [ -z "$exe_path" ]; then
echo "Windows executable not found under $posix_path" >&2
ls -al "$posix_path" || true
exit 1
fi
cp "$exe_path" ./ci/fpm.exe
- name: Fetch Git for Windows
shell: msys2 {0}
run: |
cd ./ci
wget ${{ env.git_download }} -O MinGit.zip
unzip MinGit.zip -d MinGit
env:
git_download: "https://github.com/git-for-windows/git/releases/download/v2.33.1.windows.1/MinGit-2.33.1-64-bit.zip"
- name: Fetch EnVar Plugin for NSIS
shell: msys2 {0}
run: |
cd ./ci
wget ${{ env.envar_download }} -O EnVar-Plugin.zip
mkdir EnVar_plugin
unzip EnVar-Plugin.zip -d EnVar_plugin
env:
envar_download: "https://github.com/GsNSIS/EnVar/releases/download/v0.3.1/EnVar-Plugin.zip"
- name: Install NSIS
run: choco install nsis -y
shell: pwsh
- name: Add NSIS to PATH
shell: pwsh
run: |
$dirs = @(
"${env:ProgramFiles(x86)}\NSIS",
"${env:ProgramFiles}\NSIS"
) | Where-Object { $_ -and (Test-Path $_) }
if (-not $dirs) { throw "NSIS not found under Program Files." }
$dirs | ForEach-Object { $_ | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append }
- name: Generate installer
run: |
cd ./ci
makensis fpm-installer.nsi
move fpm-installer.exe fpm-installer-${{ env.VERSION }}-gcc-${{ matrix.gcc_v }}.exe
- name: Upload artifact
uses: actions/upload-artifact@v6
with:
name: fpm-installer-gcc-${{ matrix.gcc_v }}
path: ci/fpm-installer-${{ env.VERSION }}-gcc-${{ matrix.gcc_v }}.exe
upload-artifacts:
if: ${{ github.event_name == 'release' && contains(github.ref, 'v') || github.event_name == 'push' }}
runs-on: ubuntu-latest
needs:
- build
- make-installer
steps:
- id: deploy-on-push
if: ${{ github.event_name == 'push' }}
run:
echo "::set-output name=result::${{ env.DEPLOY_BRANCH }}"
env:
DEPLOY_BRANCH: ${{ secrets.DEPLOY_BRANCH && contains(github.ref, secrets.DEPLOY_BRANCH) && 1 || 0 }}
- uses: actions/checkout@v6
if: ${{ github.event_name == 'push' }}
- name: Download Artifacts
uses: actions/download-artifact@v7
with:
path: fpm-cd-artifacts
pattern: 'fpm-*-gcc-12*'
merge-multiple: true
- name: Normalize file names for continuous delivery
if: ${{ github.event_name == 'push' }}
run: |
cd fpm-cd-artifacts
for output in fpm-*; do
mv -v $(basename $output) $(basename $output | sed -E '${{ env.replace }}')
done
env:
replace: 's/-([0-9]+\.[0-9]+\.[0-9]+-[0-9]+-g)?[0-9a-f]+//'
- name: Create SHA256 checksums
run: |
cd fpm-cd-artifacts
for output in fpm-*; do
sha256sum $(basename "$output") | tee $(basename "$output").sha256
done
- name: Move/Create continuous tag
if: ${{ github.event_name == 'push' && steps.deploy-on-push.outputs.result != 0 }}
run: |
git tag --force 'current' ${{ github.sha }}
git push --tags --force
- name: Upload assets
uses: svenstaro/upload-release-action@v2
if: ${{ github.event_name == 'release' || steps.deploy-on-push.outputs.result != 0 }}
with:
repo_token: ${{ secrets.GITHUB_TOKEN }}
file: fpm-cd-artifacts/*
file_glob: true
tag: ${{ github.event_name == 'release' && github.ref || 'current'}}
overwrite: true
fortran-lang-fpm-90bb83a/README.md 0000664 0001750 0001750 00000015305 15145116760 016753 0 ustar alastair alastair
# [Fortran Package Manager](https://fpm.fortran-lang.org/)
Fortran Package Manager (fpm) is a package manager and build system for Fortran.
Its key goal is to improve the user experience of Fortran programmers.
It does so by making it easier to build your Fortran program or library, run the
executables, tests, and examples, and distribute it as a dependency to other
Fortran projects.
Fpm's user interface is modeled after [Rust's Cargo](https://doc.rust-lang.org/cargo/),
so if you're familiar with that tool, you will feel at home with fpm.
Fpm's long term vision is to nurture and grow the ecosystem of modern Fortran
applications and libraries.
Fpm is an early prototype and is evolving rapidly.
You can use it to build and package your Fortran projects, as well as to use
[existing fpm packages](https://github.com/fortran-lang/fpm-registry) as dependencies.
Fpm's behavior and user interface may change as it evolves, however as fpm
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/).
Fortran Package Manager is not to be confused with
[Jordan Sissel's fpm](https://github.com/jordansissel/fpm), a more general,
non-Fortran related package manager.
**Website: **
## [Download](https://fpm.fortran-lang.org/install/index.html)
Fpm is available on many platforms and through multiple package managers, see our Documentation
webpage for a list of **[All Supported Installations](https://fpm.fortran-lang.org/install/index.html)**.
The easiest installation routes are shown below.
### [Binary](https://github.com/fortran-lang/fpm/releases)
Binaries for the latest stable release are available [to download](https://github.com/fortran-lang/fpm/releases/latest) for Windows, MacOS, and Linux.
**Note:** On Linux and MacOS, you will need to enable executable permission before you can use the binary.
_e.g._ `$ chmod u+x fpm-0.6.0-linux-x86_64`
The binaries at the [current tag](https://github.com/fortran-lang/fpm/releases/tag/current) are updated automatically to always provide the current git version from the default branch.
### [Conda]
Fpm is available on [conda-forge], to add `conda-forge` to your channels use:
```sh
conda config --add channels conda-forge
```
Fpm can be installed with:
```sh
conda create -n fpm fpm
conda activate fpm
```
The conda package manager can be installed from [miniforge](https://github.com/conda-forge/miniforge/releases)
or from [miniconda](https://docs.conda.io/en/latest/miniconda.html).
[Conda]: https://conda.io
[conda-forge]: https://conda-forge.org/
### [Homebrew](https://brew.sh/)
The Fortran Package Manager (fpm) is available for the [Homebrew](https://brew.sh/) package manager via an additional tap.
To install fpm via brew, include the new tap and install using
```sh
brew tap fortran-lang/fortran
brew install fpm
```
Binary distributions are available for MacOS 11 (Catalina) and 12 (Big Sur) for x86_64 architectures. For other platforms fpm will be built locally from source automatically.
Fpm should be available and functional after those steps.
For more details checkout the tap [here](https://github.com/fortran-lang/homebrew-fortran).
## [Get started](https://fpm.fortran-lang.org/tutorial/index.html)
**Follow our [Quickstart Tutorial](https://fpm.fortran-lang.org/tutorial/hello-fpm.html) to get familiar with fpm**.
### Start a new project
Creating a new *fpm* project is as simple as running the command
`fpm new project_name`. This will create a new folder in your current directory
with the following contents and initialized as a git repository.
* `fpm.toml` – with your project’s name and some default standard meta-data
* `README.md` – with your project’s name
* `.gitignore`
* `src/project_name.f90` – with a simple hello world subroutine
* `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
*fpm* understands the basic commands:
* `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
arguments can also be passed to the executable(s) or test(s) with the option
`-- some arguments`.
See additional instructions in the [Packaging guide](PACKAGING.md) or
the [manifest reference](https://fpm.fortran-lang.org/spec/manifest.html).
## Environmental variables
The table below lists the environment variables that control `fpm`'s choice of compilers,
compiler flags, archiver locations, and link flags, each of which can be overridden by
passing `fpm` flags also shown in the table.
| Environment Variable | Defines | Overridden by |
| :------------------- | :-------------------- | :--------------- |
| `FPM_FC` | Fortran compiler path | `--compiler` |
| `FPM_CC` | C compiler path | `--c-compiler` |
| `FPM_CXX` | C++ compiler path | `--cxx-compiler` |
| `FPM_FFLAGS` | Fortran compiler flags| `--flag` |
| `FPM_CFLAGS` | C compiler flags | `--c-flag` |
| `FPM_CXXFLAGS` | C++ compiler flags | `--cxx-flag` |
| `FPM_AR` | Archiver path | `--archiver` |
| `FPM_LDFLAGS` | Link flags | `--link-flag` |
fortran-lang-fpm-90bb83a/CONTRIBUTING.md 0000664 0001750 0001750 00000012520 15145116760 017721 0 ustar alastair alastair # Contributing to the Fortran Package Manager
Thank you for considering contributing to the Fortran Package Manager (*fpm*).
Please review and follow these guidelines to make the contribution process
simple and effective for all involved. It will help communicate that you
respect the time of the community developers. In return, the community will
help address your problem, evaluate changes, and guide you through your pull
requests.
By contributing to *fpm*, you certify that you own or are allowed to share the
content of your contribution under the [fpm license](LICENSE).
* [Style](#style)
* [Reporting a bug](#reporting-a-bug)
* [Suggesting a feature](#suggesting-a-feature)
* [Workflow](#workflow)
* [General guidelines](#general-guidelines)
* [For new contributors](#for-new-contributors)
## Style
Please follow the
[Fortran stdlib style guide](https://github.com/fortran-lang/stdlib/blob/master/STYLE_GUIDE.md)
for any Fortran code that you contribute.
This allows us to focus on substance rather than style.
## Reporting a bug
A bug is a *demonstrable problem* caused by the code in this repository.
Good bug reports are extremely valuable to us—thank you!
Before opening a bug report:
1. Check if the issue has already been reported
([issues](https://github.com/fortran-lang/fpm/issues)).
2. Check if it is still an issue or it has been fixed?
Try to reproduce it with the latest version from the default branch.
3. Isolate the problem and create a minimal test case.
A good bug report should include all information needed to reproduce the bug.
Please be as detailed as possible:
1. Which version of *fpm* are you using? Please be specific.
2. What are the steps to reproduce the issue?
3. What is the expected outcome?
4. What happens instead?
This information will help the community diagnose the issue quickly and with
minimal back-and-forth.
## Suggesting a feature
Before suggesting a new feature, take a moment to find out if it fits the scope
of the project, or if it has already been discussed. It is up to you to provide
a strong argument to convince the community of the benefits of this feature.
Please provide as much detail and context as possible. If applicable, include a
mocked-up snippet of what the output or behavior would look like with this
feature implemented. “Crazy”, out-of-the-box ideas are especially welcome.
It’s quite possible that we are not considering an unusually creative solution.
## Workflow
*fpm* is a community project. There is no one single person making final
decisions. This is the workflow that we follow:
1. Open a [new issue](https://github.com/fortran-lang/fpm/issues/new) to
describe a bug or propose a new feature.
Refer to the earlier sections on how to write a good bug report or feature
request.
2. Discuss with the community and reach majority consensus about what should be
done about the bug or feature request.
We define “majority” loosely as 80%.
This means that at least 4 of 5 people engaged in the discussion should be
able to agree on the next step.
This allows us to have the community mostly agree while not getting stuck if
one person disagrees.
At this stage, the scope of the fix/feature, its behavior, and API if
applicable should be defined.
Only when you have community consensus on these items you should proceed to
writing code and opening a PR.
**When actively working on code towards a PR, please assign yourself to the
issue on GitHub.**
This is good collaborative practice to avoid duplicated effort and also
inform others what you are currently working on.
3. Open a new Pull Request (PR) with your contribution.
The body of the PR should at least include a bullet-point summary of the
changes, and a detailed description is encouraged.
If the PR completely addresses the issue you opened in step 1, include in
the PR description the following line: `Fixes #`.
4. Request reviewers to your PR.
For small bug fixes or documentation improvements, 1 to 2 reviewers is
sufficient.
For implementation of bigger features, request 3 to 4 or more reviewers.
Ideally, request reviewers that participated in step 2.
5. If your PR implements a feature that adds or changes the behavior of *fpm*,
your PR must also include appropriate changes to the documentation.
This workflow can evolve and change over time as we learn how best to work
together. If you have an idea on how to improve the workflow itself, please
open an issue and we’ll discuss it.
## General guidelines
* A PR should implement *only one* feature or bug fix.
* Do not commit changes to files that are irrelevant to your feature or bug fix.
* Smaller PRs are better than large PRs, and will lead to a shorter review and
merge cycle
* Add tests for your feature or bug fix to be sure that it stays functional and useful
* Be open to constructive criticism and requests for improving your code.
* Again, please follow the
[Fortran stdlib style guide](https://github.com/fortran-lang/stdlib/blob/master/STYLE_GUIDE.md).
## For new contributors
If you have never created a pull request before, welcome :tada:.
You can learn how from
[this great tutorial](https://app.egghead.io/courses/how-to-contribute-to-an-open-source-project-on-github).
Don’t know where to start?
You can start by looking through the list of
[open issues](https://github.com/fortran-lang/fpm/issues).
fortran-lang-fpm-90bb83a/test/ 0000775 0001750 0001750 00000000000 15145116760 016447 5 ustar alastair alastair fortran-lang-fpm-90bb83a/test/new_test/ 0000775 0001750 0001750 00000000000 15145116760 020277 5 ustar alastair alastair fortran-lang-fpm-90bb83a/test/new_test/new_test.f90 0000664 0001750 0001750 00000021636 15145116760 022457 0 ustar alastair alastair program new_test
use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit
use fpm_filesystem, only : is_dir, list_files, exists, windows_path, join_path, &
dirname, run
use fpm_strings, only : string_t, operator(.in.)
use fpm_environment, only : get_os_type
use fpm_environment, only : OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD, OS_WINDOWS
implicit none
type(string_t), allocatable :: file_names(:)
integer :: i, j, k
character(len=:),allocatable :: cmdpath
character(len=:),allocatable :: path
character(len=*),parameter :: scr = 'fpm_scratch_'
character(len=*),parameter :: cmds(*) = [character(len=80) :: &
! run a variety of "fpm new" variations and verify expected files are generated
'new', &
'new name-with-hyphens', &
'new '//scr//'A', &
'new '//scr//'B --lib', &
'new '//scr//'C --app', &
'new '//scr//'D --test', &
'new '//scr//'E --lib --test ', &
'new '//scr//'F --lib --app', &
'new '//scr//'G --test --app', &
'new '//scr//'H --example', &
'new '//scr//'BB --lib', &
'new '//scr//'BB --test ', &
'new '//scr//'BB --backfill --test', &
'new '//scr//'CC --test --src --app', &
'new --version', &
'new --help']
integer :: estat, cstat
character(len=256) :: message
character(len=:),allocatable :: directories(:)
character(len=:),allocatable :: shortdirs(:)
character(len=:),allocatable :: expected(:)
logical,allocatable :: tally(:)
logical :: IS_OS_WINDOWS
character(len=*),parameter :: dirs_to_be_removed = 'fpm_scratch_* name-with-hyphens'
character(len=:),allocatable :: rm_command
write(*,'(g0:,1x)')'TEST new SUBCOMMAND (draft):'
cmdpath = get_command_path()
allocate(tally(0))
shortdirs=[character(len=80) :: 'A','B','C','D','E','F','G','H','BB','CC']
allocate(character(len=80) :: directories(size(shortdirs)))
!! SEE IF EXPECTED FILES ARE GENERATED
!! Issues:
!! o assuming fpm command is in expected path and the new version
!! o DOS versus POSIX filenames
is_os_windows=.false.
select case (get_os_type())
case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD)
call execute_command_line('rm -rf fpm_scratch_*',exitstat=estat,cmdstat=cstat,cmdmsg=message)
path=cmdpath
case (OS_WINDOWS)
path=windows_path(cmdpath)
is_os_windows=.true.
do i=1,size(directories)
call execute_command_line('rmdir /s /q fpm_scratch_'//trim(shortdirs(i)),exitstat=estat,&
cmdstat=cstat,cmdmsg=message)
end do
case default
write(*,*)'ERROR: unknown OS. Stopping test'
stop 2
end select
do i=1,size(directories)
directories(i)=scr//trim(shortdirs(i))
if( is_dir(trim(directories(i))) ) then
write(*,*)'ERROR:',trim( directories(i) ),' already exists'
write(*,*)' you must remove scratch directories before performing this test'
write(*,'(*(g0:,1x))')'directories:',(trim(directories(j)),j=1,size(directories)),'name-with-hyphens'
stop
endif
enddo
! execute the fpm(1) commands
do i=1,size(cmds)
message=''
write(*,*)path//' '//cmds(i)
call execute_command_line(path//' '//cmds(i),exitstat=estat,cmdstat=cstat,cmdmsg=message)
write(*,'(*(g0))')'CMD=',trim(cmds(i)),' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message)
enddo
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)/=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
! Test that generated manifests are valid by building one of the packages
write(*,'(a)') ' Testing that generated manifest is valid (can be built)...'
call execute_command_line(path//' build '//scr//'A', exitstat=estat, cmdstat=cstat, cmdmsg=message)
if (estat == 0) then
write(*,'(a)') ' Generated manifest is valid - build succeeded'
tally = [tally, .true.]
else
write(*,'(a,i0)') ' ERROR: Generated manifest is invalid - build failed with exit status ', estat
tally = [tally, .false.]
end if
! clean up scratch files; might want an option to leave them for inspection
select case (get_os_type())
case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD)
rm_command = 'rm -rf ' // dirs_to_be_removed
case (OS_WINDOWS)
do i=1,size(directories)
rm_command = 'rmdir /s /q fpm_scratch_'//trim(shortdirs(i))
call execute_command_line('rmdir /s /q fpm_scratch_'//trim(shortdirs(i)),exitstat=estat,&
cmdstat=cstat,cmdmsg=message)
end do
rm_command = 'rmdir /s /q name-with-hyphens'
end select
call execute_command_line(rm_command, exitstat=estat,cmdstat=cstat,cmdmsg=message)
write(*,'("new TEST TALLY=",*(g0))')tally
if(all(tally))then
write(*,'(*(g0))')'PASSED: all ',count(tally),' tests passed '
else
write(*,*)'FAILED: PASSED=',count(tally),' FAILED=',count(.not.tally)
stop 5
endif
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
fortran-lang-fpm-90bb83a/test/help_test/ 0000775 0001750 0001750 00000000000 15145116760 020436 5 ustar alastair alastair fortran-lang-fpm-90bb83a/test/help_test/help_test.f90 0000664 0001750 0001750 00000025603 15145116760 022753 0 ustar alastair alastair program help_test
! note hardcoded len=k1 instead of len=: in this test is a work-around a gfortran bug in old
! pre-v8.3 versions
use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit
use fpm_filesystem, only : dirname, join_path, exists
use fpm_environment, only : get_os_type, OS_WINDOWS
implicit none
integer :: i
integer :: be, af
character(len=:),allocatable :: path
integer :: estat, cstat
integer,parameter :: k1=132
character(len=k1) :: message
logical,allocatable :: tally(:)
!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',&
'help clean >> fpm_scratch_help.txt',&
'help publish >> fpm_scratch_help.txt',&
'--version >> fpm_scratch_help.txt',&
! generate manual
' help manual > fpm_scratch_manual.txt']
!'fpm run >> fpm_scratch_help.txt',&
!'fpm run -- --list >> fpm_scratch_help.txt',&
!'fpm run -- list --list >> fpm_scratch_help.txt',&
character(len=*),parameter :: names(*)=[character(len=10) ::&
'fpm','new','update','build','run','test','runner','install','list','help','clean']
character(len=:), allocatable :: prog
integer :: length
! 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==0,cstat==0])]
call swallow('fpm_scratch_help.txt',page1)
if(size(page1)<3)then
write(*,*)'help for '//names(i)//' ridiculiously small'
tally=[tally,.false.]
exit
endif
!!write(*,*)findloc(page1,'NAME')==1
be=count(.not.tally)
tally=[tally,count(page1=='NAME')==1]
tally=[tally,count(page1=='SYNOPSIS')==1]
tally=[tally,count(page1=='DESCRIPTION')==1]
af=count(.not.tally)
if(be/=af)then
write(*,*)'missing expected sections in ',names(i)
write(*,*)page1(1) ! assuming at least size 1 for debugging mingw
write(*,*)count(page1=='NAME')
write(*,*)count(page1=='SYNOPSIS')
write(*,*)count(page1=='DESCRIPTION')
write(*,'(a)')page1
endif
write(*,*)'have completed ',count(tally),' tests'
call wipe('fpm_scratch_help.txt')
enddo
! execute the fpm(1) commands
do i=1,size(cmds)
message=''
path= prog //' '//cmds(i)
call execute_command_line(path,exitstat=estat,cmdstat=cstat,cmdmsg=message)
write(*,'(*(g0))')'CMD=',path,' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message)
tally=[tally,all([estat==0,cstat==0])]
enddo
! compare book written in fragments with manual
call swallow('fpm_scratch_help.txt',book1)
call swallow('fpm_scratch_manual.txt',book2)
! get rid of lines from run() which is not on stderr at the moment
book1=pack(book1,index(book1,' + build/')==0)
book2=pack(book1,index(book2,' + build/')==0)
write(*,*)'book1 ',size(book1), len(book1)
write(*,*)'book2 ',size(book2), len(book2)
if(size(book1)/=size(book2))then
write(*,*)'manual and "debug" appended pages are not the same size'
tally=[tally,.false.]
else
if(all(book1/=book2))then
tally=[tally,.false.]
write(*,*)'manual and "debug" appended pages are not the same'
else
write(*,*)'manual and "debug" appended pages are the same'
tally=[tally,.true.]
endif
endif
! overall size of manual
!chars=size(book2)
!lines=max(count(char(10)==book2),count(char(13)==book2))
chars=sum(len_trim(book2)) ! SUM TRIMMED LENGTH
lines=size(book2)
if( (chars<12000) .or. (lines<350) )then
write(*,*)'"debug" manual is suspiciously small, bytes=',chars,' lines=',lines
tally=[tally,.false.]
else
write(*,*)'"debug" manual size in bytes=',chars,' lines=',lines
tally=[tally,.true.]
endif
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==0)then
close(unit=lun,iostat=ios,status='delete',iomsg=message)
if(ios/=0)then
write(*,*)''//trim(message)
endif
else
write(*,*)''//trim(message)
endif
end subroutine wipe
subroutine slurp(filename,text)
implicit none
!$@(#) M_io::slurp(3f): allocate text array and read file filename into it
character(*),intent(in) :: filename ! filename to shlep
character(len=1),allocatable,intent(out) :: text(:) ! array to hold file
integer :: nchars, igetunit, ios
character(len=k1) :: message
character(len=4096) :: local_filename
ios=0
nchars=0
message=''
open(newunit=igetunit, file=trim(filename), action="read", iomsg=message,&
&form="unformatted", access="stream",status='old',iostat=ios)
local_filename=filename
if(ios==0)then ! if file was successfully opened
inquire(unit=igetunit, size=nchars)
if(nchars<=0)then
call stderr_local( '*slurp* empty file '//trim(local_filename) )
return
endif
! read file into text array
if(allocated(text))deallocate(text) ! make sure text array not allocated
allocate ( text(nchars) ) ! make enough storage to hold file
read(igetunit,iostat=ios,iomsg=message) text ! load input file -> text array
if(ios/=0)then
call stderr_local( '*slurp* bad read of '//trim(local_filename)//':'//trim(message) )
endif
else
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)==nl)then
linelength=max(linelength,length)
lines=lines+1
length=0
else
length=length+1
endif
enddo
if(sz>0)then
if(array(sz)/=nl)then
lines=lines+1
endif
endif
if(allocated(table))deallocate(table)
!intel-bug!allocate(character(len=linelength) :: table(lines))
allocate(character(len=k1) :: table(lines))
table=' '
linecount=1
position=1
do i=1,sz
if(array(i)==nl)then
linecount=linecount+1
position=1
elseif(array(i)==cr)then
elseif(linelength/=0)then
if(position>len(table))then
write(*,*)' adding character past edge of text',table(linecount),array(i)
elseif(linecount>size(table))then
write(*,*)' adding line past end of text',linecount,size(table)
else
table(linecount)(position:position)=array(i)
endif
position=position+1
endif
enddo
end function page
end program help_test
fortran-lang-fpm-90bb83a/test/fpm_test/ 0000775 0001750 0001750 00000000000 15145116760 020270 5 ustar alastair alastair fortran-lang-fpm-90bb83a/test/fpm_test/test_compiler.f90 0000664 0001750 0001750 00000033657 15145116760 023477 0 ustar alastair alastair !> Define tests for the `fpm_compiler` module
module test_compiler
use testsuite, only : new_unittest, unittest_t, error_t, test_failed, &
& check_string
use fpm_environment, only : OS_WINDOWS, OS_LINUX
use fpm_compiler , only : compiler_t, new_compiler, tokenize_flags
use fpm_strings , only : string_t, operator(==)
use fpm_command_line, only: get_fpm_env
use fpm_compile_commands, only: compile_command_table_t
implicit none
private
public :: collect_compiler
contains
!> Collect all exported unit tests
subroutine collect_compiler(testsuite)
!> Collection of tests
type(unittest_t), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
& new_unittest("check-fortran-source-runs", test_check_fortran_source_runs), &
& new_unittest("check-c-source-runs", test_check_c_source_runs), &
& new_unittest("check-cxx-source-runs", test_check_cxx_source_runs), &
& new_unittest("tokenize-flags", test_tokenize_flags), &
& new_unittest("compile-commands-unix", test_register_compile_command_unix), &
& new_unittest("compile-commands-windows", test_register_compile_command_windows), &
& new_unittest("get-default-flags-pic", test_get_default_flags_pic)]
end subroutine collect_compiler
subroutine test_check_fortran_source_runs(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(:), allocatable :: fc,cc,cxx
type(compiler_t) :: compiler
!> Get default compiler
fc = get_fpm_env("FC", default="gfortran")
cc = get_fpm_env("CC", default=" ")
cxx = get_fpm_env("CXX", default=" ")
call new_compiler(compiler, fc, cc, cxx, echo=.false., verbose=.false.)
if (compiler%is_unknown()) then
call test_failed(error, "Cannot initialize Fortran compiler")
return
end if
!> Test fortran-source runs
if (.not.compiler%check_fortran_source_runs("print *, 'Hello world!'; end")) then
call test_failed(error, "Cannot run Fortran hello world")
return
end if
!> Test with invalid flags
if (compiler%check_fortran_source_runs("print *, 'Hello world!'; end", &
link_flags=" -some-really-invalid-link-flag")) then
call test_failed(error, "Invalid link flags did not trigger an error")
return
end if
if (compiler%check_fortran_source_runs("print *, 'Hello world!'; end", &
compile_flags=" -certainly-not-a-build/flag")) then
call test_failed(error, "Invalid compile flags did not trigger an error")
return
end if
if (compiler%check_fortran_source_runs("print *, 'Hello world!'; end", &
compile_flags=" -certainly-not-a-build/flag", &
link_flags=" -some-really-invalid-link-flag")) then
call test_failed(error, "Invalid build and link flags did not trigger an error")
return
end if
!> Test the flag check wrapper
if (compiler%check_flags_supported(compile_flags='-Werror=unknown-flag') &
.and. .not. compiler%is_intel()) then ! Intel will not trigger an error
call test_failed(error, "Invalid compile flags did not trigger an error")
return
end if
if (compiler%check_flags_supported(compile_flags='-not-a-compile-flag')) then
call test_failed(error, "Invalid compile flags did not trigger an error")
return
end if
if (compiler%check_flags_supported(link_flags='-Wl,--nonexistent-linker-option')) then
call test_failed(error, "Invalid link flags did not trigger an error")
return
end if
if (compiler%check_flags_supported(compile_flags='-Werror=eunknown-flag', &
link_flags='-Wl,--nonexistent-linker-option')) then
call test_failed(error, "Invalid compile and link flags did not trigger an error")
return
end if
end subroutine test_check_fortran_source_runs
subroutine test_check_c_source_runs(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(:), allocatable :: fc,cc,cxx
type(compiler_t) :: compiler
!> Get default compiler
fc = get_fpm_env("FC", default="gfortran")
cc = get_fpm_env("CC", default=" ")
cxx = get_fpm_env("CXX", default=" ")
call new_compiler(compiler, fc, cc, cxx, echo=.false., verbose=.false.)
if (compiler%is_unknown()) then
call test_failed(error, "Cannot initialize compiler")
return
end if
!> Skip tests if no C compiler is available
if (len_trim(compiler%cc) == 0) then
return
end if
!> Test C source runs with simple hello world
if (.not.compiler%check_c_source_runs( &
'#include ' // new_line('a') // &
'int main() { printf("Hello C world!"); return 0; }')) then
call test_failed(error, "Cannot run C hello world with compiler "//compiler%cc)
return
end if
!> Test with invalid source that should fail
if (compiler%check_c_source_runs( &
'#include ' // new_line('a') // &
'int main() { return 1; }')) then ! Returns error code 1
call test_failed(error, "C program returning error code 1 did not fail")
return
end if
!> Test with invalid flags
if (compiler%check_c_source_runs( &
'#include ' // new_line('a') // &
'int main() { return 0; }', &
compile_flags=" -invalid-c-flag")) then
call test_failed(error, "Invalid C compile flags did not trigger an error")
return
end if
!> Test the C flag check wrapper
if (compiler%check_c_flags_supported(compile_flags='-not-a-c-flag')) then
call test_failed(error, "Invalid C compile flags did not trigger an error")
return
end if
end subroutine test_check_c_source_runs
subroutine test_check_cxx_source_runs(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(:), allocatable :: fc,cc,cxx
type(compiler_t) :: compiler
!> Get default compiler
fc = get_fpm_env("FC", default="gfortran")
cc = get_fpm_env("CC", default=" ")
cxx = get_fpm_env("CXX", default=" ")
call new_compiler(compiler, fc, cc, cxx, echo=.false., verbose=.false.)
if (compiler%is_unknown()) then
call test_failed(error, "Cannot initialize compiler")
return
end if
!> Skip tests if no C++ compiler is available or if it's set to a space
if (len_trim(compiler%cxx) == 0 .or. trim(compiler%cxx) == " ") then
return
end if
!> Test C++ source runs with simple hello world
!> Only fail if we're sure the compiler is available
if (.not.compiler%check_cxx_source_runs( &
'#include ' // new_line('a') // &
'int main() { return 0; }')) then
!> This might fail if C++ compiler is misconfigured, so just skip further tests
return
end if
!> Test with invalid source that should fail
if (compiler%check_cxx_source_runs( &
'#include ' // new_line('a') // &
'int main() { return 1; }')) then ! Returns error code 1
call test_failed(error, "C++ program returning error code 1 did not fail")
return
end if
!> Test with invalid flags
if (compiler%check_cxx_source_runs( &
'#include ' // new_line('a') // &
'int main() { return 0; }', &
compile_flags=" -invalid-cxx-flag")) then
call test_failed(error, "Invalid C++ compile flags did not trigger an error")
return
end if
!> Test the C++ flag check wrapper
if (compiler%check_cxx_flags_supported(compile_flags='-not-a-cxx-flag')) then
call test_failed(error, "Invalid C++ compile flags did not trigger an error")
return
end if
end subroutine test_check_cxx_source_runs
subroutine test_tokenize_flags(error)
type(error_t), allocatable, intent(out) :: error
character(:), allocatable :: flags
type(string_t), allocatable :: tokens(:)
integer :: i
flags = '-I/path/to/include -I /test -I"/path/to/include with spaces" ' // &
'-I "spaces here too" -L/path/to/lib -lmylib -O2 -g -Wall'
call tokenize_flags(flags, tokens)
do i = 1, size(tokens)
print *, "Tokens ", i, ": ", tokens(i)%s
end do
if (tokens(1)%s /= '-I/path/to/include') then
call test_failed(error, "Tokenization of flags failed: expected '-I/path/to/include'")
return
end if
if (tokens(2)%s /= '-I/test') then
call test_failed(error, "Tokenization of flags failed: expected '-I/test'")
return
end if
if (tokens(3)%s /= '-I"/path/to/include with spaces"') then
call test_failed(error, 'Tokenization of flags failed: expected -I"/path/to/include with spaces"')
return
end if
if (size(tokens) /= 9) then
call test_failed(error, "Tokenization of flags failed: expected 9 tokens")
return
end if
end subroutine test_tokenize_flags
subroutine test_register_compile_command_unix(error)
type(error_t), allocatable, intent(out) :: error
type(compile_command_table_t) :: table
type(string_t), allocatable :: expected(:)
integer :: i
call table%register('gfortran -c -I/usr/include -O2 -Wall main.f90', OS_LINUX, error)
if (allocated(error)) return
if (size(table%command) /= 1) then
call test_failed(error, "Expected 1 command registered")
return
end if
associate(c => table%command(1))
! Expect these arguments in order
expected = [ string_t('gfortran'), string_t('-c'), &
string_t('-I/usr/include'), string_t('-O2'), &
string_t('-Wall'), string_t('main.f90') ]
if (.not. c%arguments == expected) then
do i = 1, size(c%arguments)
print *, "Argument", i, ":", c%arguments(i)%s
end do
call test_failed(error, "Unix compile command arguments did not match expected tokens")
return
end if
end associate
end subroutine test_register_compile_command_unix
subroutine test_register_compile_command_windows(error)
type(error_t), allocatable, intent(out) :: error
type(compile_command_table_t) :: table
type(string_t), allocatable :: expected(:)
integer :: i
call table%register('ifort /c /I"C:\Program Files\Libs" /O2 /W4 main.f90', OS_WINDOWS, error)
if (allocated(error)) return
if (size(table%command) /= 1) then
call test_failed(error, "Expected 1 command registered")
return
end if
associate(c => table%command(1))
! Expected Windows-style tokens
expected = [ string_t('ifort'), string_t('/c'), &
string_t('/IC:\Program Files\Libs'), string_t('/O2'), &
string_t('/W4'), string_t('main.f90') ]
if (.not. c%arguments == expected) then
do i = 1, size(c%arguments)
print *, "Argument", i, ":", c%arguments(i)%s
end do
call test_failed(error, "Windows compile command arguments did not match expected tokens")
return
end if
end associate
end subroutine test_register_compile_command_windows
subroutine test_get_default_flags_pic(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(compiler_t) :: compiler
character(:), allocatable :: flags
integer :: first_pos, second_pos
!> Create a gfortran compiler
call new_compiler(compiler, "gfortran", "gcc", "g++", echo=.false., verbose=.false.)
if (compiler%is_unknown()) then
call test_failed(error, "Cannot initialize gfortran compiler for PIC test")
return
end if
!> Test that -fPIC is included in release flags
flags = compiler%get_default_flags(release=.true.)
first_pos = index(flags, "-fPIC")
if (first_pos == 0) then
call test_failed(error, "Release flags should contain -fPIC, got: "//flags)
return
end if
!> Test that -fPIC is not duplicated in release flags
second_pos = index(flags(first_pos+5:), "-fPIC")
if (second_pos /= 0) then
call test_failed(error, "Release flags should not contain duplicate -fPIC, got: "//flags)
return
end if
!> Test that -fPIC is included in debug flags
flags = compiler%get_default_flags(release=.false.)
first_pos = index(flags, "-fPIC")
if (first_pos == 0) then
call test_failed(error, "Debug flags should contain -fPIC, got: "//flags)
return
end if
!> Test that -fPIC is not duplicated in debug flags
second_pos = index(flags(first_pos+5:), "-fPIC")
if (second_pos /= 0) then
call test_failed(error, "Debug flags should not contain duplicate -fPIC, got: "//flags)
return
end if
end subroutine test_get_default_flags_pic
end module test_compiler
fortran-lang-fpm-90bb83a/test/fpm_test/test_features.f90 0000664 0001750 0001750 00000225427 15145116760 023501 0 ustar alastair alastair !> Unit tests for FPM feature and feature collection functionality
module test_features
use testsuite, only : new_unittest, unittest_t, error_t, test_failed
use fpm_manifest, only: package_config_t, get_package_data
use fpm_manifest_feature, only: feature_config_t
use fpm_manifest_feature_collection, only: feature_collection_t
use fpm_manifest_platform, only: platform_config_t
use fpm_environment, only: OS_ALL, OS_LINUX, OS_MACOS, OS_WINDOWS
use fpm_compiler, only: id_all, id_gcc, id_intel_classic_nix, id_intel_classic_windows, id_intel_llvm_nix, &
match_compiler_type
use fpm_strings, only: string_t
use fpm_filesystem, only: get_temp_filename
implicit none
private
public :: collect_features
contains
!> Collect all feature tests
subroutine collect_features(testsuite)
!> Collection of tests
type(unittest_t), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
& new_unittest("feature-collection-basic", test_feature_collection_basic), &
& new_unittest("feature-collection-flexible", test_feature_collection_flexible), &
& new_unittest("feature-collection-invalid", test_feature_collection_invalid, should_fail=.true.), &
& new_unittest("feature-collection-duplicates", test_feature_collection_duplicates, should_fail=.true.), &
& new_unittest("feature-collection-extract", test_feature_collection_extract), &
& new_unittest("feature-collection-platform-validation", test_feature_collection_platform_validation, &
& should_fail=.true.), &
& new_unittest("feature-collection-complex", test_feature_collection_complex), &
& new_unittest("feature-allocatable-conflict", test_feature_allocatable_conflict, should_fail=.true.), &
& new_unittest("feature-flag-addition", test_feature_flag_addition), &
& new_unittest("feature-metapackage-addition", test_feature_metapackage_addition), &
& new_unittest("feature-extract-gfortran-linux", test_feature_extract_gfortran_linux), &
& new_unittest("feature-extract-ifort-windows", test_feature_extract_ifort_windows), &
& new_unittest("feature-extract-dependencies-examples", test_feature_extract_dependencies_examples), &
& new_unittest("feature-extract-build-configs", test_feature_extract_build_configs), &
& new_unittest("feature-extract-test-configs", test_feature_extract_test_configs), &
& new_unittest("feature-extract-example-configs", test_feature_extract_example_configs), &
& new_unittest("dependency-feature-propagation", test_dependency_feature_propagation), &
& new_unittest("dependency-features-specification", test_dependency_features_specification), &
& new_unittest("feature-chained-os-commands", test_feature_chained_os_commands, should_fail=.true.), &
& new_unittest("feature-chained-compiler-commands", &
& test_feature_chained_compiler_commands, should_fail=.true.), &
& new_unittest("feature-complex-chain-compiler-os-compiler", &
& test_feature_complex_chain_compiler_os_compiler, should_fail=.true.), &
& new_unittest("feature-complex-chain-os-compiler-os", &
& test_feature_complex_chain_os_compiler_os, should_fail=.true.), &
& new_unittest("feature-mixed-valid-chains", test_feature_mixed_valid_chains), &
& new_unittest("feature-compiler-flags-integration", test_feature_compiler_flags_integration), &
& new_unittest("default-profile-with-debug", test_default_profile_with_debug), &
& new_unittest("default-profile-with-release", test_default_profile_with_release), &
& new_unittest("default-profile-implicit-debug", test_default_profile_implicit_debug), &
& new_unittest("default-profile-skipped-custom", test_default_profile_skipped_custom) &
& ]
end subroutine collect_features
!> Test basic feature collection functionality
!> This should create two variants: gfortran+OS_ALL and ifort+OS_ALL (NOT duplicates)
subroutine test_feature_collection_basic(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit,i
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "feature-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'debug.gfortran.flags = "-Wall -g -fcheck=bounds"', &
& 'debug.ifort.flags = "/warn:all /check:all /traceback"', &
& 'release.flags = "-O3"'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Check that feature collections were created
if (.not. allocated(package%features)) then
call test_failed(error, "Feature collections were not created")
return
end if
! Verify we have at least one collection
if (size(package%features) /= 2) then
call test_failed(error, "Invalid feature collections found, should be 2")
return
end if
! Check that the debug collection has variants
do i=1,2
if (package%features(i)%base%name=="debug") then
if (.not. allocated(package%features(i)%variants)) then
call test_failed(error, "Debug collection variants were not created")
return
end if
! Should have exactly 2 variants: gfortran and ifort
if (size(package%features(i)%variants) /= 2) then
call test_failed(error, "Debug collection should have exactly 2 variants")
return
end if
! Check that variants have different platform configurations
if (package%features(i)%variants(1)%platform == package%features(i)%variants(2)%platform) then
call test_failed(error, "Variants should have different platform configurations: " &
//"variant1.compiler="//package%features(i)%variants(1)%platform%compiler_name() &
//" variant1.os="//package%features(i)%variants(1)%platform%os_name() &
//" variant2.compiler="//package%features(i)%variants(2)%platform%compiler_name() &
//" variant2.os="//package%features(i)%variants(2)%platform%os_name())
return
end if
else
if (allocated(package%features(i)%variants)) then
if (size(package%features(i)%variants) > 0) then
call test_failed(error, "Release collection variants should not be created")
return
endif
end if
endif
end do
end subroutine test_feature_collection_basic
!> Test flexible feature collection parsing with OS and compiler constraints
subroutine test_feature_collection_flexible(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 = "flexible-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'myfeature.linux.gfortran.flags = "-fPIC -Wall"', &
& 'myfeature.windows.ifort.flags = "/fPIC /warn:all"', &
& 'myfeature.macos.flags = "-framework CoreFoundation"', &
& 'myfeature.preprocess.cpp.macros = ["-DMYFEATURE"]'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Check that feature collections were created
if (.not. allocated(package%features)) then
call test_failed(error, "Feature collections were not created for flexible test")
return
end if
! Verify we have at least one collection
if (size(package%features) < 1) then
call test_failed(error, "No feature collections found in flexible test")
return
end if
! Check that base feature has been set
if (.not. allocated(package%features(1)%base%name)) then
call test_failed(error, "Base feature name not set in flexible test")
return
end if
end subroutine test_feature_collection_flexible
!> Test invalid feature collection configuration (should fail)
subroutine test_feature_collection_invalid(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 = "invalid-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'badfeature.unknownos.badcompiler.flags = "-invalid"', &
& 'badfeature.invalid-key-format = "should fail"'
close(unit)
call get_package_data(package, temp_file, error)
end subroutine test_feature_collection_invalid
!> Test feature collection duplicate platform detection
subroutine test_feature_collection_duplicates(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 = "duplicate-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'debug.gfortran.flags = "-g"', &
& 'debug.gfortran.c-flags = "-DDEBUG"' ! Duplicate gfortran platform
close(unit)
call get_package_data(package, temp_file, error)
! This should fail due to duplicate gfortran platform
if (.not. allocated(error)) then
call test_failed(error, "Expected error for duplicate platform configurations was not generated")
return
end if
! Clear the expected error
deallocate(error)
end subroutine test_feature_collection_duplicates
!> Test feature collection extract_for_target functionality
subroutine test_feature_collection_extract(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
type(feature_config_t) :: extracted_feature
type(platform_config_t) :: target_platform
integer :: i
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "extract-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'debug.flags = "-g"', &
& 'debug.gfortran.flags = "-Wall"', &
& 'debug.ifort.flags = "/debug"'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Should have debug feature collection
if (.not. allocated(package%features) .or. size(package%features) < 1) then
call test_failed(error, "No feature collections found for extract test")
return
end if
! Find debug feature collection
do i = 1, size(package%features)
if (package%features(i)%base%name == "debug") then
! Test extraction for gfortran on linux
target_platform%compiler = id_gcc
target_platform%os_type = OS_LINUX
extracted_feature = package%features(i)%extract_for_target(target_platform, error=error)
if (allocated(error)) return
! Should have both base and gfortran-specific flags
if (.not. allocated(extracted_feature%flags)) then
call test_failed(error, "Extracted feature missing flags")
return
end if
! The extracted flags should contain both base and gfortran flags
! (implementation details may vary but should have both -g and -Wall)
if (index(extracted_feature%flags, "-g") == 0) then
call test_failed(error, "Extracted feature missing base flags (-g)")
return
end if
! Test extraction for ifort
target_platform%compiler = id_intel_classic_nix
extracted_feature = package%features(i)%extract_for_target(target_platform, error=error)
if (allocated(error)) return
if (.not. allocated(extracted_feature%flags)) then
call test_failed(error, "Extracted ifort feature missing flags")
return
end if
return ! Test passed
end if
end do
call test_failed(error, "Debug feature collection not found for extract test")
end subroutine test_feature_collection_extract
!> Test feature collection platform validation
subroutine test_feature_collection_platform_validation(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 = "validation-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'test.invalidcompiler.flags = "-test"' ! Invalid compiler name
close(unit)
! Should return error
call get_package_data(package, temp_file, error)
end subroutine test_feature_collection_platform_validation
!> Test complex feature collection hierarchy
subroutine test_feature_collection_complex(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
integer :: i, debug_variants, release_variants
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "complex-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'debug.flags = "-g"', &
& 'debug.gfortran.flags = "-Wall"', &
& 'debug.ifort.flags = "/debug"', &
& 'debug.linux.flags = "-DLINUX"', &
& 'debug.windows.ifort.flags = "/DEBUG:FULL"', &
& 'release.flags = "-O3"', &
& 'release.gfortran.flags = "-mtune=generic -funroll-loops"'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Should have 2 feature collections (debug and release)
if (.not. allocated(package%features) .or. size(package%features) /= 2) then
call test_failed(error, "Expected 2 feature collections for complex test")
return
end if
debug_variants = 0
release_variants = 0
do i = 1, size(package%features)
if (package%features(i)%base%name == "debug") then
if (allocated(package%features(i)%variants)) then
debug_variants = size(package%features(i)%variants)
end if
else if (package%features(i)%base%name == "release") then
if (allocated(package%features(i)%variants)) then
release_variants = size(package%features(i)%variants)
end if
end if
end do
! Debug should have multiple variants (gfortran, ifort, linux, windows+ifort)
if (debug_variants < 3) then
call test_failed(error, "Debug feature should have at least 3 variants in complex test")
return
end if
! Release should have 1 variant (gfortran)
if (release_variants /= 1) then
call test_failed(error, "Release feature should have exactly 1 variant in complex test")
return
end if
end subroutine test_feature_collection_complex
!> Test that allocatable configurations cannot appear in multiple variants (should fail)
subroutine test_feature_allocatable_conflict(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 = "conflict-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'myfeature.gfortran.fortran.source-dir = "src/gfortran"', &
& 'myfeature.linux.fortran.source-dir = "src/linux"'
close(unit)
! Conflict: both would apply to gfortran+linux
call get_package_data(package, temp_file, error)
end subroutine test_feature_allocatable_conflict
!> Test that flags are properly added together (additive)
subroutine test_feature_flag_addition(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
type(feature_config_t) :: extracted_feature
type(platform_config_t) :: target_platform
integer :: i
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "addition-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'myfeature.flags = "-DBASE"', &
& 'myfeature.gfortran.flags = "-DGFORTRAN"', &
& 'myfeature.linux.flags = "-DLINUX"'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Should have feature collection
if (.not. allocated(package%features) .or. size(package%features) < 1) then
call test_failed(error, "No feature collections found for addition test")
return
end if
! Find myfeature collection
do i = 1, size(package%features)
if (package%features(i)%base%name == "myfeature") then
! Test extraction for gfortran on linux (should get all three flags)
target_platform%compiler = id_gcc
target_platform%os_type = OS_LINUX
extracted_feature = package%features(i)%extract_for_target(target_platform, error=error)
if (allocated(error)) return
! Should have flags from base, gfortran, and linux variants
if (.not. allocated(extracted_feature%flags)) then
call test_failed(error, "Extracted feature missing flags")
return
end if
! Should contain all three flags (additive behavior)
if (index(extracted_feature%flags, "-DBASE") == 0) then
call test_failed(error, "Missing base flags (-DBASE)")
return
end if
if (index(extracted_feature%flags, "-DGFORTRAN") == 0) then
call test_failed(error, "Missing compiler-specific flags (-DGFORTRAN)")
return
end if
if (index(extracted_feature%flags, "-DLINUX") == 0) then
call test_failed(error, "Missing OS-specific flags (-DLINUX)")
return
end if
return ! Test passed
end if
end do
call test_failed(error, "myfeature collection not found for addition test")
end subroutine test_feature_flag_addition
!> Test that metapackages are properly combined with OR logic (additive)
subroutine test_feature_metapackage_addition(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
type(feature_config_t) :: extracted_feature
type(platform_config_t) :: target_platform
integer :: i
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "meta-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'myfeature.dependencies.openmp = "*"', &
& 'myfeature.gfortran.dependencies.stdlib = "*"', &
& 'myfeature.linux.dependencies.mpi = "*"'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Should have feature collection
if (.not. allocated(package%features) .or. size(package%features) < 1) then
call test_failed(error, "No feature collections found for metapackage test")
return
end if
! Find myfeature collection
do i = 1, size(package%features)
if (package%features(i)%base%name == "myfeature") then
! Test extraction for gfortran on linux (should get all three metapackages)
target_platform%compiler = id_gcc
target_platform%os_type = OS_LINUX
extracted_feature = package%features(i)%extract_for_target(target_platform, error=error)
if (allocated(error)) return
if (.not. package%features(i)%base%meta%openmp%on) then
call test_failed(error, "Missing base openmp metapackage")
return
end if
! Should have all three metapackages enabled (OR logic)
if (.not. extracted_feature%meta%openmp%on) then
call test_failed(error, "Missing openmp metapackage")
return
end if
if (.not. extracted_feature%meta%stdlib%on) then
call test_failed(error, "Missing stdlib metapackage")
return
end if
if (.not. extracted_feature%meta%mpi%on) then
call test_failed(error, "Missing mpi metapackage")
return
end if
return ! Test passed
end if
end do
call test_failed(error, "myfeature collection not found for metapackage test")
end subroutine test_feature_metapackage_addition
!> Test comprehensive feature extraction for gfortran+Linux target (flags + executables + build)
subroutine test_feature_extract_gfortran_linux(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
type(feature_config_t) :: extracted_feature
type(platform_config_t) :: target_platform
integer :: i
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "extract-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'debug.flags = "-g"', &
& 'debug.gfortran.flags = "-Wall -fcheck=bounds"', &
& 'debug.linux.flags = "-DLINUX"', &
& 'debug.linux.gfortran.flags = "-fbacktrace"', &
& '[[features.debug.executable]]', &
& 'name = "base_prog"', &
& 'source-dir = "app"', &
& '[[features.debug.gfortran.executable]]', &
& 'name = "gfortran_prog"', &
& 'source-dir = "app/gfortran"', &
& '[[features.debug.linux.executable]]', &
& 'name = "linux_prog"', &
& 'source-dir = "app/linux"', &
& '[features.debug.gfortran.build]', &
& 'auto-executables = false'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Find debug collection and extract for gfortran+Linux
do i = 1, size(package%features)
if (package%features(i)%base%name == "debug") then
target_platform = platform_config_t(id_gcc, OS_LINUX)
extracted_feature = package%features(i)%extract_for_target(target_platform, error=error)
if (allocated(error)) return
! Check flags are combined correctly
if (.not. allocated(extracted_feature%flags)) then
call test_failed(error, "No flags in extracted gfortran+Linux feature")
return
end if
if (index(extracted_feature%flags, "-g") == 0 .or. &
index(extracted_feature%flags, "-Wall") == 0 .or. &
index(extracted_feature%flags, "-DLINUX") == 0 .or. &
index(extracted_feature%flags, "-fbacktrace") == 0) then
call test_failed(error, "Missing expected flags in gfortran+Linux extraction")
return
end if
! Check that all executables are combined (base + gfortran + linux)
if (.not. allocated(extracted_feature%executable) .or. size(extracted_feature%executable) < 3) then
call test_failed(error, "Wrong number of executables in gfortran+Linux (expected 3)")
return
end if
! Check that build config is set (only gfortran variant has it)
if (.not. allocated(extracted_feature%build)) then
call test_failed(error, "Missing build config in gfortran+Linux extraction")
return
end if
if (extracted_feature%build%auto_executables) then
call test_failed(error, "Build config not applied correctly")
return
end if
return ! Test passed
end if
end do
call test_failed(error, "debug collection not found")
end subroutine test_feature_extract_gfortran_linux
!> Test comprehensive feature extraction for ifort+Windows target (flags + tests + library)
subroutine test_feature_extract_ifort_windows(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
type(feature_config_t) :: extracted_feature
type(platform_config_t) :: target_platform
integer :: i
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "extract-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'debug.flags = "/debug"', &
& 'debug.ifort.flags = "/warn:all"', &
& 'debug.windows.flags = "/DWINDOWS"', &
& 'debug.linux.flags = "-DLINUX"', & ! Should not be included for Windows target
& '[[features.debug.test]]', &
& 'name = "base_test"', &
& 'source-dir = "test"', &
& '[[features.debug.ifort.test]]', &
& 'name = "ifort_test"', &
& 'source-dir = "test/ifort"', &
& '[[features.debug.windows.test]]', &
& 'name = "windows_test"', &
& 'source-dir = "test/windows"', &
& '[features.debug.windows.library]', &
& 'source-dir = "src/windows"'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Find debug collection and extract for gfortran+Windows
do i = 1, size(package%features)
if (package%features(i)%base%name == "debug") then
target_platform = platform_config_t("ifort", OS_WINDOWS)
extracted_feature = package%features(i)%extract_for_target(target_platform, error=error)
if (allocated(error)) return
! Check flags: should have base + ifort + windows (but NOT linux)
if (.not. allocated(extracted_feature%flags)) then
call test_failed(error, "No flags in extracted ifort+Windows feature")
return
end if
if (index(extracted_feature%flags, "/debug") == 0 .or. &
index(extracted_feature%flags, "/warn:all") == 0 .or. &
index(extracted_feature%flags, "/DWINDOWS") == 0) then
call test_failed(error, "Missing expected flags in ifort+Windows extraction. Got: '" &
//extracted_feature%flags//"'")
return
end if
! Should NOT have linux-specific flag
if (index(extracted_feature%flags, "-DLINUX") > 0) then
call test_failed(error, "Incorrectly included Linux flag -DLINUX in ifort+Windows")
return
end if
! Check that all tests are combined (base + ifort + windows)
if (.not. allocated(extracted_feature%test) .or. size(extracted_feature%test) < 3) then
call test_failed(error, "Wrong number of tests in ifort+Windows (expected 3)")
return
end if
! Check that library config is set (only windows variant has it)
if (.not. allocated(extracted_feature%library)) then
call test_failed(error, "Missing library config in ifort+Windows extraction")
return
end if
if (extracted_feature%library%source_dir /= "src/windows") then
call test_failed(error, "Library config not applied correctly")
return
end if
return ! Test passed
end if
end do
call test_failed(error, "debug collection not found")
end subroutine test_feature_extract_ifort_windows
!> Test feature extraction with dependencies and examples for gfortran+macOS target
subroutine test_feature_extract_dependencies_examples(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
type(feature_config_t) :: extracted_feature
type(platform_config_t) :: target_platform
integer :: i, j
logical :: has_gfortran_dep, has_macos_dep
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "deps-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& '[features.testing.dependencies]', &
& 'base_dep.git = "https://github.com/example/base"', &
& '[features.testing.gfortran.dependencies]', &
& 'gfortran_dep.git = "https://github.com/example/gfortran"', &
& '[features.testing.macos.dependencies]', &
& 'macos_dep.git = "https://github.com/example/macos"', &
& '[[features.testing.example]]', &
& 'name = "base_example"', &
& 'source-dir = "example"', &
& '[[features.testing.gfortran.example]]', &
& 'name = "gfortran_example"', &
& 'source-dir = "example/gfortran"', &
& '[[features.testing.macos.example]]', &
& 'name = "macos_example"', &
& 'source-dir = "example/macos"', &
& '[features.testing.macos.fortran]', &
& 'implicit-typing = false'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Find testing collection and extract for gfortran+macOS
do i = 1, size(package%features)
if (package%features(i)%base%name == "testing") then
target_platform = platform_config_t(id_gcc, OS_MACOS)
extracted_feature = package%features(i)%extract_for_target(target_platform, error=error)
if (allocated(error)) return
! Check that all dependencies are combined (base + gfortran + macos)
if (.not. allocated(extracted_feature%dependency)) then
call test_failed(error, "Missing dependencies in gfortran+macOS extraction")
return
end if
! Verify that specific dependencies are present by checking names
has_gfortran_dep = .false.
has_macos_dep = .false.
do j = 1, size(extracted_feature%dependency)
if (extracted_feature%dependency(j)%name == "gfortran_dep") then
has_gfortran_dep = .true.
end if
if (extracted_feature%dependency(j)%name == "macos_dep") then
has_macos_dep = .true.
end if
end do
if (.not. has_gfortran_dep) then
call test_failed(error, "Missing gfortran_dep dependency in gfortran+macOS extraction")
return
end if
if (.not. has_macos_dep) then
call test_failed(error, "Missing macos_dep dependency in gfortran+macOS extraction")
return
end if
! Check that all examples are combined (base + gfortran + macos)
if (.not. allocated(extracted_feature%example) .or. size(extracted_feature%example) < 3) then
call test_failed(error, "Wrong number of examples in gfortran+macOS (expected 3)")
return
end if
! Check that fortran config is set (only macOS variant has it)
if (.not. allocated(extracted_feature%fortran)) then
call test_failed(error, "Missing fortran config in gfortran+macOS extraction")
return
end if
if (extracted_feature%fortran%implicit_typing) then
call test_failed(error, "Fortran config not applied correctly - "// &
" implicit typing should be false")
return
end if
return ! Test passed
end if
end do
call test_failed(error, "testing collection not found")
end subroutine test_feature_extract_dependencies_examples
!> Test feature extraction with build configurations for ifort+Linux target
subroutine test_feature_extract_build_configs(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
type(feature_config_t) :: extracted_feature
type(platform_config_t) :: target_platform
integer :: i
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "build-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& '[features.optimization.ifort.linux.build]', &
& 'auto-executables = false', &
& 'auto-tests = false', &
& 'link = ["mylib"]', &
& 'external-modules = ["external_mod"]'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Find optimization collection and extract for ifort+Linux
do i = 1, size(package%features)
if (package%features(i)%base%name == "optimization") then
target_platform = platform_config_t(id_intel_classic_nix, OS_LINUX)
extracted_feature = package%features(i)%extract_for_target(target_platform, error=error)
if (allocated(error)) return
! Check that build config is present
if (.not. allocated(extracted_feature%build)) then
call test_failed(error, "Missing build config in ifort+Linux extraction")
return
end if
! Check that auto-executables is set correctly
if (extracted_feature%build%auto_executables) then
call test_failed(error, "Build config auto-executables should be false")
return
end if
! Check that auto-tests is set correctly
if (extracted_feature%build%auto_tests) then
call test_failed(error, "Build config auto-tests should be false")
return
end if
! Check that link libraries are present
if (.not. allocated(extracted_feature%build%link) .or. size(extracted_feature%build%link) < 1) then
call test_failed(error, "Missing link libraries in ifort+Linux build config")
return
end if
! Check that external modules are present
if (.not. allocated(extracted_feature%build%external_modules) &
.or. size(extracted_feature%build%external_modules) < 1) then
call test_failed(error, "Missing external modules in ifort+Linux build config")
return
end if
return ! Test passed
end if
end do
call test_failed(error, "optimization collection not found")
end subroutine test_feature_extract_build_configs
!> Test feature extraction with test configurations for gfortran+Windows target
subroutine test_feature_extract_test_configs(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
type(feature_config_t) :: extracted_feature
type(platform_config_t) :: target_platform
integer :: i, j
logical :: has_base, has_gfortran, has_windows, has_specific
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "test-configs"', &
& 'version = "0.1.0"', &
& '[features]', &
& '[[features.testing.test]]', &
& 'name = "base_test"', &
& 'source-dir = "test"', &
& '[[features.testing.gfortran.test]]', &
& 'name = "gfortran_test"', &
& 'source-dir = "test/gfortran"', &
& '[[features.testing.windows.test]]', &
& 'name = "windows_test"', &
& 'source-dir = "test/windows"', &
& '[[features.testing.gfortran.windows.test]]', &
& 'name = "gfortran_windows_test"', &
& 'source-dir = "test/gfortran_windows"'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Find testing collection and extract for gfortran+Windows
do i = 1, size(package%features)
if (package%features(i)%base%name == "testing") then
target_platform = platform_config_t(id_gcc, OS_WINDOWS)
extracted_feature = package%features(i)%extract_for_target(target_platform, error=error)
if (allocated(error)) return
! Check that all test configs are combined (base + gfortran + windows + gfortran.windows)
if (.not. allocated(extracted_feature%test) .or. size(extracted_feature%test) < 4) then
call test_failed(error, "Wrong number of test configs in gfortran+Windows (expected 4)")
return
end if
! Verify that specific test configs are present by checking names
has_base = .false.
has_gfortran = .false.
has_windows = .false.
has_specific = .false.
do j = 1, size(extracted_feature%test)
select case (extracted_feature%test(j)%name)
case ("base_test")
has_base = .true.
case ("gfortran_test")
has_gfortran = .true.
case ("windows_test")
has_windows = .true.
case ("gfortran_windows_test")
has_specific = .true.
end select
end do
if (.not. has_base) then
call test_failed(error, "Missing base_test in gfortran+Windows extraction")
return
end if
if (.not. has_gfortran) then
call test_failed(error, "Missing gfortran_test in gfortran+Windows extraction")
return
end if
if (.not. has_windows) then
call test_failed(error, "Missing windows_test in gfortran+Windows extraction")
return
end if
if (.not. has_specific) then
call test_failed(error, "Missing gfortran_windows_test in gfortran+Windows extraction")
return
end if
return ! Test passed
end if
end do
call test_failed(error, "testing collection not found")
end subroutine test_feature_extract_test_configs
!> Test feature extraction with example configurations for ifx+macOS target
subroutine test_feature_extract_example_configs(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
type(feature_config_t) :: extracted_feature
type(platform_config_t) :: target_platform
integer :: i, j
logical :: has_base, has_ifx, has_macos, has_specific
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "example-configs"', &
& 'version = "0.1.0"', &
& '[features]', &
& '[[features.showcase.example]]', &
& 'name = "base_example"', &
& 'source-dir = "examples"', &
& '[[features.showcase.ifx.example]]', &
& 'name = "ifx_example"', &
& 'source-dir = "examples/ifx"', &
& '[[features.showcase.macos.example]]', &
& 'name = "macos_example"', &
& 'source-dir = "examples/macos"', &
& '[[features.showcase.ifx.macos.example]]', &
& 'name = "ifx_macos_example"', &
& 'source-dir = "examples/ifx_macos"'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Find showcase collection and extract for ifx+macOS
do i = 1, size(package%features)
if (package%features(i)%base%name == "showcase") then
target_platform = platform_config_t(id_intel_llvm_nix, OS_MACOS)
extracted_feature = package%features(i)%extract_for_target(target_platform, error=error)
if (allocated(error)) return
! Check that all example configs are combined (base + ifx + macos + ifx.macos)
if (.not. allocated(extracted_feature%example) .or. size(extracted_feature%example) < 4) then
call test_failed(error, "Wrong number of example configs in ifx+macOS (expected 4)")
return
end if
! Verify that specific example configs are present by checking names
has_base = .false.
has_ifx = .false.
has_macos = .false.
has_specific = .false.
do j = 1, size(extracted_feature%example)
select case (extracted_feature%example(j)%name)
case ("base_example")
has_base = .true.
case ("ifx_example")
has_ifx = .true.
case ("macos_example")
has_macos = .true.
case ("ifx_macos_example")
has_specific = .true.
end select
end do
if (.not. has_base) then
call test_failed(error, "Missing base_example in ifx+macOS extraction")
return
end if
if (.not. has_ifx) then
call test_failed(error, "Missing ifx_example in ifx+macOS extraction")
return
end if
if (.not. has_macos) then
call test_failed(error, "Missing macos_example in ifx+macOS extraction")
return
end if
if (.not. has_specific) then
call test_failed(error, "Missing ifx_macos_example in ifx+macOS extraction")
return
end if
return ! Test passed
end if
end do
call test_failed(error, "showcase collection not found")
end subroutine test_feature_extract_example_configs
!> Test that dependency features are correctly propagated and applied
subroutine test_dependency_feature_propagation(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: dependency_config, exported_config
character(:), allocatable :: temp_file
integer :: unit
type(platform_config_t) :: target_platform
type(string_t), allocatable :: test_features(:)
allocate(temp_file, source=get_temp_filename())
! Create a dependency manifest with features
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "test-dependency"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'debug.flags = "-g -DDEBUG"', &
& 'debug.gfortran.flags = "-fcheck=bounds"', &
& 'mpi.flags = "-DUSE_MPI"', &
& 'mpi.dependencies.mpi = "*"', &
& '[[features.debug.executable]]', &
& 'name = "debug_tool"', &
& 'source-dir = "debug_tools"'
close(unit)
! Load the dependency configuration
call get_package_data(dependency_config, temp_file, error)
if (allocated(error)) return
! Simulate dependency requesting specific features (like dep%features from build_model)
allocate(test_features(2))
test_features(1)%s = "debug"
test_features(2)%s = "mpi"
! Test export_config with these features (mimics line 132-133 in fpm.f90)
target_platform = platform_config_t(id_gcc, OS_LINUX)
exported_config = dependency_config%export_config(target_platform, test_features, verbose=.false., error=error)
if (allocated(error)) return
! Verify that debug feature flags were applied
if (.not. allocated(exported_config%flags)) then
call test_failed(error, "Dependency export_config missing flags from debug feature")
return
end if
if (index(exported_config%flags, "-g") == 0 .or. &
index(exported_config%flags, "-DDEBUG") == 0) then
call test_failed(error, "Dependency missing debug flags: got '" // exported_config%flags // "'")
return
end if
if (index(exported_config%flags, "-fcheck=bounds") == 0) then
call test_failed(error, "Dependency missing gfortran-specific debug flags")
return
end if
! Verify that mpi feature flags were applied
if (index(exported_config%flags, "-DUSE_MPI") == 0) then
call test_failed(error, "Dependency missing mpi flags")
return
end if
! Verify that mpi metapackage was enabled
if (.not. exported_config%meta%mpi%on) then
call test_failed(error, "Dependency mpi metapackage not enabled")
return
end if
! Verify that debug executable was included
if (.not. allocated(exported_config%executable)) then
call test_failed(error, "Dependency debug executable not included")
return
end if
if (size(exported_config%executable) < 1) then
call test_failed(error, "Dependency should have debug executable")
return
end if
if (exported_config%executable(1)%name /= "debug_tool") then
call test_failed(error, "Dependency debug executable has wrong name")
return
end if
end subroutine test_dependency_feature_propagation
!> Test that main package can specify features for its dependencies
subroutine test_dependency_features_specification(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: main_package
character(:), allocatable :: temp_file
integer :: unit, i
logical :: found_tomlf_dep
allocate(temp_file, source=get_temp_filename())
! Create a main package manifest that specifies features for dependencies
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "main-package"', &
& 'version = "0.1.0"', &
& '[dependencies]', &
& '"dep-a" = { path = "../dep-a", features = ["openmp", "json"] }', &
& '"dep-b" = { path = "../dep-b", features = ["debug"] }'
close(unit)
! Load the main package configuration
call get_package_data(main_package, temp_file, error)
if (allocated(error)) return
! Verify dependencies were parsed correctly
if (.not. allocated(main_package%dependency)) then
call test_failed(error, "Main package dependencies not allocated")
return
end if
if (size(main_package%dependency) /= 2) then
call test_failed(error, "Expected 2 dependencies, got " // &
char(size(main_package%dependency) + ichar('0')))
return
end if
! Find and verify dep-a dependency with features
found_tomlf_dep = .false.
do i = 1, size(main_package%dependency)
if (main_package%dependency(i)%name == "dep-a") then
found_tomlf_dep = .true.
! Verify path configuration exists
if (.not. allocated(main_package%dependency(i)%path)) then
call test_failed(error, "dep-a dependency missing path configuration")
return
end if
! Path gets canonicalized, so just check it ends with the relative path
if (index(main_package%dependency(i)%path, "dep-a") == 0) then
call test_failed(error, "dep-a dependency path should contain 'dep-a', got: '" // &
main_package%dependency(i)%path // "'")
return
end if
! Verify features array - this is the key test
if (.not. allocated(main_package%dependency(i)%features)) then
call test_failed(error, "dep-a dependency features not allocated")
return
end if
if (size(main_package%dependency(i)%features) /= 2) then
call test_failed(error, "dep-a dependency should have 2 features")
return
end if
if (main_package%dependency(i)%features(1)%s /= "openmp" .or. &
main_package%dependency(i)%features(2)%s /= "json") then
call test_failed(error, "dep-a dependency has wrong feature names")
return
end if
exit
end if
end do
if (.not. found_tomlf_dep) then
call test_failed(error, "dep-a dependency not found")
return
end if
! Verify dep-b dependency has features
do i = 1, size(main_package%dependency)
if (main_package%dependency(i)%name == "dep-b") then
if (.not. allocated(main_package%dependency(i)%features)) then
call test_failed(error, "dep-b dependency features not allocated")
return
end if
if (size(main_package%dependency(i)%features) /= 1) then
call test_failed(error, "dep-b dependency should have 1 feature")
return
end if
if (main_package%dependency(i)%features(1)%s /= "debug") then
call test_failed(error, "dep-b dependency has wrong feature name")
return
end if
exit
end if
end do
end subroutine test_dependency_features_specification
!> Test that chained OS commands are rejected (should fail)
subroutine test_feature_chained_os_commands(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 = "chained-os-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'myfeature.windows.linux.flags = "-invalid"' ! Chained OS: windows.linux
close(unit)
call get_package_data(package, temp_file, error)
! This should fail due to chained OS commands
end subroutine test_feature_chained_os_commands
!> Test that chained compiler commands are rejected (should fail)
subroutine test_feature_chained_compiler_commands(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 = "chained-compiler-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'myfeature.gfortran.ifort.flags = "-invalid"' ! Chained compiler: gfortran.ifort
close(unit)
call get_package_data(package, temp_file, error)
! This should fail due to chained compiler commands
end subroutine test_feature_chained_compiler_commands
!> Test complex chaining: compiler.os.compiler (should fail)
subroutine test_feature_complex_chain_compiler_os_compiler(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 = "complex-chain-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'myfeature.gfortran.windows.ifort.flags = "-invalid"' ! gfortran.windows.ifort chain
close(unit)
call get_package_data(package, temp_file, error)
! This should fail due to chained compiler constraints: gfortran -> windows (OK) -> ifort (ERROR)
end subroutine test_feature_complex_chain_compiler_os_compiler
!> Test complex chaining: os.compiler.os (should fail)
subroutine test_feature_complex_chain_os_compiler_os(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 = "complex-chain-test2"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'myfeature.windows.ifx.macos.flags = "-invalid"' ! windows.ifx.macos chain
close(unit)
call get_package_data(package, temp_file, error)
! This should fail due to chained OS constraints: windows -> ifx (OK) -> macos (ERROR)
end subroutine test_feature_complex_chain_os_compiler_os
!> Test mixed valid chains (should pass)
subroutine test_feature_mixed_valid_chains(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
integer :: i
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "valid-chains-test"', &
& 'version = "0.1.0"', &
& '[features]', &
& 'debug.flags = "-g"', & ! Base feature (all OS, all compilers)
& 'debug.gfortran.flags = "-Wall"', & ! Compiler-specific (gfortran, all OS)
& 'debug.windows.flags = "-DWINDOWS"', & ! OS-specific (all compilers, Windows)
& 'debug.gfortran.windows.flags = "-fbacktrace"', & ! Target-specific (gfortran + Windows)
& 'debug.linux.ifort.flags = "-check all"', & ! Target-specific (Linux + ifort)
& 'release.ifx.macos.flags = "-O3"' ! Another valid target-specific (ifx + macOS)
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Verify that valid chains are accepted and collections created
if (.not. allocated(package%features)) then
call test_failed(error, "No feature collections found for valid chains test")
return
end if
! Should have debug and release features
if (size(package%features) < 2) then
call test_failed(error, "Expected at least 2 feature collections for valid chains")
return
end if
! Check that debug feature has multiple variants
do i = 1, size(package%features)
if (package%features(i)%base%name == "debug") then
if (.not. allocated(package%features(i)%variants)) then
call test_failed(error, "Debug collection should have variants for valid chains")
return
end if
! Should have multiple variants: gfortran, windows, gfortran.windows, linux.ifort
if (size(package%features(i)%variants) < 4) then
call test_failed(error, "Debug collection should have at least 4 variants for valid chains")
return
end if
exit
end if
end do
end subroutine test_feature_mixed_valid_chains
!> Test integration of feature compiler flags with new_compiler_flags
subroutine test_feature_compiler_flags_integration(error)
use fpm, only: new_compiler_flags
use fpm_model, only: fpm_model_t
use fpm_command_line, only: fpm_build_settings
use fpm_compiler, only: new_compiler, id_gcc
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package_config,package
type(fpm_model_t) :: model
type(fpm_build_settings) :: settings
type(platform_config_t) :: target_platform
character(:), allocatable :: temp_file
integer :: unit
allocate(temp_file, source=get_temp_filename())
! Create a test package with feature-based compiler flags
open(newunit=unit, file=temp_file, status='unknown')
write(unit, '(a)') 'name = "test_flags"'
write(unit, '(a)') 'version = "0.1.0"'
write(unit, '(a)') ''
write(unit, '(a)') '[library]'
write(unit, '(a)') 'source-dir = "src"'
write(unit, '(a)') ''
write(unit, '(a)') '[features]'
write(unit, '(a)') 'debug.gfortran.flags = "-g -Wall -fcheck=bounds"'
write(unit, '(a)') 'debug.flags = "-g"'
write(unit, '(a)') 'release.gfortran.flags = "-O3 -mtune=generic -funroll-loops"'
write(unit, '(a)') 'release.flags = "-O2"'
write(unit, '(a)') ''
write(unit, '(a)') '[profiles]'
write(unit, '(a)') 'development = ["debug"]'
write(unit, '(a)') 'production = ["release"]'
close(unit)
! Set up build settings without CLI flags
settings%flag = ""
settings%cflag = ""
settings%cxxflag = ""
settings%ldflag = ""
! Load the package configuration
call get_package_data(package_config, temp_file, error, apply_defaults=.true.)
if (allocated(error)) return
! 1) Choose first desired target platform: gfortran on Linux with development profile
target_platform = platform_config_t(id_gcc, OS_LINUX)
settings%profile = "development" ! This should activate debug features
! Extract the current package configuration request
package = package_config%export_config(target_platform, profile=settings%profile, verbose=.false., error=error)
if (allocated(error)) return
! Set up model with mock compiler
call new_compiler(model%compiler, "gfortran", "gcc", "g++", echo=.false., verbose=.false.)
! Test that package flags are used when no CLI flags provided
call new_compiler_flags(model, settings, package)
! 2) Ensure flags are picked from gfortran platform (should include both base debug and gfortran-specific)
if (.not. allocated(model%fortran_compile_flags)) then
call test_failed(error, "Expected fortran_compile_flags to be allocated for gfortran")
return
end if
if (index(model%fortran_compile_flags, "-g") == 0) then
call test_failed(error, "Expected debug flags to contain '-g' for gfortran platform")
return
end if
if (index(model%fortran_compile_flags, "-Wall") == 0) then
call test_failed(error, "Expected gfortran-specific flags to contain '-Wall'")
return
end if
if (index(model%fortran_compile_flags, "-fcheck=bounds") == 0) then
call test_failed(error, "Expected gfortran-specific flags to contain '-fcheck=bounds'")
return
end if
! 3) Choose another target platform: gfortran on Linux with production profile
settings%profile = "production" ! This should activate release features
! Extract the new package configuration request
package = package_config%export_config(target_platform, profile=settings%profile, verbose=.false., error=error)
if (allocated(error)) return
! Reset flags and test production profile
call new_compiler_flags(model, settings, package)
! 4) Ensure flags are picked from the release platform (should include release flags)
if (.not. allocated(model%fortran_compile_flags)) then
call test_failed(error, "Expected fortran_compile_flags to be allocated for release")
return
end if
if (index(model%fortran_compile_flags, "-O3") == 0) then
call test_failed(error, "Expected release gfortran flags to contain '-O3'")
return
end if
if (index(model%fortran_compile_flags, "-mtune") == 0) then
call test_failed(error, "Expected release gfortran flags to contain '-mtune'")
return
end if
if (index(model%fortran_compile_flags, "-funroll-loops") == 0) then
call test_failed(error, "Expected release gfortran flags to contain '-funroll-loops'")
return
end if
if (index(model%fortran_compile_flags, "-O2") == 0) then
call test_failed(error, "Expected base release flags to contain '-O2'")
return
end if
! Test CLI flags still override package flags
settings%flag = "-O1 -DCUSTOM"
call new_compiler_flags(model, settings, package)
if (index(model%fortran_compile_flags, "-O1") == 0) then
call test_failed(error, "Expected CLI flags to be used when provided")
return
end if
if (index(model%fortran_compile_flags, "-DCUSTOM") == 0) then
call test_failed(error, "Expected CLI flags to contain custom flags")
return
end if
! Clean up - file was already closed after writing
end subroutine test_feature_compiler_flags_integration
!> Test that "default" profile features are applied alongside --profile debug
subroutine test_default_profile_with_debug(error)
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package_config, package
type(platform_config_t) :: target_platform
character(:), allocatable :: temp_file
integer :: unit
allocate(temp_file, source=get_temp_filename())
open(newunit=unit, file=temp_file, status='unknown')
write(unit, '(a)') 'name = "test_default"'
write(unit, '(a)') 'version = "0.1.0"'
write(unit, '(a)') '[library]'
write(unit, '(a)') 'source-dir = "src"'
write(unit, '(a)') ''
write(unit, '(a)') '[features]'
write(unit, '(a)') 'baseline.flags = "-fPIC"'
write(unit, '(a)') 'debug.flags = "-g"'
write(unit, '(a)') ''
write(unit, '(a)') '[profiles]'
write(unit, '(a)') 'default = ["baseline"]'
write(unit, '(a)') 'debug = ["debug"]'
close(unit)
call get_package_data(package_config, temp_file, error, apply_defaults=.true.)
if (allocated(error)) return
target_platform = platform_config_t(id_gcc, OS_LINUX)
! Export with --profile debug: should get both default (baseline) and debug features
package = package_config%export_config(target_platform, profile="debug", verbose=.false., error=error)
if (allocated(error)) return
! Should have baseline flags from default profile
if (index(package%flags, "-fPIC") == 0) then
call test_failed(error, "Expected default profile flags '-fPIC' to be present with --profile debug")
return
end if
! Should also have debug flags
if (index(package%flags, "-g") == 0) then
call test_failed(error, "Expected debug flags '-g' to be present with --profile debug")
return
end if
end subroutine test_default_profile_with_debug
!> Test that "default" profile features are applied alongside --profile release
subroutine test_default_profile_with_release(error)
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package_config, package
type(platform_config_t) :: target_platform
character(:), allocatable :: temp_file
integer :: unit
allocate(temp_file, source=get_temp_filename())
open(newunit=unit, file=temp_file, status='unknown')
write(unit, '(a)') 'name = "test_default"'
write(unit, '(a)') 'version = "0.1.0"'
write(unit, '(a)') '[library]'
write(unit, '(a)') 'source-dir = "src"'
write(unit, '(a)') ''
write(unit, '(a)') '[features]'
write(unit, '(a)') 'baseline.flags = "-fPIC"'
write(unit, '(a)') 'release.flags = "-O3"'
write(unit, '(a)') ''
write(unit, '(a)') '[profiles]'
write(unit, '(a)') 'default = ["baseline"]'
write(unit, '(a)') 'release = ["release"]'
close(unit)
call get_package_data(package_config, temp_file, error, apply_defaults=.true.)
if (allocated(error)) return
target_platform = platform_config_t(id_gcc, OS_LINUX)
! Export with --profile release: should get both default (baseline) and release features
package = package_config%export_config(target_platform, profile="release", verbose=.false., error=error)
if (allocated(error)) return
! Should have baseline flags from default profile
if (index(package%flags, "-fPIC") == 0) then
call test_failed(error, "Expected default profile flags '-fPIC' to be present with --profile release")
return
end if
! Should also have release flags
if (index(package%flags, "-O3") == 0) then
call test_failed(error, "Expected release flags '-O3' to be present with --profile release")
return
end if
end subroutine test_default_profile_with_release
!> Test that "default" profile features are applied when no profile is specified (implicit debug)
subroutine test_default_profile_implicit_debug(error)
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package_config, package
type(platform_config_t) :: target_platform
character(:), allocatable :: temp_file
integer :: unit
allocate(temp_file, source=get_temp_filename())
open(newunit=unit, file=temp_file, status='unknown')
write(unit, '(a)') 'name = "test_default"'
write(unit, '(a)') 'version = "0.1.0"'
write(unit, '(a)') '[library]'
write(unit, '(a)') 'source-dir = "src"'
write(unit, '(a)') ''
write(unit, '(a)') '[features]'
write(unit, '(a)') 'baseline.flags = "-fPIC"'
write(unit, '(a)') ''
write(unit, '(a)') '[profiles]'
write(unit, '(a)') 'default = ["baseline"]'
close(unit)
call get_package_data(package_config, temp_file, error, apply_defaults=.true.)
if (allocated(error)) return
target_platform = platform_config_t(id_gcc, OS_LINUX)
! Export with no profile/features: should still get default profile features
package = package_config%export_config(target_platform, verbose=.false., error=error)
if (allocated(error)) return
! Should have baseline flags from default profile
if (index(package%flags, "-fPIC") == 0) then
call test_failed(error, "Expected default profile flags '-fPIC' to be present with no explicit profile")
return
end if
end subroutine test_default_profile_implicit_debug
!> Test that "default" profile features are NOT applied when a custom profile is requested
subroutine test_default_profile_skipped_custom(error)
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package_config, package
type(platform_config_t) :: target_platform
character(:), allocatable :: temp_file
integer :: unit
allocate(temp_file, source=get_temp_filename())
open(newunit=unit, file=temp_file, status='unknown')
write(unit, '(a)') 'name = "test_default"'
write(unit, '(a)') 'version = "0.1.0"'
write(unit, '(a)') '[library]'
write(unit, '(a)') 'source-dir = "src"'
write(unit, '(a)') ''
write(unit, '(a)') '[features]'
write(unit, '(a)') 'baseline.flags = "-fPIC"'
write(unit, '(a)') 'custom_opt.flags = "-O1"'
write(unit, '(a)') ''
write(unit, '(a)') '[profiles]'
write(unit, '(a)') 'default = ["baseline"]'
write(unit, '(a)') 'myprofile = ["custom_opt"]'
close(unit)
call get_package_data(package_config, temp_file, error, apply_defaults=.true.)
if (allocated(error)) return
target_platform = platform_config_t(id_gcc, OS_LINUX)
! Export with --profile myprofile: should NOT get default profile features
package = package_config%export_config(target_platform, profile="myprofile", verbose=.false., error=error)
if (allocated(error)) return
! Should have custom profile flags
if (index(package%flags, "-O1") == 0) then
call test_failed(error, "Expected custom profile flags '-O1' to be present")
return
end if
! Should NOT have baseline flags from default profile
if (index(package%flags, "-fPIC") /= 0) then
call test_failed(error, "Default profile flags '-fPIC' should NOT be present with custom profile")
return
end if
end subroutine test_default_profile_skipped_custom
end module test_features
fortran-lang-fpm-90bb83a/test/fpm_test/testsuite.f90 0000664 0001750 0001750 00000016161 15145116760 022646 0 ustar alastair alastair !> 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
fortran-lang-fpm-90bb83a/test/fpm_test/test_module_dependencies.f90 0000664 0001750 0001750 00000133302 15145116760 025644 0 ustar alastair alastair !> 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, &
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.), is_valid_module_name, is_valid_module_prefix
use fpm, only: check_modules_for_duplicates
implicit none
private
public :: collect_module_dependencies, operator(.in.)
interface operator(.in.)
module procedure target_in
end interface
contains
!> Collect all exported unit tests
subroutine collect_module_dependencies(testsuite)
!> Collection of tests
type(unittest_t), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
& new_unittest("library-module-use", test_library_module_use), &
& new_unittest("program-module-use", test_program_module_use), &
& new_unittest("program-with-module", test_program_with_module), &
& new_unittest("program-own-module-use", test_program_own_module_use), &
& new_unittest("missing-library-use", &
test_missing_library_use, should_fail=.true.), &
& new_unittest("missing-program-use", &
test_missing_program_use, should_fail=.true.), &
& new_unittest("invalid-library-use", &
test_invalid_library_use, should_fail=.true.), &
& new_unittest("package-with-no-duplicates", &
test_package_with_no_module_duplicates), &
& new_unittest("package-with-duplicates-in-same-source", &
test_package_module_duplicates_same_source, should_fail=.true.), &
& new_unittest("package-with-duplicates-in-one-package", &
test_package_module_duplicates_one_package, should_fail=.true.), &
& new_unittest("package-with-duplicates-in-two-packages", &
test_package_module_duplicates_two_packages, should_fail=.true.), &
& new_unittest("subdirectory-module-use", &
test_subdirectory_module_use), &
& new_unittest("invalid-subdirectory-module-use", &
test_invalid_subdirectory_module_use, should_fail=.true.), &
& new_unittest("tree-shake-module", &
test_tree_shake_module, should_fail=.false.), &
& new_unittest("tree-shake-subprogram-with-module", &
test_tree_shake_subprogram_with_module, should_fail=.false.), &
& new_unittest("valid-enforced-module-names", &
check_valid_enforced_module_names, should_fail=.false.), &
& new_unittest("valid-enforced-module-names-dashed", &
check_valid_enforced_module_names_dashed, should_fail=.false.), &
& new_unittest("invalid-enforced-module-names", &
check_invalid_enforced_module_names, should_fail=.false.), &
& new_unittest("invalid-module-names", &
check_invalid_module_names, should_fail=.false.), &
& new_unittest("custom-module-prefixes", &
check_valid_custom_prefix, should_fail=.false.), &
& new_unittest("custom-prefixed-module-names", &
check_custom_prefixed_modules, should_fail=.false.) &
]
end subroutine collect_module_dependencies
!> Check library module using another library module
subroutine test_library_module_use(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(fpm_model_t) :: model
type(build_target_ptr), allocatable :: targets(:)
allocate(model%external_modules(0))
allocate(model%packages(1))
allocate(model%packages(1)%sources(2))
model%package_name = "test"
model%build_prefix = ""
model%packages(1)%name = "package1"
model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", &
scope = FPM_SCOPE_LIB, &
provides=[string_t('my_mod_1')])
model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_2.f90", &
scope = FPM_SCOPE_LIB, &
provides=[string_t('my_mod_2')], &
uses=[string_t('my_mod_1')])
call targets_from_sources(targets,model,.false.,error=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
type(fpm_model_t) :: model
type(build_target_ptr), allocatable :: targets(:)
character(:), allocatable :: scope_str
allocate(model%external_modules(0))
allocate(model%packages(1))
allocate(model%packages(1)%sources(2))
model%package_name = "test_scope"
model%build_prefix = ""
model%packages(1)%name = "package1"
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,.false.,error=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
type(fpm_model_t) :: model
type(build_target_ptr), allocatable :: targets(:)
allocate(model%external_modules(0))
allocate(model%packages(1))
allocate(model%packages(1)%sources(1))
model%package_name = "test_program_with_module"
model%build_prefix = ""
model%packages(1)%name = "package1"
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,.false.,error=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
allocate(model%external_modules(0))
allocate(model%packages(1))
allocate(model%packages(1)%sources(3))
model%package_name = "test_scope"
model%build_prefix = ""
model%packages(1)%name = "package1"
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,.false.,error=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(:)
allocate(model%external_modules(0))
allocate(model%packages(1))
allocate(model%packages(1)%sources(2))
model%package_name = "test_missing_library_use"
model%build_prefix = ""
model%packages(1)%name = "package1"
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,.false.,error=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(:)
allocate(model%external_modules(0))
allocate(model%packages(1))
allocate(model%packages(1)%sources(2))
model%package_name = "test_missing_program_use"
model%build_prefix = ""
model%packages(1)%name = "package1"
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,.false.,error=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(:)
allocate(model%external_modules(0))
allocate(model%packages(1))
allocate(model%packages(1)%sources(2))
model%package_name = "test_invalid_library_use"
model%build_prefix = ""
model%packages(1)%name = "package1"
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,.false.,error=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(:)
allocate(model%external_modules(0))
allocate(model%packages(1))
allocate(model%packages(1)%sources(2))
model%package_name = "test_subdirectory_module_use"
model%build_prefix = ""
model%packages(1)%name = "package1"
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,.false.,error=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%package_name = "test_package_with_no_module_duplicates"
model%build_prefix = ""
model%packages(1)%name = "package1"
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%package_name = "test_package_module_duplicates_same_source"
model%build_prefix = ""
model%packages(1)%name = "package1"
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%package_name = "test_package_module_duplicates_one_package"
model%build_prefix = ""
model%packages(1)%name = "package1"
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%package_name = "test_package_module_duplicates_two_packages"
model%build_prefix = ""
model%packages(1)%name = "package1"
model%packages(2)%name = "package2"
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 tree-shaking of unused modules
!> Unused module should not be included in targets
subroutine test_tree_shake_module(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(fpm_model_t) :: model
type(build_target_ptr), allocatable :: targets(:)
character(:), allocatable :: scope_str
allocate(model%external_modules(0))
allocate(model%packages(1))
allocate(model%packages(1)%sources(4))
model%package_name = "test_tree_shake_module"
model%build_prefix = ""
model%packages(1)%name = "package1"
model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", &
scope = FPM_SCOPE_LIB, &
provides=[string_t('my_mod_1')]) ! indirectly used
model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_2.f90", &
scope = FPM_SCOPE_LIB, &
provides=[string_t('my_mod_2')], &
uses=[string_t('my_mod_1')]) ! directly used
model%packages(1)%sources(3) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_3.f90", &
scope = FPM_SCOPE_LIB, &
provides=[string_t('my_mod_3')]) ! unused module
model%packages(1)%sources(4) = 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,prune=.true.,error=error)
if (allocated(error)) return
if (size(targets) /= 5) then
call test_failed(error,scope_str//'Incorrect number of targets - expecting five')
return
end if
call check_target(targets(1)%ptr,type=FPM_TARGET_ARCHIVE,n_depends=2, &
deps=[targets(2),targets(3)], &
links=[targets(2),targets(3)],error=error)
if (allocated(error)) return
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_OBJECT,n_depends=1, &
deps=[targets(3)],source=model%packages(1)%sources(4),error=error)
if (allocated(error)) return
call check_target(targets(5)%ptr,type=FPM_TARGET_EXECUTABLE,n_depends=2, &
deps=[targets(1),targets(4)], &
links=[targets(4)], error=error)
if (allocated(error)) return
end subroutine test_tree_shake_module
!> Check tree-shaking of modules used via a subprogram source
!> (Subprogram type is a source containing any non-module subroutines/functions)
!> Subprograms cannot be pruned, so neither can their dependencies
subroutine test_tree_shake_subprogram_with_module(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(fpm_model_t) :: model
type(build_target_ptr), allocatable :: targets(:)
character(:), allocatable :: scope_str
allocate(model%external_modules(0))
allocate(model%packages(1))
allocate(model%packages(1)%sources(4))
model%package_name = "test_tree_shake_subprogram_with_module"
model%build_prefix = ""
model%packages(1)%name = "package1"
model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", &
scope = FPM_SCOPE_LIB, &
provides=[string_t('my_mod_1')]) ! used via subprogram
model%packages(1)%sources(2) = new_test_source(FPM_UNIT_SUBPROGRAM,file_name="src/my_subprogram.f90", &
scope = FPM_SCOPE_LIB, &
uses=[string_t('my_mod_1')]) ! subprogram (never pruned)
model%packages(1)%sources(3) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_3.f90", &
scope = FPM_SCOPE_LIB, &
provides=[string_t('my_mod_3')]) ! unused module
model%packages(1)%sources(4) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", &
scope=FPM_SCOPE_APP)
call targets_from_sources(targets,model,prune=.true.,error=error)
if (allocated(error)) return
if (size(targets) /= 5) then
call test_failed(error,scope_str//'Incorrect number of targets - expecting five')
return
end if
call check_target(targets(1)%ptr,type=FPM_TARGET_ARCHIVE,n_depends=2, &
deps=[targets(2)], &
links=[targets(2),targets(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
call check_target(targets(4)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, &
source=model%packages(1)%sources(4),error=error)
if (allocated(error)) return
call check_target(targets(5)%ptr,type=FPM_TARGET_EXECUTABLE,n_depends=2, &
deps=[targets(1),targets(4)], &
links=[targets(4)], error=error)
if (allocated(error)) return
end subroutine test_tree_shake_subprogram_with_module
!> 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(:)
allocate(model%external_modules(0))
allocate(model%packages(1))
allocate(model%packages(1)%sources(2))
model%package_name = "test_invalid_subdirectory_module_use"
model%build_prefix = ""
model%packages(1)%name = "package1"
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,.false.,error=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
!> Check several module names whose name is valid and begins with the package name
subroutine check_valid_enforced_module_names(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i,j
type(string_t) :: package,modules,prefix
logical, parameter :: enforcing(2) = [.false.,.true.]
character(*), parameter :: package_name = 'my_pkg'
character(len=80), parameter :: module_names(*) = [ character(len=80) :: &
'my_pkg__mod_1', &
'my_pkg___mod_1', &
'my_pkg____mod_1', &
'my_pkg', &
'my_pkg__1', &
'my_pkg__my_pkg' ]
package = string_t(package_name)
prefix = string_t("") ! Prefix not used
do i=1,size(module_names)
modules = string_t(module_names(i))
!> All these names are valid both with and without enforcing
do j=1,2
if (.not.is_valid_module_name(modules,package,prefix,enforcing(j))) then
call test_failed(error,'Valid dummy module name ['//modules%s//'] of package ['// &
package%s//'] unexpectedly fails naming check (enforcing='// &
merge('T','F',enforcing(j))//').')
return
endif
end do
end do
end subroutine check_valid_enforced_module_names
!> Check several module names whose name is valid and begins with the package name
subroutine check_valid_enforced_module_names_dashed(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i,j
type(string_t) :: package,modules,prefix
logical, parameter :: enforcing(2) = [.false.,.true.]
character(*), parameter :: package_name = 'my-pkg'
character(len=80), parameter :: module_names(*) = [ character(len=80) :: &
'my_pkg__mod_1', &
'my_pkg___mod_1', &
'my_pkg____mod_1', &
'my_pkg', &
'my_pkg__1', &
'my_pkg__my_pkg' ]
package = string_t(package_name)
prefix = string_t("") ! Prefix not used
do i=1,size(module_names)
modules = string_t(trim(module_names(i)))
!> All these names are valid both with and without enforcing
do j=1,2
if (.not.is_valid_module_name(modules,package,prefix,enforcing(j))) then
call test_failed(error,'Valid dummy module name ['//modules%s//'] of package ['// &
package%s//'] unexpectedly fails naming check (enforcing='// &
merge('T','F',enforcing(j))//').')
return
endif
end do
end do
end subroutine check_valid_enforced_module_names_dashed
!> Check several module names whose name is invalid
subroutine check_invalid_enforced_module_names(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i
type(string_t) :: package,modules,prefix
character(*), parameter :: package_name = 'my_pkg'
character(len=80), parameter :: module_names(*) = [ character(len=80) :: &
'mod_1', &
'my_pkmod_1', &
'my_mod_1', &
'pkg_mod_1', &
'y_pkg_mod_1', &
'_my_pkg_mod_1', &
'my_pkgmy_mod', &
'my_pkg_', &
'my_pkg__' ]
package = string_t(package_name)
prefix = string_t("") ! Prefix not used
!> All these cases should report an invalid name
do i=1,size(module_names)
modules = string_t(trim(module_names(i)))
if (is_valid_module_name(modules,package,prefix,.true.)) then
call test_failed(error,'Invalid dummy module name ['//modules%s//'] of package ['// &
package%s//'] unexpectedly passes naming check (enforcing=T).')
return
end if
end do
end subroutine check_invalid_enforced_module_names
!> Check module names whose name does not name the convention:
!> - Begin with a literal
!> - len(name)<=63
!> - Contains literals, numbers, or underscores only
subroutine check_invalid_module_names(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i
type(string_t) :: modules,package,prefix
!> Examples taken from Metcalf/Reid/Cohen
character(len=80), parameter :: module_names(*) = [ character(len=80) :: &
'1a', &
'a thing', &
'$sign', &
'_begin_with_underscore', &
'contains-dashes', &
'and/other?symbols@2' ]
package = string_t("")
prefix = string_t("") ! Prefix not used
!> All these cases should report an invalid name
do i=1,size(module_names)
modules = string_t(module_names(i))
if (is_valid_module_name(modules,package,prefix,.false.)) then
call test_failed(error,'Invalid Fortran module name ['//modules%s//'] ' &
//' unexpectedly passes naming check.')
return
end if
end do
end subroutine check_invalid_module_names
!> Check several module prefixes that are valid
subroutine check_valid_custom_prefix(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i
type(string_t) :: prefix
character(len=80), parameter :: valid_prefixes(*) = [ character(len=80) :: &
'm', &
'mp', &
'mypkg', &
'mypkg123', &
'mypackage', &
'tomlf' ]
character(len=80), parameter :: invalid_prefixes(*) = [ character(len=80) :: &
'm_', &
'm-p', &
'my_pkg', &
'my-pkg123', &
'my package', &
'toml-f', &
'123pkg', &
'mypkg_' ]
! All valid
do i=1,size(valid_prefixes)
prefix = string_t(valid_prefixes(i))
!> All these names are valid both with and without enforcing
if (.not.is_valid_module_prefix(prefix)) then
call test_failed(error,'Valid dummy module prefix ['//prefix%s//'] '//&
' unexpectedly fails naming check.')
return
endif
end do
! All invalid
do i=1,size(invalid_prefixes)
prefix = string_t(invalid_prefixes(i))
!> All these names are valid both with and without enforcing
if (is_valid_module_prefix(prefix)) then
call test_failed(error,'Invalid dummy module prefix ['//prefix%s//'] '//&
' unexpectedly passed naming check.')
return
endif
end do
end subroutine check_valid_custom_prefix
!> Check several module prefixes that are valid
subroutine check_custom_prefixed_modules(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i
type(string_t) :: prefix,modules,package
character(len=*), parameter :: custom_prefix = 'mp123'
character(len=*), parameter :: package_name = 'my-package'
character(len=80), parameter :: module_names(*) = [ character(len=80) :: &
'mp123', &
'mp123_utils', &
'mp123__utils', &
'mp123_test', &
'mp123_my_module_name',&
'my_package__utils',&
'my_package',&
'my_package__123']
character(len=80), parameter :: invalid_names(*) = [ character(len=80) :: &
'utils', &
'mp_123_utils', &
'mypackage__utils', &
'my_package_utils', &
'my_package_test']
prefix = string_t(custom_prefix)
package = string_t(package_name)
! All valid
do i=1,size(module_names)
modules = string_t(module_names(i))
!> All these names are valid both with and without enforcing
if (.not.is_valid_module_name(modules,package,prefix,.true.)) then
call test_failed(error,'Valid prefixed module ['//modules%s//'] ' //&
' from package ['//package%s//'] with prefix ['//&
prefix%s//'] unexpectedly fails naming check.')
return
endif
end do
! All invalid
do i=1,size(invalid_names)
modules = string_t(invalid_names(i))
!> All these names are valid both with and without enforcing
if (is_valid_module_name(modules,package,prefix,.true.)) then
call test_failed(error,'Invalid prefixed module ['//modules%s//'] ' //&
' from package ['//package%s//'] with prefix ['//&
prefix%s//'] unexpectedly passed naming check.')
return
endif
end do
end subroutine check_custom_prefixed_modules
!> 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
fortran-lang-fpm-90bb83a/test/fpm_test/test_installer.f90 0000664 0001750 0001750 00000021373 15145116760 023652 0 ustar alastair alastair !> 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
use fpm_targets, only: build_target_ptr, add_target, FPM_TARGET_ARCHIVE, &
FPM_TARGET_SHARED
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-module-custom", test_install_module_custom), &
& new_unittest("install-exe-unix", test_install_exe_unix), &
& new_unittest("install-exe-win", test_install_exe_win), &
& new_unittest("install-test-unix", test_install_tests_unix), &
& new_unittest("install-test-win", test_install_tests_win), &
& new_unittest("install-shared-lib-unix", test_install_shared_library_unix)]
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_tests_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", testdir="tdir", verbosity=0, copy="mock")
mock%installer_t = installer
mock%os = OS_LINUX
mock%expected_dir = "PREFIX/tdir"
mock%expected_run = 'mock "name" "'//mock%expected_dir//'"'
call mock%install_test("name", error)
end subroutine test_install_tests_unix
subroutine test_install_tests_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", testdir="tdir", verbosity=0, copy="mock")
mock%installer_t = installer
mock%os = OS_WINDOWS
mock%expected_dir = "PREFIX\tdir"
mock%expected_run = 'mock "name.exe" "'//mock%expected_dir//'"'
call mock%install_test("name", error)
end subroutine test_install_tests_win
subroutine test_install_lib(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(mock_installer_t) :: mock
type(installer_t) :: installer
type(build_target_ptr), allocatable :: targets(:)
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 add_target(targets,"name",FPM_TARGET_ARCHIVE,"name")
call mock%install_library(targets(1)%ptr, error)
deallocate(targets(1)%ptr)
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
subroutine test_install_module_custom(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", moduledir="custom_modules", verbosity=0, copy="mock")
mock%installer_t = installer
mock%expected_dir = join_path("PREFIX", "custom_modules")
mock%expected_run = 'mock "test_module.mod" "'//join_path("PREFIX", "custom_modules")//'"'
call mock%install_module("test_module.mod", error)
end subroutine test_install_module_custom
subroutine test_install_shared_library_unix(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(mock_installer_t) :: mock
type(installer_t) :: installer
character(len=*), parameter :: libname = "libname.so"
type(build_target_ptr), allocatable :: targets(:)
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 "'//libname//'" "'//mock%expected_dir//'"'
call add_target(targets,"name",FPM_TARGET_SHARED,libname)
call mock%install_library(targets(1)%ptr, error)
deallocate(targets(1)%ptr)
end subroutine test_install_shared_library_unix
!> 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
fortran-lang-fpm-90bb83a/test/fpm_test/test_versioning.f90 0000664 0001750 0001750 00000032700 15145116760 024034 0 ustar alastair alastair !> Test implementation of version data type
module test_versioning
use testsuite, only : new_unittest, unittest_t, error_t, test_failed
use fpm_versioning
use fpm_release, only: fpm_version
implicit none
private
public :: collect_versioning
contains
!> Collect all exported unit tests
subroutine collect_versioning(tests)
!> Collection of tests
type(unittest_t), allocatable, intent(out) :: tests(:)
tests = [ &
& new_unittest("fpm-version", test_fpm_version), &
& 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
!> Test fpm self-version query
subroutine test_fpm_version(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(version_t) :: self_version
self_version = fpm_version()
end subroutine test_fpm_version
!> Read valid version strings
subroutine test_valid_version(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(version_t) :: version
call new_version(version, "8.9.0", error)
if (allocated(error)) return
call new_version(version, "2020.10.003", error)
end subroutine test_valid_version
!> Compare versions for equality
subroutine test_valid_equals(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(version_t) :: v1, v2
type(version_t) :: varray(4)
call new_version(v1, [1, 2, 0])
call new_version(v2, [1, 2])
if (.not. v1 == v2) then
call test_failed(error, "Version comparison failed")
return
end if
if (.not. v2 == v1) then
call test_failed(error, "Version comparison failed")
return
end if
call new_version(v1, [0, 9, 0])
call new_version(v2, [0, 9])
if (.not. v1==v2) then
call test_failed(error, "Version comparison failed")
return
end if
if (.not. v2==v1) then
call test_failed(error, "Version comparison failed")
return
end if
call new_version(v1, [2020])
call new_version(v2, [2020, 0])
if (.not. v1 == v2) then
call test_failed(error, "Version comparison failed")
return
end if
if (.not. v2 == v1) then
call test_failed(error, "Version comparison failed")
return
end if
call new_version(v1, [20, 1])
call new_version(varray(1), [19])
call new_version(varray(2), [18, 2])
call new_version(varray(3), [20, 1])
call new_version(varray(4), [1, 3, 1])
if (.not. any(v1 == varray)) then
call test_failed(error, "Version comparison failed")
return
end if
end subroutine test_valid_equals
!> Compare versions for mismatch
subroutine test_valid_notequals(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(version_t) :: v1, v2
type(version_t) :: varray(4)
call new_version(v1, [2020, 3, 1])
call new_version(v2, [2020, 3])
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/=v2) then
call test_failed(error, "Version comparison failed")
return
end if
if (.not. v2/=v1) then
call test_failed(error, "Version comparison failed")
return
end if
call new_version(v1, [2020])
call new_version(v2, [0, 2020])
if (.not. v2 /= v1) then
call test_failed(error, "Version comparison failed")
return
end if
if (.not. v1 /= v2) then
call test_failed(error, "Version comparison failed")
return
end if
call new_version(v1, [20, 1])
call new_version(varray(1), [19])
call new_version(varray(2), [18, 2])
call new_version(varray(3), [18, 1])
call new_version(varray(4), [1, 3, 1])
if (.not. any(v1 /= varray)) then
call test_failed(error, "Version comparison failed")
return
end if
end subroutine test_valid_notequals
!> Relative comparison of versions
subroutine test_valid_compare(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(version_t) :: v1, v2
type(version_t) :: varray(4)
call new_version(v1, [10])
call new_version(v2, [1])
if (.not. v1 > v2) then
call test_failed(error, "Version comparison failed (gt)")
return
end if
if (.not. v1 >= v2) then
call test_failed(error, "Version comparison failed (ge)")
return
end if
if (.not. v2 < v1) then
call test_failed(error, "Version comparison failed (lt)")
return
end if
if (.not. v2 <= v1) then
call test_failed(error, "Version comparison failed (le)")
return
end if
call new_version(v1, [1, 0, 8])
call new_version(v2, [1, 0])
if (.not. v1 > v2) then
call test_failed(error, "Version comparison failed (gt)")
return
end if
if (.not. v1 >= v2) then
call test_failed(error, "Version comparison failed (ge)")
return
end if
if (.not. v2 < v1) then
call test_failed(error, "Version comparison failed (lt)")
return
end if
if (.not. v2 <= v1) then
call test_failed(error, "Version comparison failed (le)")
return
end if
call new_version(v1, [1, 2])
call new_version(v2, [1, 2, 0])
if (v1 > v2) then
call test_failed(error, "Version comparison failed (gt)")
return
end if
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
call new_version(v1, [1, 2, 3])
call new_version(v2, [2, 0, 0])
if (v1 > v2) then
call test_failed(error, "Version comparison failed (gt)")
return
end if
if (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 (v2 <= v1) then
call test_failed(error, "Version comparison failed (le)")
return
end if
call new_version(v1, [1, 2, 3])
call new_version(v2, [1, 0, 4])
if (v2 > v1) then
call test_failed(error, "Version comparison failed (gt)")
return
end if
if (v2 >= v1) then
call test_failed(error, "Version comparison failed (ge)")
return
end if
if (v1 < v2) then
call test_failed(error, "Version comparison failed (lt)")
return
end if
if (v1 <= v2) then
call test_failed(error, "Version comparison failed (le)")
return
end if
call new_version(v1, [1, 0, 8])
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])
call new_version(v2, [1, 0, 8])
if (v1 > v2) then
call test_failed(error, "Version comparison failed (gt)")
return
end if
if (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 (v2 <= v1) then
call test_failed(error, "Version comparison failed (le)")
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
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"
type(version_t) :: version
call new_version(version, str_in, error)
if (allocated(error)) return
if (str_in /= version%s()) then
call test_failed(error, "Expected "//str_in//" but got "//version%s())
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
fortran-lang-fpm-90bb83a/test/fpm_test/test_manifest.f90 0000664 0001750 0001750 00000176001 15145116760 023462 0 ustar alastair alastair !> Define tests for the `fpm_manifest` modules
module test_manifest
use fpm_filesystem, only: get_temp_filename
use testsuite, only : new_unittest, unittest_t, error_t, test_failed, check_string
use fpm_manifest
use fpm_manifest_profile, only: profile_config_t
use fpm_manifest_platform, only: platform_config_t
use fpm_compiler, only: id_gcc, id_intel_classic_nix
use fpm_environment, only: OS_LINUX
use fpm_manifest_feature, only: feature_config_t
use fpm_strings, only: operator(.in.), string_t
use fpm_error, only: fatal_error, error_t
use tomlf, only : new_table, toml_table, toml_array
use fpm_toml, only : add_table, add_array, get_value, get_list, set_value, set_list
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-library-type", test_default_library_type), &
& new_unittest("default-executable", test_default_executable), &
& new_unittest("dependency-empty", test_dependency_empty, should_fail=.true.), &
& new_unittest("dependency-pathtag", test_dependency_pathtag, should_fail=.true.), &
& new_unittest("dependency-gitpath", test_dependency_gitpath, should_fail=.true.), &
& new_unittest("dependency-nourl", test_dependency_nourl, should_fail=.true.), &
& new_unittest("dependency-gitconflict", test_dependency_gitconflict, should_fail=.true.), &
& new_unittest("dependency-invalid-git", test_dependency_invalid_git, should_fail=.true.), &
& new_unittest("dependency-no-namespace", test_dependency_no_namespace, should_fail=.true.), &
& new_unittest("dependency-redundant-v", test_dependency_redundant_v, should_fail=.true.), &
& new_unittest("dependency-features-present", test_dependency_features_present), &
& new_unittest("dependency-features-absent", test_dependency_features_absent), &
& new_unittest("dependency-features-empty", test_dependency_features_empty), &
& new_unittest("dependency-profile-present", test_dependency_profile_present), &
& new_unittest("dependency-profile-absent", test_dependency_profile_absent), &
& new_unittest("dependency-profile-features-conflict", &
& test_dependency_profile_features_conflict, should_fail=.true.), &
& new_unittest("dependency-wrongkey", test_dependency_wrongkey, should_fail=.true.), &
& new_unittest("dependencies-empty", test_dependencies_empty), &
& new_unittest("dependencies-typeerror", test_dependencies_typeerror, should_fail=.true.), &
& new_unittest("profiles", test_profiles), &
& new_unittest("profiles-invalid", test_profiles_invalid, 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("build-key-invalid", test_build_invalid_key), &
& new_unittest("library-empty", test_library_empty), &
& new_unittest("library-wrongkey", test_library_wrongkey, should_fail=.true.), &
& new_unittest("library-list", test_library_list, 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-module-dir", test_install_module_dir), &
& new_unittest("install-wrongkey", test_install_wrongkey, should_fail=.true.), &
& new_unittest("preprocess-empty", test_preprocess_empty), &
& new_unittest("preprocess-wrongkey", test_preprocess_wrongkey, should_fail=.true.), &
& new_unittest("preprocessors-empty", test_preprocessors_empty, should_fail=.true.), &
& new_unittest("macro-parsing", test_macro_parsing, should_fail=.false.), &
& new_unittest("macro-parsing-dependency", &
& test_macro_parsing_dependency, should_fail=.false.), &
& new_unittest("features-demo-serialization", test_features_demo_serialization) &
& ]
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', &
& 'module-naming = false', &
& '[dependencies.fpm]', &
& 'git = "https://github.com/fortran-lang/fpm"', &
& '[[executable]]', &
& 'name = "example-1" # comment', &
& 'source-dir = "prog"', &
& '[dependencies]', &
& 'toml-f.git = "git@github.com:toml-f/toml-f.git"', &
& '"toml..f" = { path = ".." }', &
& '[["executable"]]', &
& 'name = "example-2"', &
& 'source-dir = "prog"', &
& '[executable.dependencies]', &
& '[''library'']', &
& 'source-dir = """', &
& 'lib""" # comment', &
& '[preprocess]', &
& '[preprocess.cpp]', &
& 'suffixes = ["F90", "f90"]', &
& 'directories = ["src/feature1", "src/models"]', &
& 'macros = ["FOO", "BAR"]'
close(unit)
call get_package_data(package, manifest, error)
open(file=manifest, newunit=unit)
close(unit, status='delete')
if (allocated(error)) return
if (package%name /= "example") then
call test_failed(error, "Package name is "//package%name//" but should be example")
return
end if
if (.not.allocated(package%library)) then
call test_failed(error, "library is not present in package data")
return
end if
if (.not.allocated(package%executable)) then
call test_failed(error, "executable is not present in package data")
return
end if
if (size(package%executable) /= 2) then
call test_failed(error, "Number of executables in package is not two")
return
end if
if (.not.allocated(package%dependency)) then
call test_failed(error, "dependency is not present in package data")
return
end if
if (size(package%dependency) /= 3) then
call test_failed(error, "Number of dependencies in package is not three")
return
end if
if (allocated(package%test)) then
call test_failed(error, "test is present in package but not in package file")
return
end if
if (.not.allocated(package%preprocess)) then
call test_failed(error, "Preprocessor is not present in package data")
return
end if
if (size(package%preprocess) /= 1) then
call test_failed(error, "Number of preprocessors in package is not one")
return
end if
! Test package serialization
call package%test_serialization('test_valid_manifest',error)
if (allocated(error)) return
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
call package%test_serialization('test_default_library',error)
if (allocated(error)) return
end subroutine test_default_library
!> Test that a package with non-specified library returns monolithic and not shared/static
subroutine test_default_library_type(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(len=*), parameter :: manifest = 'fpm-default-library-type.toml'
integer :: unit
open(file=manifest, newunit=unit)
write(unit, '(a)') &
& 'name = "example"', &
& '[library]'
close(unit)
call get_package_data(package, manifest, error)
open(file=manifest, newunit=unit)
close(unit, status='delete')
if (allocated(error)) return
if (.not.allocated(package%library)) then
call test_failed(error, "Default library is not present in package data")
return
end if
if (.not.package%library%monolithic()) then
call test_failed(error, "Default library should be monolithic")
return
end if
if (package%library%shared()) then
call test_failed(error, "Default library should not be shared")
return
end if
if (package%library%static()) then
call test_failed(error, "Default library should not be static")
return
end if
call package%test_serialization('test_default_library_type',error)
if (allocated(error)) return
end subroutine test_default_library_type
!> 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
call package%feature_config_t%test_serialization('test_default_executable (feature only)',error)
if (allocated(error)) return
call package%test_serialization('test_default_executable',error)
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
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_config_t) :: dependency
call new_table(table)
table%key = "example"
call new_dependency(dependency, table, error=error)
end subroutine test_dependency_empty
!> Try to create a dependency with conflicting entries
subroutine test_dependency_pathtag(error)
use fpm_manifest_dependency
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
integer :: stat
type(dependency_config_t) :: dependency
call new_table(table)
table%key = 'example'
call set_value(table, 'path', 'package', stat)
call set_value(table, 'tag', 'v20.1', stat)
call new_dependency(dependency, table, error=error)
end subroutine test_dependency_pathtag
!> Try to create a dependency with conflicting entries
subroutine test_dependency_nourl(error)
use fpm_manifest_dependency
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
integer :: stat
type(dependency_config_t) :: dependency
call new_table(table)
table%key = 'example'
call set_value(table, 'tag', 'v20.1', stat)
call new_dependency(dependency, table, error=error)
end subroutine test_dependency_nourl
!> Try to create a dependency with conflicting entries
subroutine test_dependency_gitpath(error)
use fpm_manifest_dependency
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
integer :: stat
type(dependency_config_t) :: dependency
call new_table(table)
table%key = 'example'
call set_value(table, 'path', 'package', stat)
call set_value(table, 'git', 'https://gitea.com/fortran-lang/pack', stat)
call new_dependency(dependency, table, error=error)
end subroutine test_dependency_gitpath
!> Try to create a dependency with conflicting entries
subroutine test_dependency_gitconflict(error)
use fpm_manifest_dependency
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
integer :: stat
type(dependency_config_t) :: dependency
call new_table(table)
table%key = 'example'
call set_value(table, 'git', 'https://gitea.com/fortran-lang/pack', stat)
call set_value(table, 'branch', 'latest', stat)
call set_value(table, 'tag', 'v20.1', stat)
call new_dependency(dependency, table, error=error)
end subroutine test_dependency_gitconflict
!> Try to create a git dependency with an invalid source format.
subroutine test_dependency_invalid_git(error)
use fpm_manifest_dependency
!> 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 set_value(table, 'git', 123) ! Not a string
call new_dependency(dependency, table, error=error)
end subroutine test_dependency_invalid_git
!> Namespace is necessary if a dependency is not a git or path dependency
subroutine test_dependency_no_namespace(error)
use fpm_manifest_dependency
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_config_t) :: dependency
call new_table(table)
table%key = 'example'
call set_value(table, 'v', 'abc')
call new_dependency(dependency, table, error=error)
end subroutine test_dependency_no_namespace
!> Do not specify version with a git or path dependency
subroutine test_dependency_redundant_v(error)
use fpm_manifest_dependency
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_config_t) :: dependency
call new_table(table)
table%key = 'example'
call set_value(table, 'v', '0.0.0')
call set_value(table, 'path', 'abc')
call new_dependency(dependency, table, error=error)
end subroutine test_dependency_redundant_v
!> Try to create a dependency with conflicting entries
subroutine test_dependency_wrongkey(error)
use fpm_manifest_dependency
!> 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=error)
end subroutine test_dependency_wrongkey
!> Dependency tables can be empty
subroutine test_dependencies_empty(error)
use fpm_manifest_dependency
!> 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=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
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(toml_array), pointer :: children
integer :: stat
type(dependency_config_t), allocatable :: dependencies(:)
call new_table(table)
call add_array(table, 'dep1', children, stat)
call new_dependencies(dependencies, table, error=error)
end subroutine test_dependencies_typeerror
!> Test profile parsing and storage in package
subroutine test_profiles(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(len=*), parameter :: manifest = 'fpm-profiles.toml'
integer :: unit
open(file=manifest, newunit=unit)
write(unit, '(a)') &
& 'name = "example"', &
& '[profiles]', &
& 'development = ["debug", "testing"]', &
& 'release = ["optimized"]', &
& 'full-test = ["debug", "testing", "benchmarks"]', &
& '[features]', &
& 'testing.flags = " -g"', &
& 'optimized.flags = " -O2"', &
& 'benchmarks.flags = " -O3"'
close(unit)
call get_package_data(package, manifest, error)
open(file=manifest, newunit=unit)
close(unit, status='delete')
if (allocated(error)) return
! Check that profiles were parsed correctly
if (.not. allocated(package%profiles)) then
call test_failed(error, "No profiles found in package")
return
end if
! debug, release, development, full-test
if (size(package%profiles) /= 4) then
call test_failed(error, "Unexpected number of profiles, should be 4")
return
end if
! Check development profile
if (package%profiles(1)%name /= "development") then
call test_failed(error, "Expected profile name 'development', got '" // package%profiles(1)%name // "'")
return
end if
if (size(package%profiles(1)%features) /= 2) then
call test_failed(error, "Unexpected number of features, should be 2")
return
end if
if (package%profiles(1)%features(1)%s /= "debug" .or. &
package%profiles(1)%features(2)%s /= "testing") then
call test_failed(error, "Incorrect features in development profile")
return
end if
end subroutine test_profiles
!> Test invalid profile configuration should fail
subroutine test_profiles_invalid(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(len=*), parameter :: manifest = 'fpm-profiles-error.toml'
integer :: unit
open(file=manifest, newunit=unit)
write(unit, '(a)') &
& 'name = "example"', &
& '[profiles]', &
& 'development = "not_an_array"'
close(unit)
call get_package_data(package, manifest, error)
open(file=manifest, newunit=unit)
close(unit, status='delete')
end subroutine test_profiles_invalid
!> Executables cannot be created from empty tables
subroutine test_executable_empty(error)
use fpm_manifest_executable
!> 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
!> 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
!> 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
!> 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', &
& 'module-naming = true'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
if (package%build%auto_executables) then
call test_failed(error, "Wrong value of 'auto-executables' read, expecting .false.")
return
end if
if (package%build%auto_tests) then
call test_failed(error, "Wrong value of 'auto-tests' read, expecting .false.")
return
end if
if (.not. package%build%module_naming) then
call test_failed(error, "Wrong value of 'module-naming' read, expecting .true.")
return
end if
end subroutine test_build_valid
!> Try to read values from the [build] table
subroutine test_build_invalid_key(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
type(error_t), allocatable :: build_error
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 ', &
& 'module-naming = true ', &
& 'this-will-fail = true '
close(unit)
call get_package_data(package, temp_file, build_error)
! Error message should contain both package name and key name
if (allocated(build_error)) then
if (.not.index(build_error%message,'this-will-fail')>0) then
call fatal_error(error, 'no invalid key name is printed to output')
return
end if
if (.not.index(build_error%message,'example')>0) then
call fatal_error(error, 'no package name is printed to output')
return
end if
else
call fatal_error(error, 'no error allocated on invalid [build] section key ')
return
end if
end subroutine test_build_invalid_key
!> 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, "Wrong default value of 'auto-executables' read, expecting .true.")
return
end if
if (.not.package%build%auto_tests) then
call test_failed(error, "Wrong default value of 'auto-tests' read, expecting .true.")
return
end if
if (package%build%module_naming) then
call test_failed(error, "Wrong default value of 'module-naming' read, expecting .false.")
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
!> 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
!> 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
!> Pass a TOML table with not allowed source dirs
subroutine test_library_list(error)
use fpm_manifest_library
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(string_t), allocatable :: source_dirs(:)
type(toml_table) :: table
type(library_config_t) :: library
source_dirs = [string_t("src1"),string_t("src2")]
call new_table (table)
call set_list (table, "source-dir", source_dirs, error)
call new_library(library, table, error)
end subroutine test_library_list
!> Pass a TOML table with a 1-sized source dir list
subroutine test_library_listone(error)
use fpm_manifest_library
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "example"', &
& '[library]', &
& 'source-dir = ["my-src"]'
close(unit)
call get_package_data(package, temp_file, error)
end subroutine test_library_listone
!> Packages cannot be created from empty tables
subroutine test_package_simple(error)
use fpm_manifest_package
!> 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=error)
end subroutine test_package_simple
!> Packages cannot be created from empty tables
subroutine test_package_empty(error)
use fpm_manifest_package
!> 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=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
!> 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=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
!> 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=error)
end subroutine test_package_noname
!> Try to read executables from a mixed type array
subroutine test_package_wrongexe(error)
use fpm_manifest_package
!> 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=error)
end subroutine test_package_wrongexe
!> Try to read tests from a mixed type array
subroutine test_package_wrongtest(error)
use fpm_manifest_package
!> 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=error)
end subroutine test_package_wrongtest
!> Try to read tests from a mixed type array
subroutine test_package_duplicate(error)
use fpm_manifest_package
!> 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=error)
end subroutine test_package_duplicate
!> Tests cannot be created from empty tables
subroutine test_test_simple(error)
use fpm_manifest_test
!> 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
!> 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
!> 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
!> 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
!> 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
!> 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
!> 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
!> 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, 'test_link_string', error)
if (allocated(error)) return
!> Test serialization roundtrip
call build%test_serialization('test_link_string', error)
if (allocated(error)) return
end subroutine test_link_string
!> Test link options
subroutine test_link_array(error)
use fpm_manifest_build
!> 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, 'test_link_array', error)
if (allocated(error)) return
!> Test serialization roundtrip
call build%test_serialization('test_link_array', error)
if (allocated(error)) return
end subroutine test_link_array
!> Test link options
subroutine test_invalid_link(error)
use fpm_manifest_build
!> 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, 'test_invalid_link', error)
end subroutine test_invalid_link
subroutine test_install_library(error)
use fpm_manifest_install
!> 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
!> 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
!> 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
subroutine test_install_module_dir(error)
use fpm_manifest_install
!> 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, "module-dir", "custom_modules")
call new_install_config(install, table, error)
if (allocated(error)) return
if (.not.allocated(install%module_dir)) then
call test_failed(error, "Module directory should be allocated")
return
end if
if (install%module_dir /= "custom_modules") then
call test_failed(error, "Module directory should match input")
return
end if
end subroutine test_install_module_dir
subroutine test_preprocess_empty(error)
use fpm_manifest_preprocess
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(preprocess_config_t) :: preprocess
call new_table(table)
table%key = "example"
call preprocess%new(table, error)
end subroutine test_preprocess_empty
!> Pass a TOML table with not allowed keys
subroutine test_preprocess_wrongkey(error)
use fpm_manifest_preprocess
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(toml_table), pointer :: child
integer :: stat
type(preprocess_config_t) :: preprocess
call new_table(table)
table%key = 'example'
call add_table(table, 'wrong-field', child, stat)
call preprocess%new(table, error)
end subroutine test_preprocess_wrongkey
!> Preprocess table cannot be empty.
subroutine test_preprocessors_empty(error)
use fpm_manifest_preprocess
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(preprocess_config_t), allocatable :: preprocessors(:)
call new_table(table)
call new_preprocessors(preprocessors, table, error)
if (allocated(error)) return
end subroutine test_preprocessors_empty
!> Test macro parsing function get_macros_from_manifest
subroutine test_macro_parsing(error)
use fpm_compiler, only: get_macros, compiler_enum, id_gcc
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit
integer(compiler_enum) :: id
id = id_gcc
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "example"', &
& 'version = "0.1.0"', &
& '[preprocess]', &
& '[preprocess.cpp]', &
& 'macros = ["FOO", "BAR=2", "VERSION={version}"]'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
if (get_macros(id, package%preprocess(1)%macros, package%version) /= " -DFOO -DBAR=2 -DVERSION=0.1.0") then
call test_failed(error, "Macros were not parsed correctly")
end if
end subroutine test_macro_parsing
!> Test macro parsing of the package and its dependency.
subroutine test_macro_parsing_dependency(error)
use fpm_compiler, only: get_macros, compiler_enum
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: macros_package, macros_dependency
type(package_config_t) :: package, dependency
character(:), allocatable :: toml_file_package
character(:), allocatable :: toml_file_dependency
integer :: unit
integer(compiler_enum) :: id
allocate(toml_file_package, source=get_temp_filename())
allocate(toml_file_dependency, source=get_temp_filename())
open(file=toml_file_package, newunit=unit)
write(unit, '(a)') &
& 'name = "example"', &
& 'version = "0.1.0"', &
& '[dependencies]', &
& '[dependencies.dependency-name]', &
& 'git = "https://github.com/fortran-lang/dependency-name"', &
& '[preprocess]', &
& '[preprocess.cpp]', &
& 'macros = ["FOO", "BAR=2", "VERSION={version}"]'
close(unit)
open(file=toml_file_dependency, newunit=unit)
write(unit, '(a)') &
& 'name = "dependency-name"', &
& 'version = "0.2.0"', &
& '[preprocess]', &
& '[preprocess.cpp]', &
& 'macros = ["FOO1", "BAR2=2", "VERSION={version}"]'
close(unit)
call get_package_data(package, toml_file_package, error)
if (allocated(error)) return
call get_package_data(dependency, toml_file_dependency, error)
if (allocated(error)) return
macros_package = get_macros(id, package%preprocess(1)%macros, package%version)
macros_dependency = get_macros(id, dependency%preprocess(1)%macros, dependency%version)
if (macros_package == macros_dependency) then
call test_failed(error, "Macros of package and dependency should not be equal")
end if
end subroutine test_macro_parsing_dependency
!> Ensure dependency "features" array is correctly parsed when present
subroutine test_dependency_features_present(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit, i, idx_dep0, idx_dep1, idx_dep2
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "example"', &
& 'version = "0.1.0"', &
& '[dependencies]', &
& '"dep0" = { path = "local/dep0", features = ["featA", "featB"] }', &
& '"dep1" = { git = "https://example.com/repo.git", tag = "v1.2.3", features = ["only"] }', &
& '"dep2" = { path = "other/dep2" }'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
if (.not.allocated(package%dependency)) then
call test_failed(error, 'No dependencies parsed from manifest')
return
end if
idx_dep0 = 0; idx_dep1 = 0; idx_dep2 = 0
do i = 1, size(package%dependency)
select case (package%dependency(i)%name)
case ('dep0'); idx_dep0 = i
case ('dep1'); idx_dep1 = i
case ('dep2'); idx_dep2 = i
end select
end do
if (idx_dep0 == 0 .or. idx_dep1 == 0 .or. idx_dep2 == 0) then
call test_failed(error, 'Expected dependencies dep0/dep1/dep2 not found')
return
end if
! dep0: features = ["featA","featB"]
if (.not.allocated(package%dependency(idx_dep0)%features)) then
call test_failed(error, 'dep0 features not allocated')
return
end if
if (size(package%dependency(idx_dep0)%features) /= 2) then
call test_failed(error, 'dep0 features size /= 2')
return
end if
if (package%dependency(idx_dep0)%features(1)%s /= 'featA' .or. &
& package%dependency(idx_dep0)%features(2)%s /= 'featB') then
call test_failed(error, 'dep0 features values mismatch')
return
end if
! dep1: features = ["only"]
if (.not.allocated(package%dependency(idx_dep1)%features)) then
call test_failed(error, 'dep1 features not allocated')
return
end if
if (size(package%dependency(idx_dep1)%features) /= 1) then
call test_failed(error, 'dep1 features size /= 1')
return
end if
if (package%dependency(idx_dep1)%features(1)%s /= 'only') then
call test_failed(error, 'dep1 features value mismatch')
return
end if
! dep2: no features key -> should be NOT allocated
if (allocated(package%dependency(idx_dep2)%features)) then
call test_failed(error, 'dep2 features should be unallocated when key is absent')
return
end if
end subroutine test_dependency_features_present
!> Ensure a dependency without "features" key is accepted (no allocation)
subroutine test_dependency_features_absent(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit, i
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "example"', &
& '[dependencies]', &
& '"a" = { path = "a" }', &
& '"b" = { git = "https://example.org/b.git", branch = "main" }'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
if (.not.allocated(package%dependency)) then
call test_failed(error, 'No dependencies parsed from manifest')
return
end if
do i = 1, size(package%dependency)
if (allocated(package%dependency(i)%features)) then
call test_failed(error, 'features should be unallocated when not specified')
return
end if
end do
end subroutine test_dependency_features_absent
!> Accept an explicit empty "features = []" list
subroutine test_dependency_features_empty(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit, i, idx
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "example"', &
& '[dependencies]', &
& '"empty" = { path = "local/empty", features = [] }'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
idx = -1
if (.not.allocated(package%dependency)) then
call test_failed(error, 'No dependencies parsed from manifest')
return
end if
do i = 1, size(package%dependency)
if (package%dependency(i)%name == 'empty') then
idx = i
exit
end if
end do
if (idx < 1) then
call test_failed(error, 'Dependency "empty" not found')
return
end if
if (.not.allocated(package%dependency(idx)%features)) then
call test_failed(error, 'features should be allocated (size=0) for empty list')
return
end if
if (size(package%dependency(idx)%features) /= 0) then
call test_failed(error, 'features size should be zero for empty list')
return
end if
end subroutine test_dependency_features_empty
!> Test features demo manifest serialization (from example_packages/features_demo/fpm.toml)
subroutine test_features_demo_serialization(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 = "features_demo"', &
& 'version = "0.1.0"', &
& 'license = "MIT"', &
& 'description = "Demo package for FPM features functionality"', &
& '', &
& '[[executable]]', &
& 'name = "features_demo"', &
& 'source-dir = "app"', &
& 'main = "main.f90"', &
& '', &
& '[features]', &
& '# Base debug feature', &
& 'debug.flags = "-g"', &
& 'debug.preprocess.cpp.macros = "DEBUG"', &
& '', &
& '# Release feature', &
& 'release.flags = "-O3"', &
& 'release.preprocess.cpp.macros = "RELEASE"', &
& '', &
& '# Compiler-specific features', &
& 'debug.gfortran.flags = "-Wall -fcheck=bounds"', &
& 'release.gfortran.flags = "-mtune=generic -funroll-loops"', &
& '', &
& '# Platform-specific features', &
& 'linux.preprocess.cpp.macros = "LINUX_BUILD"', &
& '', &
& '# Parallel features', &
& 'mpi.preprocess.cpp.macros = "USE_MPI"', &
& 'mpi.dependencies.mpi = "*"', &
& 'openmp.preprocess.cpp.macros = "USE_OPENMP"', &
& 'openmp.dependencies.openmp = "*"', &
& '', &
& '[profiles]', &
& 'development = ["debug"]', &
& 'production = ["release", "openmp"]'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
! Verify basic package structure
if (package%name /= "features_demo") then
call test_failed(error, "Package name should be 'features_demo'")
return
end if
if (.not. allocated(package%features)) then
call test_failed(error, "Features should be allocated")
return
end if
if (.not. allocated(package%profiles)) then
call test_failed(error, "Profiles should be allocated")
return
end if
if (.not. allocated(package%executable)) then
call test_failed(error, "Executables should be allocated")
return
end if
! Test package serialization roundtrip
call package%test_serialization('test_features_demo_serialization', error)
if (allocated(error)) return
end subroutine test_features_demo_serialization
!> Test that a dependency with "profile" key is parsed correctly
subroutine test_dependency_profile_present(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit, i, idx_dep0, idx_dep1
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "example"', &
& 'version = "0.1.0"', &
& '[dependencies]', &
& '"dep0" = { path = "local/dep0", profile = "release" }', &
& '"dep1" = { path = "local/dep1" }'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
if (.not.allocated(package%dependency)) then
call test_failed(error, 'No dependencies parsed from manifest')
return
end if
idx_dep0 = 0; idx_dep1 = 0
do i = 1, size(package%dependency)
select case (package%dependency(i)%name)
case ('dep0'); idx_dep0 = i
case ('dep1'); idx_dep1 = i
end select
end do
if (idx_dep0 == 0 .or. idx_dep1 == 0) then
call test_failed(error, 'Expected dependencies dep0/dep1 not found')
return
end if
! dep0: profile = "release"
if (.not.allocated(package%dependency(idx_dep0)%profile)) then
call test_failed(error, 'dep0 profile not allocated')
return
end if
if (package%dependency(idx_dep0)%profile /= 'release') then
call test_failed(error, 'dep0 profile value mismatch, expected "release"')
return
end if
! dep0 should NOT have features allocated
if (allocated(package%dependency(idx_dep0)%features)) then
if (size(package%dependency(idx_dep0)%features) > 0) then
call test_failed(error, 'dep0 features should not be present when profile is used')
return
end if
end if
! dep1: no profile key -> should be NOT allocated
if (allocated(package%dependency(idx_dep1)%profile)) then
call test_failed(error, 'dep1 profile should be unallocated when key is absent')
return
end if
end subroutine test_dependency_profile_present
!> Ensure a dependency without "profile" key leaves it unallocated
subroutine test_dependency_profile_absent(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_config_t) :: package
character(:), allocatable :: temp_file
integer :: unit, i
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'name = "example"', &
& '[dependencies]', &
& '"a" = { path = "a" }', &
& '"b" = { git = "https://example.org/b.git", branch = "main" }'
close(unit)
call get_package_data(package, temp_file, error)
if (allocated(error)) return
if (.not.allocated(package%dependency)) then
call test_failed(error, 'No dependencies parsed from manifest')
return
end if
do i = 1, size(package%dependency)
if (allocated(package%dependency(i)%profile)) then
call test_failed(error, 'profile should be unallocated when not specified')
return
end if
end do
end subroutine test_dependency_profile_absent
!> Specifying both "features" and "profile" should be an error
subroutine test_dependency_profile_features_conflict(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"', &
& '[dependencies]', &
& '"bad" = { path = "bad", features = ["f1"], profile = "release" }'
close(unit)
call get_package_data(package, temp_file, error)
end subroutine test_dependency_profile_features_conflict
end module test_manifest
fortran-lang-fpm-90bb83a/test/fpm_test/test_settings.f90 0000664 0001750 0001750 00000053162 15145116760 023516 0 ustar alastair alastair module test_settings
use testsuite, only: new_unittest, unittest_t, error_t, test_failed
use fpm_settings, only: fpm_global_settings, get_global_settings, get_registry_settings, official_registry_base_url
use fpm_filesystem, only: is_dir, join_path, mkdir, filewrite, os_delete_dir, exists, get_local_prefix
use fpm_environment, only: os_is_unix
use tomlf, only: toml_table, new_table
use fpm_toml, only: add_table, set_value
use fpm_os, only: get_absolute_path, get_current_directory
implicit none
private
public :: collect_settings
character(len=*), parameter :: tmp_folder = 'tmp'
character(len=*), parameter :: config_file_name = 'config.toml'
contains
!> Collect unit tests.
subroutine collect_settings(tests)
!> Unit tests to collect.
type(unittest_t), allocatable, intent(out) :: tests(:)
tests = [ &
& new_unittest('no-folder', no_folder, should_fail=.true.), &
& new_unittest('no-file', no_file, should_fail=.true.), &
& new_unittest('empty-file', empty_file), &
& new_unittest('default-config-settings', default_config_settings), &
& new_unittest('error-reading-table', error_reading_table, should_fail=.true.), &
& new_unittest('empty-registry-table', empty_registry_table), &
& new_unittest('invalid-key', invalid_key, should_fail=.true.), &
& new_unittest('invalid-type', invalid_type, should_fail=.true.), &
& new_unittest('has-non-existent-path-to-registry', has_non_existent_path_to_registry, should_fail=.true.), &
& new_unittest('has-existent-path-to-registry', has_existent_path_to_registry), &
& new_unittest('absolute-path-to-registry', absolute_path_to_registry), &
& new_unittest('relative-path-to-registry', relative_path_to_registry), &
& new_unittest('relative-path-to-registry-file-read', relative_path_to_registry_file_read), &
& new_unittest('canonical-path-to-registry', canonical_path_to_registry), &
& new_unittest('has-url-to-registry', has_url_to_registry), &
& new_unittest('has-both-path-and-url-to-registry', has_both_path_and_url_to_registry, should_fail=.true.), &
& new_unittest('has-both-path-and-cache-path', has_both_path_and_cache_path, should_fail=.true.), &
& new_unittest('abs-cache-path-no-dir', abs_cache_path_no_dir), &
& new_unittest('abs-cache-path-has-dir', abs_cache_path_has_dir), &
& new_unittest('rel-cache-path-no-dir', rel_cache_path_no_dir), &
& new_unittest('rel-cache-path-has-dir', rel_cache_path_has_dir) &
]
end subroutine collect_settings
subroutine delete_tmp_folder
if (is_dir(tmp_folder)) call os_delete_dir(os_is_unix(), tmp_folder)
end subroutine
subroutine setup_global_settings(global_settings, error)
type(fpm_global_settings), intent(out) :: global_settings
type(error_t), allocatable, intent(out) :: error
character(:), allocatable :: cwd
call get_current_directory(cwd, error)
if (allocated(error)) return
global_settings%path_to_config_folder = join_path(cwd, tmp_folder)
global_settings%config_file_name = config_file_name
end subroutine
!> Throw error when custom path to config file was entered but no folder exists.
subroutine no_folder(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
call delete_tmp_folder
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call get_global_settings(global_settings, error)
end subroutine
!> Throw error when custom path to config file was entered but no file exists.
subroutine no_file(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
call delete_tmp_folder
call mkdir(tmp_folder)
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call get_global_settings(global_settings, error)
end subroutine
!> No custom path and config file specified, use default path and file name.
subroutine default_config_settings(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
character(:), allocatable :: default_path
call delete_tmp_folder
call get_global_settings(global_settings, error)
if (allocated(error)) return
if (os_is_unix()) then
default_path = join_path(get_local_prefix(), 'share', 'fpm')
else
default_path = join_path(get_local_prefix(), 'fpm')
end if
if (global_settings%path_to_config_folder /= default_path) then
call test_failed(error, "Path to config folder not set correctly :'"//global_settings%config_file_name//"'")
return
end if
if (global_settings%config_file_name /= 'config.toml') then
call test_failed(error, "Config file name not set correctly :'"//global_settings%config_file_name//"'")
return
end if
end subroutine
!> Config file exists and the path to that file is set.
subroutine empty_file(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
character(:), allocatable :: cwd
call delete_tmp_folder
call mkdir(tmp_folder)
call filewrite(join_path(tmp_folder, config_file_name), [''])
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call get_global_settings(global_settings, error)
call delete_tmp_folder
if (allocated(error)) return
call get_current_directory(cwd, error)
if (allocated(error)) return
if (global_settings%path_to_config_folder /= join_path(cwd, tmp_folder)) then
call test_failed(error, "global_settings%path_to_config_folder not set correctly :'" &
& //global_settings%path_to_config_folder//"'"); return
end if
if (.not. allocated(global_settings%registry_settings)) then
call test_failed(error, 'global_settings%registry_settings not be allocated'); return
end if
if (global_settings%registry_settings%url /= official_registry_base_url) then
call test_failed(error, 'Wrong default url'); return
end if
if (global_settings%registry_settings%cache_path /= join_path(global_settings%path_to_config_folder, &
& 'dependencies')) then
call test_failed(error, 'Wrong default cache_path'); return
end if
end subroutine
!> Invalid TOML file.
subroutine error_reading_table(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
call delete_tmp_folder
call mkdir(tmp_folder)
call filewrite(join_path(tmp_folder, config_file_name), ['['])
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call get_global_settings(global_settings, error)
call delete_tmp_folder
if (allocated(global_settings%registry_settings)) then
call test_failed(error, 'Registry settings should not be allocated'); return
end if
end subroutine
subroutine empty_registry_table(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
type(toml_table) :: table
type(toml_table), pointer :: child
call new_table(table)
call add_table(table, 'registry', child)
call get_registry_settings(child, global_settings, error)
if (allocated(error)) return
if (.not. allocated(global_settings%registry_settings)) then
call test_failed(error, 'Registry settings not allocated'); return
end if
if (allocated(global_settings%registry_settings%path)) then
call test_failed(error, "Path shouldn't be allocated"); return
end if
if (global_settings%registry_settings%url /= official_registry_base_url) then
call test_failed(error, "Url not be allocated"); return
end if
end subroutine
subroutine invalid_key(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
type(toml_table) :: table
type(toml_table), pointer :: child
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'invalid_key', 'abc')
call get_registry_settings(child, global_settings, error)
end subroutine
subroutine invalid_type(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
type(toml_table) :: table
type(toml_table), pointer :: child
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', 42)
call get_registry_settings(child, global_settings, error)
end subroutine
subroutine has_non_existent_path_to_registry(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
type(toml_table) :: table
type(toml_table), pointer :: child
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', 'nonexistent_path')
call get_registry_settings(child, global_settings, error)
end subroutine
subroutine has_existent_path_to_registry(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
type(toml_table) :: table
type(toml_table), pointer :: child
character(:), allocatable :: cwd
call delete_tmp_folder
call mkdir(tmp_folder)
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', '.')
call get_registry_settings(child, global_settings, error)
if (.not. allocated(global_settings%registry_settings%path)) then
call test_failed(error, 'Path not allocated')
return
end if
call delete_tmp_folder
call get_current_directory(cwd, error)
if (allocated(error)) return
if (global_settings%registry_settings%path /= join_path(cwd, tmp_folder)) then
call test_failed(error, "Path not set correctly: '"//global_settings%registry_settings%path//"'")
return
end if
if (allocated(global_settings%registry_settings%url)) then
call test_failed(error, "Url shouldn't be allocated")
return
end if
end subroutine
subroutine absolute_path_to_registry(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: abs_path
type(toml_table) :: table
type(toml_table), pointer :: child
call delete_tmp_folder
call mkdir(tmp_folder)
call get_absolute_path(tmp_folder, abs_path, error)
if (allocated(error)) return
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', abs_path)
call get_registry_settings(child, global_settings, error)
call delete_tmp_folder
if (allocated(error)) return
if (.not. allocated(global_settings%registry_settings)) then
call test_failed(error, 'Registry settings not allocated')
return
end if
if (.not. allocated(global_settings%registry_settings%path)) then
call test_failed(error, 'Path not allocated')
return
end if
if (global_settings%registry_settings%path /= abs_path) then
call test_failed(error, "Path not set correctly: '"//global_settings%registry_settings%path//"'")
return
end if
end subroutine
subroutine relative_path_to_registry(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: abs_path
type(toml_table) :: table
type(toml_table), pointer :: child
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'abc'))
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', 'abc')
call get_registry_settings(child, global_settings, error)
call get_absolute_path(tmp_folder, abs_path, error)
call delete_tmp_folder
if (allocated(error)) return
if (.not. allocated(global_settings%registry_settings)) then
call test_failed(error, 'Registry settings not allocated')
return
end if
if (global_settings%registry_settings%path /= join_path(abs_path, 'abc')) then
call test_failed(error, "Path not set correctly: '"//global_settings%registry_settings%path//"'")
return
end if
end subroutine
! Test that the registry path is set correctly when the path is written to and read from a config file.
subroutine relative_path_to_registry_file_read(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: abs_path
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'abc'))
call filewrite(join_path(tmp_folder, config_file_name), ['[registry]', 'path="abc"'])
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call get_global_settings(global_settings, error)
call get_absolute_path(tmp_folder, abs_path, error)
call delete_tmp_folder
if (allocated(error)) return
if (.not. allocated(global_settings%registry_settings)) then
call test_failed(error, 'Registry settings not allocated')
return
end if
if (global_settings%registry_settings%path /= join_path(abs_path, 'abc')) then
call test_failed(error, "Path not set correctly: '"//global_settings%registry_settings%path//"'")
return
end if
end subroutine
subroutine canonical_path_to_registry(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: abs_path
type(toml_table) :: table
type(toml_table), pointer :: child
call delete_tmp_folder
call mkdir(tmp_folder)
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', join_path('..', tmp_folder))
call get_registry_settings(child, global_settings, error)
call get_absolute_path(tmp_folder, abs_path, error)
call delete_tmp_folder
if (allocated(error)) return
if (.not. allocated(global_settings%registry_settings)) then
call test_failed(error, 'Registry settings not allocated')
return
end if
if (global_settings%registry_settings%path /= abs_path) then
call test_failed(error, "Path not set correctly: '"//global_settings%registry_settings%path//"'")
return
end if
end subroutine
subroutine has_url_to_registry(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
type(toml_table) :: table
type(toml_table), pointer :: child
call delete_tmp_folder
call mkdir(tmp_folder)
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'url', 'http')
call get_registry_settings(child, global_settings, error)
call delete_tmp_folder
if (.not. allocated(global_settings%registry_settings)) then
call test_failed(error, 'Registry settings not allocated')
return
end if
if (allocated(global_settings%registry_settings%path)) then
call test_failed(error, "Path shouldn't be allocated: '" &
& //global_settings%registry_settings%path//"'")
return
end if
if (.not. allocated(global_settings%registry_settings%url)) then
call test_failed(error, 'Url not allocated')
return
end if
if (global_settings%registry_settings%url /= 'http') then
call test_failed(error, 'Failed to parse url')
return
end if
end subroutine
subroutine has_both_path_and_url_to_registry(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
type(toml_table) :: table
type(toml_table), pointer :: child
call delete_tmp_folder
call mkdir(tmp_folder)
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', '.')
call set_value(child, 'url', 'http')
call get_registry_settings(child, global_settings, error)
call delete_tmp_folder
end subroutine
subroutine has_both_path_and_cache_path(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
type(toml_table) :: table
type(toml_table), pointer :: child
call delete_tmp_folder
call mkdir(tmp_folder)
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', '.')
call set_value(child, 'cache_path', 'cache')
call get_registry_settings(child, global_settings, error)
call delete_tmp_folder
end subroutine
! Custom cache location defined via absolute path but directory doesn't exist. Create it.
subroutine abs_cache_path_no_dir(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: abs_path, abs_path_to_cache
type(toml_table) :: table
type(toml_table), pointer :: child
call delete_tmp_folder
call mkdir(tmp_folder)
call get_absolute_path(tmp_folder, abs_path, error)
if (allocated(error)) return
abs_path_to_cache = join_path(abs_path, 'cache')
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'cache_path', abs_path_to_cache)
call get_registry_settings(child, global_settings, error)
if (.not. exists(abs_path_to_cache)) then
call test_failed(error, "Cache directory '"//abs_path_to_cache//"' not created.")
return
end if
if (global_settings%registry_settings%cache_path /= abs_path_to_cache) then
call test_failed(error, "Cache path '"//abs_path_to_cache//"' not registered.")
return
end if
call delete_tmp_folder
end subroutine
! Custom cache location defined via absolute path for existing directory.
subroutine abs_cache_path_has_dir(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: abs_path
type(toml_table) :: table
type(toml_table), pointer :: child
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'cache'))
call get_absolute_path(join_path(tmp_folder, 'cache'), abs_path, error)
if (allocated(error)) return
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'cache_path', abs_path)
call get_registry_settings(child, global_settings, error)
if (.not. exists(abs_path)) then
call test_failed(error, "Cache directory '"//abs_path//"' not created.")
return
end if
if (global_settings%registry_settings%cache_path /= abs_path) then
call test_failed(error, "Cache path '"//abs_path//"' not registered.")
return
end if
call delete_tmp_folder
end subroutine
! Custom cache location defined via relative path but directory doesn't exist. Create it.
subroutine rel_cache_path_no_dir(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
character(:), allocatable :: cache_path, abs_path
type(toml_table) :: table
type(toml_table), pointer :: child
call delete_tmp_folder
call mkdir(tmp_folder)
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'cache_path', 'cache')
call get_registry_settings(child, global_settings, error)
cache_path = join_path(tmp_folder, 'cache')
if (.not. exists(cache_path)) then
call test_failed(error, "Cache directory '"//cache_path//"' not created.")
return
end if
call get_absolute_path(cache_path, abs_path, error)
if (allocated(error)) return
if (global_settings%registry_settings%cache_path /= abs_path) then
call test_failed(error, "Cache path '"//cache_path//"' not registered.")
return
end if
call delete_tmp_folder
end subroutine
! Custom cache location defined via relative path for existing directory.
subroutine rel_cache_path_has_dir(error)
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: cache_path, abs_path
type(toml_table) :: table
type(toml_table), pointer :: child
call delete_tmp_folder
cache_path = join_path(tmp_folder, 'cache')
call mkdir(cache_path)
call setup_global_settings(global_settings, error)
if (allocated(error)) return
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'cache_path', 'cache')
call get_registry_settings(child, global_settings, error)
if (.not. exists(cache_path)) then
call test_failed(error, "Cache directory '"//cache_path//"' not created.")
return
end if
call get_absolute_path(cache_path, abs_path, error)
if (allocated(error)) return
if (global_settings%registry_settings%cache_path /= abs_path) then
call test_failed(error, "Cache path '"//cache_path//"' not registered.")
return
end if
call delete_tmp_folder
end subroutine
end module test_settings
fortran-lang-fpm-90bb83a/test/fpm_test/test_source_parsing.f90 0000664 0001750 0001750 00000237257 15145116760 024712 0 ustar alastair alastair !> 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, parse_use_statement
use fpm_model, only: srcfile_t, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, &
FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, &
FPM_UNIT_CPPSOURCE, FPM_UNIT_NAME
use fpm_strings, only: operator(.in.), lower, string_t
use fpm_error, only: file_parse_error, fatal_error
use fpm_manifest_preprocess, only: preprocess_config_t
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("nonintrinsic-modules-used", test_nonintrinsic_modules_used), &
& new_unittest("include-stmt", test_include_stmt), &
& new_unittest("program", test_program), &
& new_unittest("program-noheader", test_program_noheader), &
& new_unittest("program-noheader-2", test_program_noheader_2), &
& new_unittest("module", test_module), &
& new_unittest("module-with-subprogram", test_module_with_subprogram), &
& new_unittest("module-with-c-api", test_module_with_c_api), &
& new_unittest("module-with-abstract-interface",test_module_with_abstract_interface), &
& new_unittest("module-end-stmt", test_module_end_stmt), &
& new_unittest("program-with-module", test_program_with_module), &
& new_unittest("program-with-abstract-interface", test_program_with_abstract_interface), &
& 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.), &
& new_unittest("use-statement",test_use_statement), &
& new_unittest("conditional-compilation", test_conditional_compilation), &
& new_unittest("conditional-compilation-elif", test_conditional_compilation_elif), &
& new_unittest("conditional-compilation-elif-else", test_conditional_compilation_elif_else), &
& new_unittest("conditional-compilation_ifdef_else", test_conditional_compilation_ifdef_else), &
& new_unittest("conditional-if-defined", test_conditional_if_defined), &
& new_unittest("conditional-macro-comparison", test_conditional_macro_comparison), &
& new_unittest("define-without-trailing-space", test_define_no_trailing_space), &
& new_unittest("macro-case-sensitivity", test_macro_case_sensitivity), &
& new_unittest("if-macro-truthy", test_if_macro_truthy), &
& new_unittest("if-macro-truthy-from-define", test_if_macro_truthy_from_define) &
]
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
call f_source%test_serialization('srcfile_t: serialization', error)
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
call f_source%test_serialization('srcfile_t: serialization', error)
end subroutine test_intrinsic_modules_used
!> Check that intrinsic module names are not ignored if declared non_intrinsic
subroutine test_nonintrinsic_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, non_intrinsic :: iso_c_binding', &
& ' use, intrinsic :: iso_fortran_env', &
& ' use, non_intrinsic :: ieee_arithmetic', &
& ' use, non_intrinsic :: ieee_exceptions', &
& ' use, non_intrinsic :: ieee_features', &
& ' use, non_intrinsic :: my_module', &
& ' 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) /= 5) then
call test_failed(error,'Incorrect number of modules_used - expecting five')
return
end if
if (.not. ('iso_c_binding' .in. f_source%modules_used)) then
call test_failed(error,'Non-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 (.not. ('ieee_arithmetic' .in. f_source%modules_used)) then
call test_failed(error,'Non-Intrinsic module not found in modules_used')
return
end if
if (.not. ('ieee_exceptions' .in. f_source%modules_used)) then
call test_failed(error,'Non-Intrinsic module not found in modules_used')
return
end if
if (.not. ('ieee_features' .in. f_source%modules_used)) then
call test_failed(error,'Non-Intrinsic module not found in modules_used')
return
end if
if (.not. ('my_module' .in. f_source%modules_used)) then
call test_failed(error,'Non-Intrinsic module not found in modules_used')
return
end if
end subroutine test_nonintrinsic_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
call f_source%test_serialization('srcfile_t: serialization', error)
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
call f_source%test_serialization('srcfile_t: serialization', error)
end subroutine test_program
!> Try to parse a simple fortran program with no "program" header
subroutine test_program_noheader(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)') &
& 'use program_one', &
& 'implicit none', &
& 'integer :: module, program', &
& 'module = 1', &
& 'module= 1', &
& 'module =1', &
& 'module (i) =1', &
& 'program = 123', &
& 'contains', &
& 'subroutine f()', &
& 'end subroutine f', &
& 'end 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, found '//&
FPM_UNIT_NAME(f_source%unit_type))
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.('program_one' .in. f_source%modules_used)) then
call test_failed(error,'Missing module in modules_used')
return
end if
call f_source%test_serialization('srcfile_t: serialization', error)
end subroutine test_program_noheader
!> Try to parse a simple fortran program with no "program" header
subroutine test_program_noheader_2(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)') &
& 'print *, "Hello World"', &
& 'end 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, found '//&
FPM_UNIT_NAME(f_source%unit_type))
return
end if
call f_source%test_serialization('srcfile_t: serialization', error)
end subroutine test_program_noheader_2
!> Try to parse fortran module
subroutine test_module(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: unit
character(:), allocatable :: temp_file
type(srcfile_t), allocatable :: f_source
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& '#define preprocesor_line_outside', &
& 'module my_mod ! A trailing comment', &
& 'use module_one', &
& 'interface', &
& ' module subroutine f() bind(C)', &
& 'end interface', &
& 'integer :: program', &
& 'program = 1', &
& 'program= 1', &
& 'program =1', &
& 'program (i) =1', &
& 'contains', &
& 'module subroutine&', &
& ' e()', &
& ' integer, parameter :: c = 1', &
& ' integer :: & ', &
& ' bind(c)', &
& ' bind(c) = 1', &
& 'end subroutine e', &
& 'module subroutine f()', &
& 'end subroutine f', &
& 'module function g()', &
& 'end function g', &
& 'module integer function h()', &
& 'end function h', &
& 'module real function i()', &
& 'string = " &', &
& 'module name"', &
& 'string = " &', &
& 'module name !"', &
& 'end function i', &
& 'end module test', &
& '! A trailing comment outside of module'
close(unit)
f_source = parse_f_source(temp_file,error)
if (allocated(error)) then
return
end if
if (f_source%unit_type /= FPM_UNIT_MODULE) then
call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_MODULE')
return
end if
if (size(f_source%modules_provided) /= 1) then
call test_failed(error,'Unexpected modules_provided - expecting one')
return
end if
if (size(f_source%modules_used) /= 1) then
call test_failed(error,'Incorrect number of modules_used - expecting one')
return
end if
if (.not.('my_mod' .in. f_source%modules_provided)) then
call test_failed(error,'Missing module in modules_provided')
return
end if
if (.not.('module_one' .in. f_source%modules_used)) then
call test_failed(error,'Missing module in modules_used')
return
end if
call f_source%test_serialization('srcfile_t: serialization', error)
end subroutine test_module
!> Try to parse fortran module with subroutine outside of module
!> (this should be detected as FPM_UNIT_SUBPROGRAM not FPM_UNIT_MODULE)
subroutine test_module_with_subprogram(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: unit
character(:), allocatable :: temp_file
type(srcfile_t), allocatable :: f_source
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'module my_mod', &
& 'contains', &
& 'module subroutine f()', &
& 'end subroutine f', &
& 'module function g()', &
& 'end function g', &
& 'end module test',&
& 'function h()', &
& 'end function'
close(unit)
f_source = parse_f_source(temp_file,error)
if (allocated(error)) then
return
end if
if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then
call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM')
return
end if
if (size(f_source%modules_provided) /= 1) then
call test_failed(error,'Unexpected modules_provided - expecting one')
return
end if
if (size(f_source%modules_used) /= 0) then
call test_failed(error,'Incorrect number of modules_used - expecting zero')
return
end if
call f_source%test_serialization('srcfile_t: serialization', error)
end subroutine test_module_with_subprogram
!> Try to parse fortran modules without the full end module statement
!> This should be detected as FPM_UNIT_SUBPROGRAM not FPM_UNIT_MODULE
!> because we cannot guarantee if non-module subprograms are present
subroutine test_module_end_stmt(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: unit
character(:), allocatable :: temp_file
type(srcfile_t), allocatable :: f_source
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'module mod1', &
& 'contains', &
& 'module subroutine f()', &
& 'end subroutine f', &
& 'module function g()', &
& 'end function g', &
& 'end', &
& 'module mod2', &
& 'contains', &
& 'module subroutine f()', &
& 'end subroutine f', &
& 'module function g()', &
& 'end function g', &
& 'end module mod2'
close(unit)
f_source = parse_f_source(temp_file,error)
if (allocated(error)) then
return
end if
if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then
call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM')
return
end if
if (size(f_source%modules_provided) /= 2) then
call test_failed(error,'Unexpected modules_provided - expecting two')
return
end if
if (size(f_source%modules_used) /= 0) then
call test_failed(error,'Incorrect number of modules_used - expecting zero')
return
end if
if (.not.('mod1' .in. f_source%modules_provided)) then
call test_failed(error,'Missing module in modules_provided')
return
end if
if (.not.('mod2' .in. f_source%modules_provided)) then
call test_failed(error,'Missing module in modules_provided')
return
end if
call f_source%test_serialization('srcfile_t: serialization', error)
end subroutine test_module_end_stmt
!> Try to parse fortran module with exported C-API via bind(c)
!> (this should be detected as FPM_UNIT_SUBPROGRAM not FPM_UNIT_MODULE to prevent pruning)
subroutine test_module_with_c_api(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: unit
character(:), allocatable :: temp_file
type(srcfile_t), allocatable :: f_source
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& 'module my_mod', &
& 'contains', &
& 'subroutine f() &', &
& ' bind(C)', &
& 'end subroutine f', &
& 'module function g()', &
& 'end function g', &
& 'end module test'
close(unit)
f_source = parse_f_source(temp_file,error)
if (allocated(error)) then
return
end if
if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then
call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM')
return
end if
if (size(f_source%modules_provided) /= 1) then
call test_failed(error,'Unexpected modules_provided - expecting one')
return
end if
if (size(f_source%modules_used) /= 0) then
call test_failed(error,'Incorrect number of modules_used - expecting zero')
return
end if
call f_source%test_serialization('srcfile_t: serialization', error)
end subroutine test_module_with_c_api
!> Check parsing of module exporting an abstract interface
!> See also https://github.com/fortran-lang/fpm/issues/1073
subroutine test_module_with_abstract_interface(error)
type(error_t), allocatable, intent(out) :: error
integer :: unit
character(:), allocatable :: temp_file
type(srcfile_t) :: f_source
allocate(temp_file,source=get_temp_filename())
open(file=temp_file,newunit=unit)
write(unit, '(A)') &
& 'module foo', &
& 'abstract interface', &
& ' subroutine bar1()', &
& ' end subroutine', &
& ' subroutine bar2() bind(c)', &
& ' end subroutine', &
& 'end interface', &
& 'end module foo'
close(unit)
f_source = parse_f_source(temp_file,error)
if (allocated(error)) return
if (f_source%unit_type /= FPM_UNIT_MODULE) then
call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_MODULE')
return
end if
call f_source%test_serialization('srcfile_t: serialization', error)
end subroutine test_module_with_abstract_interface
!> 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
call f_source%test_serialization('srcfile_t: serialization', error)
end subroutine test_program_with_module
!> Check parsing of interfaces within program unit
!> See also https://github.com/fortran-lang/fpm/issues/1073
subroutine test_program_with_abstract_interface(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', &
& 'implicit none', &
& 'abstract interface', &
& ' function cmpfunc(a,b) bind(c)', &
& ' use, intrinsic :: iso_c_binding', &
& ' type(c_ptr), intent(in), value :: a, b', &
& ' integer(c_int) :: cmpfunc', &
& ' end function', &
& 'end interface', &
& 'interface', &
& ' subroutine qsort(ptr,count,size,comp) bind(c,name="qsort")', &
& ' use, intrinsic :: iso_c_binding', &
& ' type(c_ptr), value :: ptr', &
& ' integer(c_size_t), value :: count, size', &
& ' type(c_funptr), value :: comp', &
& 'end interface', &
& '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
! Intrinsic modules are not counted in `modules_used` (!)
if (size(f_source%modules_used) /= 0) then
call test_failed(error,'Incorrect number of modules_used - expecting zero')
return
end if
call f_source%test_serialization('srcfile_t: serialization', error)
end subroutine test_program_with_abstract_interface
!> 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
call f_source%test_serialization('srcfile_t: serialization', error)
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
call f_source%test_serialization('srcfile_t: serialization', error)
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
call f_source%test_serialization('srcfile_t: serialization', error)
end subroutine test_subprogram
!> Try to parse standard c source for includes
subroutine test_csource(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: unit
character(:), allocatable :: temp_file
type(srcfile_t), allocatable :: f_source
allocate(temp_file, source=get_temp_filename())
temp_file = temp_file//'.c'
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& '#include "proto.h"', &
& 'void c_func(int a) {', &
& ' #include "function_body.c"', &
& ' return', &
& '}'
close(unit)
f_source = parse_c_source(temp_file,error)
if (allocated(error)) then
return
end if
if (f_source%unit_type /= FPM_UNIT_CSOURCE) then
call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_CSOURCE')
return
end if
if (size(f_source%modules_provided) /= 0) then
call test_failed(error,'Unexpected modules_provided - expecting zero')
return
end if
if (size(f_source%modules_used) /= 0) then
call test_failed(error,'Incorrect number of modules_used - expecting zero')
return
end if
if (size(f_source%include_dependencies) /= 2) then
call test_failed(error,'Incorrect number of include_dependencies - expecting two')
return
end if
if (allocated(f_source%link_libraries)) then
call test_failed(error,'Unexpected link_libraries - expecting unallocated')
return
end if
if (size(f_source%parent_modules) /= 0) then
call test_failed(error,'Incorrect number of parent_modules - expecting zero')
return
end if
if (.not.('proto.h' .in. f_source%include_dependencies)) then
call test_failed(error,'Missing file in include_dependencies')
return
end if
if (.not.('function_body.c' .in. f_source%include_dependencies)) then
call test_failed(error,'Missing file in include_dependencies')
return
end if
call f_source%test_serialization('srcfile_t: serialization', error)
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
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
!> Parse several USE statements
subroutine test_use_statement(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(*), parameter :: filename='test_use_statement'
character(:), allocatable :: line,module_name
logical :: used,is_intrinsic
line = 'use, intrinsic:: iso_fortran_env'
call parse_use_statement(filename,0,line,used,is_intrinsic,module_name,error)
if (allocated(error)) return
if (.not. (used .and. &
is_intrinsic .and. &
module_name=='iso_fortran_env' .and. &
used)) then
call fatal_error(error,'USE statement failed parsing <'//line//'>')
return
endif
line = 'use, non_intrinsic :: iso_fortran_env'
call parse_use_statement(filename,0,line,used,is_intrinsic,module_name,error)
if (allocated(error)) return
if (.not. (used .and. &
(.not.is_intrinsic) .and. &
module_name=='iso_fortran_env' .and. &
used)) then
call fatal_error(error,'USE statement failed parsing <'//line//'>')
return
endif
line = 'use, non_intrinsic :: my_fortran_module'
call parse_use_statement(filename,0,line,used,is_intrinsic,module_name,error)
if (allocated(error)) return
if (.not. (used .and. &
(.not.is_intrinsic) .and. &
module_name=='my_fortran_module' .and. &
used)) then
call fatal_error(error,'USE statement failed parsing <'//line//'>')
return
endif
line = 'use, intrinsic :: my_fortran_module'
call parse_use_statement(filename,0,line,used,is_intrinsic,module_name,error)
! This is not an intrinsic module: should detect an error
if (.not. allocated(error)) then
call fatal_error(error,'Did not catch invalid intrinsic module in <'//line//'>')
return
else
deallocate(error)
endif
end subroutine test_use_statement
!> Test conditional compilation parsing with CPP preprocessing
subroutine test_conditional_compilation(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(srcfile_t) :: f_source
character(:), allocatable :: temp_file
integer :: unit
type(preprocess_config_t) :: cpp_config
! Test 1: Without preprocessing, should include dependencies from #ifdef blocks
temp_file = get_temp_filename()
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
'module test_mod', &
'#ifdef SOME_FEATURE', &
' use nonexistent_module', &
'#endif', &
' implicit none', &
'contains', &
' subroutine test_sub()', &
' print *, "test"', &
' end subroutine', &
'end module test_mod'
close(unit)
! Parse without preprocessing - should detect the use statement
f_source = parse_f_source(temp_file, error)
if (allocated(error)) return
if (size(f_source%modules_used) /= 1) then
call test_failed(error, 'Expected 1 module dependency without preprocessing, got different count')
return
end if
if (f_source%modules_used(1)%s /= 'nonexistent_module') then
call test_failed(error, 'Expected nonexistent_module, got: '//f_source%modules_used(1)%s)
return
end if
! Test 2: With preprocessing enabled, should skip dependencies from #ifdef blocks
call cpp_config%new([string_t::])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
if (size(f_source%modules_used) /= 0) then
call test_failed(error, 'Expected 0 module dependencies with preprocessing, got some dependencies')
return
end if
if (f_source%unit_type /= FPM_UNIT_MODULE) then
call test_failed(error, 'Expected module unit type')
return
end if
if (size(f_source%modules_provided) /= 1) then
call test_failed(error, 'Expected 1 provided module')
return
end if
if (f_source%modules_provided(1)%s /= 'test_mod') then
call test_failed(error, 'Expected test_mod, got: '//f_source%modules_provided(1)%s)
return
end if
end subroutine test_conditional_compilation
!> Test conditional compilation parsing with CPP preprocessing
subroutine test_conditional_compilation_elif(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(srcfile_t) :: f_source
character(:), allocatable :: temp_file
integer :: unit
type(preprocess_config_t) :: cpp_config
! Test 1: Without preprocessing, should include dependencies from #ifdef blocks
temp_file = get_temp_filename()
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
'module test_mod', &
'#ifdef SOME_FEATURE', &
' use nonexistent_module', &
'#elif defined(ANOTHER_FEATURE)', &
' use another_nonexistent_module', &
'#endif', &
' implicit none', &
'contains', &
' subroutine test_sub()', &
' print *, "test"', &
' end subroutine', &
'end module test_mod'
close(unit)
! Parse without preprocessing - should detect the use statement
f_source = parse_f_source(temp_file, error)
if (allocated(error)) return
if (size(f_source%modules_used) /= 2) then
call test_failed(error, 'Expected 2 module dependency without preprocessing, got different count')
return
end if
if (f_source%modules_used(1)%s /= 'nonexistent_module') then
call test_failed(error, 'Expected nonexistent_module, got: '//f_source%modules_used(1)%s)
return
end if
if (f_source%modules_used(2)%s /= 'another_nonexistent_module') then
call test_failed(error, 'Expected another_nonexistent_module, got: '//f_source%modules_used(2)%s)
return
end if
! Test 2: With preprocessing enabled, should skip dependencies from #ifdef blocks
call cpp_config%new([string_t::])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
if (size(f_source%modules_used) /= 0) then
call test_failed(error, 'Expected 0 module dependencies with preprocessing, got some dependencies')
return
end if
if (f_source%unit_type /= FPM_UNIT_MODULE) then
call test_failed(error, 'Expected module unit type')
return
end if
if (size(f_source%modules_provided) /= 1) then
call test_failed(error, 'Expected 1 provided module')
return
end if
if (f_source%modules_provided(1)%s /= 'test_mod') then
call test_failed(error, 'Expected test_mod, got: '//f_source%modules_provided(1)%s)
return
end if
end subroutine test_conditional_compilation_elif
!> Test conditional compilation parsing with CPP preprocessing
subroutine test_conditional_compilation_elif_else(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(srcfile_t) :: f_source
character(:), allocatable :: temp_file
integer :: unit
type(preprocess_config_t) :: cpp_config
! Test 1: Without preprocessing, should include dependencies from #ifdef blocks
temp_file = get_temp_filename()
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
'module test_mod', &
'#ifdef SOME_FEATURE', &
' use nonexistent_module', &
'#elif defined(ANOTHER_FEATURE)', &
' use another_nonexistent_module', &
'#else',&
' use a_third_module',&
'#endif', &
' implicit none', &
'contains', &
' subroutine test_sub()', &
' print *, "test"', &
' end subroutine', &
'end module test_mod'
close(unit)
! Parse without preprocessing - should detect the use statement
f_source = parse_f_source(temp_file, error)
if (allocated(error)) return
if (size(f_source%modules_used) /= 3) then
call test_failed(error, 'Expected 3 module dependency without preprocessing, got different count')
return
end if
if (f_source%modules_used(1)%s /= 'nonexistent_module') then
call test_failed(error, 'Expected nonexistent_module, got: '//f_source%modules_used(1)%s)
return
end if
if (f_source%modules_used(2)%s /= 'another_nonexistent_module') then
call test_failed(error, 'Expected another_nonexistent_module, got: '//f_source%modules_used(2)%s)
return
end if
if (f_source%modules_used(3)%s /= 'a_third_module') then
call test_failed(error, 'Expected a_third_module, got: '//f_source%modules_used(3)%s)
return
end if
! Test 2: With preprocessing enabled, should skip dependencies from #ifdef blocks
call cpp_config%new([string_t::])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
if (size(f_source%modules_used) /= 1) then
call test_failed(error, 'Expected 1 module dependencies with preprocessing, got some dependencies')
return
end if
if (f_source%unit_type /= FPM_UNIT_MODULE) then
call test_failed(error, 'Expected module unit type')
return
end if
if (size(f_source%modules_provided) /= 1) then
call test_failed(error, 'Expected 1 provided module')
return
end if
if (f_source%modules_provided(1)%s /= 'test_mod') then
call test_failed(error, 'Expected test_mod, got: '//f_source%modules_provided(1)%s)
return
end if
end subroutine test_conditional_compilation_elif_else
subroutine test_conditional_compilation_ifdef_else(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(srcfile_t) :: f_source
character(:), allocatable :: temp_file
integer :: unit
type(preprocess_config_t) :: cpp_config
! Test 1: Without preprocessing, should include dependencies from #ifdef blocks
temp_file = get_temp_filename()
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
'module test_mod', &
'#ifdef SOME_FEATURE', &
' use nonexistent_module', &
'#else',&
' use a_second_module',&
'#endif', &
' implicit none', &
'contains', &
' subroutine test_sub()', &
' print *, "test"', &
' end subroutine', &
'end module test_mod'
close(unit)
! Parse without preprocessing - should detect the use statement
f_source = parse_f_source(temp_file, error)
if (allocated(error)) return
if (size(f_source%modules_used) /= 2) then
call test_failed(error, 'Expected 2 module dependency without preprocessing, got different count')
return
end if
if (f_source%modules_used(1)%s /= 'nonexistent_module') then
call test_failed(error, 'Expected nonexistent_module, got: '//f_source%modules_used(1)%s)
return
end if
if (f_source%modules_used(2)%s /= 'a_second_module') then
call test_failed(error, 'Expected a_second_module, got: '//f_source%modules_used(2)%s)
return
end if
! Test 2: With preprocessing enabled, should skip dependencies from #ifdef blocks
call cpp_config%new([string_t::])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
if (size(f_source%modules_used) /= 1) then
call test_failed(error, 'Expected 1 module dependencies with preprocessing, got some dependencies')
return
end if
if (f_source%unit_type /= FPM_UNIT_MODULE) then
call test_failed(error, 'Expected module unit type')
return
end if
if (size(f_source%modules_provided) /= 1) then
call test_failed(error, 'Expected 1 provided module')
return
end if
if (f_source%modules_provided(1)%s /= 'test_mod') then
call test_failed(error, 'Expected test_mod, got: '//f_source%modules_provided(1)%s)
return
end if
end subroutine test_conditional_compilation_ifdef_else
!> Test conditional compilation parsing with #if defined() syntax
subroutine test_conditional_if_defined(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(srcfile_t) :: f_source
character(:), allocatable :: temp_file
integer :: unit
type(preprocess_config_t) :: cpp_config
temp_file = get_temp_filename()
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
'module test_mod', &
'#if defined(SOME_FEATURE)', &
' use some_module', &
'#endif', &
'#if !defined(OTHER_FEATURE)', &
' use other_module', &
'#endif', &
'#if SIMPLE_MACRO', &
' use third_module', &
'#endif', &
'#ifdef FOURTH_FEATURE', &
' use fourth_module', &
'#endif', &
'#ifndef FIFTH_FEATURE', &
' use fifth_module', &
' #ifdef NESTED_FEATURE', &
' use nested_module', &
' #endif', &
'#endif', &
' implicit none', &
'end module test_mod'
close(unit)
! Without preprocessing - should detect all dependencies (including nested)
f_source = parse_f_source(temp_file, error)
if (allocated(error)) return
if (size(f_source%modules_used) /= 6) then
call test_failed(error, 'Expected 6 module dependencies without preprocessing')
return
end if
! With preprocessing - should skip all dependencies (no macros defined)
call cpp_config%new([string_t::])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
! Should find 2 dependencies: !defined(OTHER_FEATURE) and #ifndef FIFTH_FEATURE are both true
! The nested #ifdef NESTED_FEATURE should be inactive since NESTED_FEATURE is not defined
if (size(f_source%modules_used) /= 2) then
if (size(f_source%modules_used) > 0) then
call test_failed(error, 'Expected 2 module dependencies with preprocessing, got ' // &
f_source%modules_used(1)%s // ' (and others)')
else
call test_failed(error, 'Expected 2 module dependencies with preprocessing, got 0')
end if
return
end if
! Test with some macros defined - should find active dependencies
call cpp_config%new([string_t('SOME_FEATURE'), string_t('SIMPLE_MACRO')])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
if (.not.('some_module' .in. f_source%modules_used)) then ! some_module
call test_failed(error, 'Expected "some_module" dependency with SOME_FEATURE and SIMPLE_MACRO defined')
return
end if
if (.not.('other_module' .in. f_source%modules_used)) then ! other_module
call test_failed(error, 'Expected "other_module" dependency with SOME_FEATURE and SIMPLE_MACRO defined')
return
end if
if (.not.('third_module' .in. f_source%modules_used)) then ! third_module
call test_failed(error, 'Expected "third_module" dependency with SOME_FEATURE and SIMPLE_MACRO defined')
return
end if
if (.not.('fifth_module' .in. f_source%modules_used)) then ! fifth_module
call test_failed(error, 'Expected "fifth_module" dependency with SOME_FEATURE and SIMPLE_MACRO defined')
return
end if
if (size(f_source%modules_used) /= 4) then ! all modules
call test_failed(error, 'Expected 4 module dependencies with SOME_FEATURE and SIMPLE_MACRO defined')
return
end if
! Test nested condition: define outer but not inner macro
call cpp_config%new([string_t('FIFTH_FEATURE')]) ! This makes #ifndef FIFTH_FEATURE inactive
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
if (size(f_source%modules_used) /= 1) then
if (size(f_source%modules_used) > 0) then
call test_failed(error, 'Expected 1 module dependency with FIFTH_FEATURE defined, got: ' // &
f_source%modules_used(2)%s // ' (and maybe others)')
else
call test_failed(error, 'Expected 1 module dependency with FIFTH_FEATURE defined, got 0')
end if
return
end if
! Test nested condition: define both outer condition (negative) and inner (positive)
call cpp_config%new([string_t('NESTED_FEATURE')]) ! FIFTH_FEATURE not defined, NESTED_FEATURE defined
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
if (size(f_source%modules_used) /= 3) then
call test_failed(error, 'Expected 3 module dependencies with nested conditions active')
return
end if
end subroutine test_conditional_if_defined
!> Test conditional compilation with #if MACRO == VALUE and #if MACRO != VALUE
subroutine test_conditional_macro_comparison(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(srcfile_t) :: f_source
character(:), allocatable :: temp_file
integer :: unit
type(preprocess_config_t) :: cpp_config
temp_file = get_temp_filename()
! Test file with macro value comparisons and #define
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
'module test_mod', &
'#define LOCAL_MACRO 1', &
'#if EXTERNAL_MACRO == 1', &
' use external_eq_module', &
'#endif', &
'#if EXTERNAL_MACRO != 1', &
' use external_neq_module', &
'#endif', &
'#if LOCAL_MACRO == 1', &
' use local_eq_module', &
'#endif', &
'#if LOCAL_MACRO != 1', &
' use local_neq_module', &
'#endif', &
'#if UNDEFINED_MACRO == 1', &
' use undefined_module', &
'#endif', &
' implicit none', &
'end module test_mod'
close(unit)
! Test 1: With CPP enabled but no external macros defined
! LOCAL_MACRO is defined via #define, EXTERNAL_MACRO is not
call cpp_config%new([string_t::])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
! Should find: local_eq_module (LOCAL_MACRO==1 is true)
! external_neq_module (EXTERNAL_MACRO!=1 is true since undefined)
! Should NOT find: external_eq_module, local_neq_module, undefined_module
if (.not.('local_eq_module' .in. f_source%modules_used)) then
call test_failed(error, 'Expected local_eq_module with #define LOCAL_MACRO 1')
return
end if
if ('local_neq_module' .in. f_source%modules_used) then
call test_failed(error, 'Should not find local_neq_module when LOCAL_MACRO==1')
return
end if
if ('external_eq_module' .in. f_source%modules_used) then
call test_failed(error, 'Should not find external_eq_module when EXTERNAL_MACRO is undefined')
return
end if
if (.not.('external_neq_module' .in. f_source%modules_used)) then
call test_failed(error, 'Expected external_neq_module (UNDEFINED != 1 should be true)')
return
end if
if ('undefined_module' .in. f_source%modules_used) then
call test_failed(error, 'Should not find undefined_module when UNDEFINED_MACRO is undefined')
return
end if
! Test 2: With external macro defined to matching value
call cpp_config%new([string_t('EXTERNAL_MACRO=1')])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
if (.not.('external_eq_module' .in. f_source%modules_used)) then
call test_failed(error, 'Expected external_eq_module with EXTERNAL_MACRO=1')
return
end if
if ('external_neq_module' .in. f_source%modules_used) then
call test_failed(error, 'Should not find external_neq_module when EXTERNAL_MACRO==1')
return
end if
! Test 3: With external macro defined to non-matching value
call cpp_config%new([string_t('EXTERNAL_MACRO=2')])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
if ('external_eq_module' .in. f_source%modules_used) then
call test_failed(error, 'Should not find external_eq_module when EXTERNAL_MACRO==2')
return
end if
if (.not.('external_neq_module' .in. f_source%modules_used)) then
call test_failed(error, 'Expected external_neq_module with EXTERNAL_MACRO=2 (!=1)')
return
end if
end subroutine test_conditional_macro_comparison
!> Test #define directive without trailing space (issue #1222)
!> This tests for out-of-bounds access when parsing #define at end of line
subroutine test_define_no_trailing_space(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: unit
character(:), allocatable :: temp_file
type(srcfile_t), allocatable :: f_source
type(preprocess_config_t) :: cpp_config
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
! Note: #define SIMPLE_FLAG has no trailing space - this triggered
! an out-of-bounds error before the fix
write(unit, '(a)') &
& '#define SIMPLE_FLAG', &
& '#ifdef SIMPLE_FLAG', &
& ' use flag_module', &
& '#endif', &
& 'program test', &
& ' implicit none', &
& 'end program test'
close(unit)
call cpp_config%new([string_t::])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
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 (.not.('flag_module' .in. f_source%modules_used)) then
call test_failed(error, 'Expected flag_module with #define SIMPLE_FLAG (no trailing space)')
return
end if
end subroutine test_define_no_trailing_space
!> Test that CPP macros are case-sensitive (per CPP standard)
subroutine test_macro_case_sensitivity(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: unit
character(:), allocatable :: temp_file
type(srcfile_t), allocatable :: f_source
type(preprocess_config_t) :: cpp_config
allocate(temp_file, source=get_temp_filename())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& '! Test #ifdef (uses macro_in_list)', &
& '#ifdef MY_MACRO', &
& ' use ifdef_uppercase_module', &
& '#endif', &
& '#ifdef my_macro', &
& ' use ifdef_lowercase_module', &
& '#endif', &
& '#ifdef My_Macro', &
& ' use ifdef_mixedcase_module', &
& '#endif', &
& '! Test #if MACRO (uses macro_is_truthy -> get_macro_value)', &
& '#if MY_MACRO', &
& ' use if_uppercase_module', &
& '#endif', &
& '#if my_macro', &
& ' use if_lowercase_module', &
& '#endif', &
& '#if My_Macro', &
& ' use if_mixedcase_module', &
& '#endif', &
& 'program test', &
& ' implicit none', &
& 'end program test'
close(unit)
! Test 1: Define MY_MACRO=1 (uppercase) - should only match uppercase for both #ifdef and #if
call cpp_config%new([string_t('MY_MACRO=1')])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
! #ifdef tests (macro_in_list)
if (.not.('ifdef_uppercase_module' .in. f_source%modules_used)) then
call test_failed(error, '#ifdef: Expected ifdef_uppercase_module with MY_MACRO defined')
return
end if
if ('ifdef_lowercase_module' .in. f_source%modules_used) then
call test_failed(error, '#ifdef: Should not find ifdef_lowercase_module - case-sensitive')
return
end if
if ('ifdef_mixedcase_module' .in. f_source%modules_used) then
call test_failed(error, '#ifdef: Should not find ifdef_mixedcase_module - case-sensitive')
return
end if
! #if tests (macro_is_truthy -> get_macro_value)
if (.not.('if_uppercase_module' .in. f_source%modules_used)) then
call test_failed(error, '#if: Expected if_uppercase_module with MY_MACRO=1 defined')
return
end if
if ('if_lowercase_module' .in. f_source%modules_used) then
call test_failed(error, '#if: Should not find if_lowercase_module - case-sensitive')
return
end if
if ('if_mixedcase_module' .in. f_source%modules_used) then
call test_failed(error, '#if: Should not find if_mixedcase_module - case-sensitive')
return
end if
! Test 2: Define my_macro=1 (lowercase) - should only match lowercase
call cpp_config%new([string_t('my_macro=1')])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
! #ifdef tests
if ('ifdef_uppercase_module' .in. f_source%modules_used) then
call test_failed(error, '#ifdef: Should not find ifdef_uppercase_module - case-sensitive')
return
end if
if (.not.('ifdef_lowercase_module' .in. f_source%modules_used)) then
call test_failed(error, '#ifdef: Expected ifdef_lowercase_module with my_macro defined')
return
end if
! #if tests
if ('if_uppercase_module' .in. f_source%modules_used) then
call test_failed(error, '#if: Should not find if_uppercase_module - case-sensitive')
return
end if
if (.not.('if_lowercase_module' .in. f_source%modules_used)) then
call test_failed(error, '#if: Expected if_lowercase_module with my_macro=1 defined')
return
end if
end subroutine test_macro_case_sensitivity
!> Test #if MACRO truthy evaluation per CPP semantics
!> Per CPP: undefined=0, MACRO=0 is false, MACRO=1 is true, MACRO=non-zero is true
subroutine test_if_macro_truthy(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: unit
character(:), allocatable :: temp_file
type(srcfile_t), allocatable :: f_source
type(preprocess_config_t) :: cpp_config
allocate(temp_file, source=get_temp_filename())
! Test file with #if MACRO (not #ifdef, not #if defined())
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& '#if UNDEFINED_MACRO', &
& ' use undefined_module', &
& '#endif', &
& '#if ZERO_MACRO', &
& ' use zero_module', &
& '#endif', &
& '#if ONE_MACRO', &
& ' use one_module', &
& '#endif', &
& '#if NONZERO_MACRO', &
& ' use nonzero_module', &
& '#endif', &
& '#if EMPTY_MACRO', &
& ' use empty_module', &
& '#endif', &
& 'program test', &
& ' implicit none', &
& 'end program test'
close(unit)
! Test 1: No macros defined - only UNDEFINED should be tested (evaluates to 0/false)
call cpp_config%new([string_t::])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
if ('undefined_module' .in. f_source%modules_used) then
call test_failed(error, 'Undefined macro should evaluate to false in #if')
return
end if
! Test 2: ZERO_MACRO=0 should be false, ONE_MACRO=1 should be true
call cpp_config%new([string_t('ZERO_MACRO=0'), string_t('ONE_MACRO=1')])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
if ('zero_module' .in. f_source%modules_used) then
call test_failed(error, 'MACRO=0 should evaluate to false in #if')
return
end if
if (.not.('one_module' .in. f_source%modules_used)) then
call test_failed(error, 'MACRO=1 should evaluate to true in #if')
return
end if
! Test 3: Non-zero values should be truthy
call cpp_config%new([string_t('NONZERO_MACRO=42')])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
if (.not.('nonzero_module' .in. f_source%modules_used)) then
call test_failed(error, 'MACRO=42 (non-zero) should evaluate to true in #if')
return
end if
! Test 4: Empty macro (defined without value) - true, like -DMACRO on command line
call cpp_config%new([string_t('EMPTY_MACRO')])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
if (.not.('empty_module' .in. f_source%modules_used)) then
call test_failed(error, 'Empty macro should evaluate to true in #if (like -DMACRO)')
return
end if
end subroutine test_if_macro_truthy
!> Test all CPP conditional formats for macros defined inside source via #define
!> Formats: #if MACRO, #ifdef MACRO, #if defined(MACRO), #if defined MACRO, #if MACRO == val
subroutine test_if_macro_truthy_from_define(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: unit
character(:), allocatable :: temp_file
type(srcfile_t), allocatable :: f_source
type(preprocess_config_t) :: cpp_config
allocate(temp_file, source=get_temp_filename())
! Test file with #define inside source, then various conditional formats
open(file=temp_file, newunit=unit)
write(unit, '(a)') &
& '#define ZERO_MACRO 0', &
& '#define ONE_MACRO 1', &
& '#define NONZERO_MACRO 42', &
& '#define EMPTY_MACRO', &
& '', &
& '! Test #if MACRO format', &
& '#if ZERO_MACRO', &
& ' use if_zero_module', &
& '#endif', &
& '#if ONE_MACRO', &
& ' use if_one_module', &
& '#endif', &
& '#if NONZERO_MACRO', &
& ' use if_nonzero_module', &
& '#endif', &
& '#if EMPTY_MACRO', &
& ' use if_empty_module', &
& '#endif', &
& '#if UNDEFINED_MACRO', &
& ' use if_undefined_module', &
& '#endif', &
& '', &
& '! Test #ifdef MACRO format', &
& '#ifdef ZERO_MACRO', &
& ' use ifdef_zero_module', &
& '#endif', &
& '#ifdef ONE_MACRO', &
& ' use ifdef_one_module', &
& '#endif', &
& '#ifdef EMPTY_MACRO', &
& ' use ifdef_empty_module', &
& '#endif', &
& '#ifdef UNDEFINED_MACRO', &
& ' use ifdef_undefined_module', &
& '#endif', &
& '', &
& '! Test #if defined(MACRO) format (with parentheses)', &
& '#if defined(ZERO_MACRO)', &
& ' use defined_paren_zero_module', &
& '#endif', &
& '#if defined(UNDEFINED_MACRO)', &
& ' use defined_paren_undefined_module', &
& '#endif', &
& '#if !defined(UNDEFINED_MACRO)', &
& ' use not_defined_paren_module', &
& '#endif', &
& '', &
& '! Test #if defined MACRO format (without parentheses)', &
& '#if defined ONE_MACRO', &
& ' use defined_noparen_one_module', &
& '#endif', &
& '#if !defined UNDEFINED_MACRO', &
& ' use not_defined_noparen_module', &
& '#endif', &
& '', &
& '! Test #if MACRO == value format', &
& '#if ZERO_MACRO == 0', &
& ' use eq_zero_module', &
& '#endif', &
& '#if ONE_MACRO == 1', &
& ' use eq_one_module', &
& '#endif', &
& '#if NONZERO_MACRO == 42', &
& ' use eq_nonzero_module', &
& '#endif', &
& '#if ONE_MACRO != 0', &
& ' use neq_one_module', &
& '#endif', &
& '#if ZERO_MACRO != 1', &
& ' use neq_zero_module', &
& '#endif', &
& '', &
& 'program test', &
& ' implicit none', &
& 'end program test'
close(unit)
! Enable CPP but don't pass any external macros
call cpp_config%new([string_t::])
cpp_config%name = "cpp"
f_source = parse_f_source(temp_file, error, preprocess=cpp_config)
if (allocated(error)) return
! === #if MACRO tests ===
if ('if_zero_module' .in. f_source%modules_used) then
call test_failed(error, '#if MACRO: MACRO=0 should be false')
return
end if
if (.not.('if_one_module' .in. f_source%modules_used)) then
call test_failed(error, '#if MACRO: MACRO=1 should be true')
return
end if
if (.not.('if_nonzero_module' .in. f_source%modules_used)) then
call test_failed(error, '#if MACRO: MACRO=42 should be true')
return
end if
if ('if_empty_module' .in. f_source%modules_used) then
call test_failed(error, '#if MACRO: empty macro from #define should be false (CPP error)')
return
end if
if ('if_undefined_module' .in. f_source%modules_used) then
call test_failed(error, '#if MACRO: undefined should be false')
return
end if
! === #ifdef MACRO tests ===
if (.not.('ifdef_zero_module' .in. f_source%modules_used)) then
call test_failed(error, '#ifdef MACRO: MACRO=0 should be true (defined)')
return
end if
if (.not.('ifdef_one_module' .in. f_source%modules_used)) then
call test_failed(error, '#ifdef MACRO: MACRO=1 should be true')
return
end if
if (.not.('ifdef_empty_module' .in. f_source%modules_used)) then
call test_failed(error, '#ifdef MACRO: empty macro should be true')
return
end if
if ('ifdef_undefined_module' .in. f_source%modules_used) then
call test_failed(error, '#ifdef MACRO: undefined should be false')
return
end if
! === #if defined(MACRO) tests ===
if (.not.('defined_paren_zero_module' .in. f_source%modules_used)) then
call test_failed(error, '#if defined(MACRO): MACRO=0 should be true (defined)')
return
end if
if ('defined_paren_undefined_module' .in. f_source%modules_used) then
call test_failed(error, '#if defined(MACRO): undefined should be false')
return
end if
if (.not.('not_defined_paren_module' .in. f_source%modules_used)) then
call test_failed(error, '#if !defined(MACRO): undefined should be true')
return
end if
! === #if defined MACRO tests (no parentheses) ===
if (.not.('defined_noparen_one_module' .in. f_source%modules_used)) then
call test_failed(error, '#if defined MACRO: MACRO=1 should be true')
return
end if
if (.not.('not_defined_noparen_module' .in. f_source%modules_used)) then
call test_failed(error, '#if !defined MACRO: undefined should be true')
return
end if
! === #if MACRO == value tests ===
if (.not.('eq_zero_module' .in. f_source%modules_used)) then
call test_failed(error, '#if MACRO == 0: should be true when MACRO=0')
return
end if
if (.not.('eq_one_module' .in. f_source%modules_used)) then
call test_failed(error, '#if MACRO == 1: should be true when MACRO=1')
return
end if
if (.not.('eq_nonzero_module' .in. f_source%modules_used)) then
call test_failed(error, '#if MACRO == 42: should be true when MACRO=42')
return
end if
if (.not.('neq_one_module' .in. f_source%modules_used)) then
call test_failed(error, '#if MACRO != 0: should be true when MACRO=1')
return
end if
if (.not.('neq_zero_module' .in. f_source%modules_used)) then
call test_failed(error, '#if MACRO != 1: should be true when MACRO=0')
return
end if
end subroutine test_if_macro_truthy_from_define
end module test_source_parsing
fortran-lang-fpm-90bb83a/test/fpm_test/test_package_dependencies.f90 0000664 0001750 0001750 00000152241 15145116760 025755 0 ustar alastair alastair !> 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_filesystem, only: is_dir, join_path, filewrite, mkdir, os_delete_dir, exists
use fpm_environment, only: os_is_unix
use fpm_os, only: get_current_directory
use fpm_dependency
use fpm_manifest_dependency
use fpm_manifest_metapackages, only: metapackage_config_t
use fpm_manifest, only: package_config_t, get_package_data
use tomlf, only: toml_table, new_table
use fpm_toml, only: toml_key, add_table, set_value, get_value
use fpm_settings, only: fpm_global_settings, get_registry_settings, get_global_settings
use fpm_downloader, only: downloader_t
use fpm_versioning, only: version_t
use jonquil, only: json_object, json_value, json_loads, cast_to_object
implicit none
private
public :: collect_package_dependencies
character(*), parameter :: tmp_folder = 'tmp'
character(*), parameter :: config_file_name = 'config.toml'
type, extends(dependency_tree_t) :: mock_dependency_tree_t
contains
procedure, private :: resolve_dependency => resolve_dependency_once
end type mock_dependency_tree_t
type, extends(downloader_t) :: mock_downloader_t
contains
procedure, nopass :: get_pkg_data, get_file, unpack => unpack_mock_package
end type mock_downloader_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), &
& new_unittest("update-dependencies", test_update_dependencies), &
& new_unittest("metapackage-override", test_metapackage_override), &
& new_unittest("do-not-update-dependencies", test_non_updated_dependencies), &
& new_unittest("registry-dir-not-found", registry_dir_not_found, should_fail=.true.), &
& new_unittest("no-versions-in-registry", no_versions_in_registry, should_fail=.true.), &
& new_unittest("local-registry-specified-version-not-found", local_registry_specified_version_not_found, should_fail=.true.), &
& new_unittest("local-registry-specified-no-manifest", local_registry_specified_no_manifest, should_fail=.true.), &
& new_unittest("local-registry-specified-has-manifest", local_registry_specified_has_manifest), &
& new_unittest("local-registry-specified-not-a-dir", local_registry_specified_not_a_dir, should_fail=.true.), &
& new_unittest("local-registry-unspecified-no-versions", local_registry_unspecified_no_versions, should_fail=.true.), &
& new_unittest("local-registry-unspecified-no-manifest", local_registry_unspecified_no_manifest, should_fail=.true.), &
& new_unittest("local-registry-unspecified-has-manifest", local_registry_unspecified_has_manifest), &
& new_unittest("cache-specified-version-found", cache_specified_version_found), &
& new_unittest("specified-version-not-found-in-cache", registry_specified_version_not_found_in_cache), &
& new_unittest("registry-specified-version-not-exists", registry_specified_version_not_exists, should_fail=.true.), &
& new_unittest("registry-specified-version-other-versions-exist", registry_specified_version_other_versions_exist), &
& new_unittest("registry-unspecified-version", registry_unspecified_version), &
& new_unittest("registry-unspecified-version_exists_in_cache", registry_unspecified_version_exists_in_cache), &
& new_unittest("pkg-data-no-code", pkg_data_no_code, should_fail=.true.), &
& new_unittest("pkg-data-corrupt-code", pkg_data_corrupt_code, should_fail=.true.), &
& new_unittest("pkg-data-missing-error-message", pkg_data_missing_error_msg, should_fail=.true.), &
& new_unittest("pkg-data-error-reading-message", pkg_data_error_reading_msg, should_fail=.true.), &
& new_unittest("pkg-data-error-has-message", pkg_data_error_has_msg, should_fail=.true.), &
& new_unittest("pkg-data-error-no-data", pkg_data_no_data, should_fail=.true.), &
& new_unittest("pkg-data-error-reading-data", pkg_data_error_reading_data, should_fail=.true.), &
& new_unittest("pkg-data-requested-version-wrong-key", pkg_data_requested_version_wrong_key, should_fail=.true.), &
& new_unittest("pkg-data-no-version-requested-wrong-key", pkg_data_no_version_requested_wrong_key, should_fail=.true.), &
& new_unittest("pkg-data-error-reading-latest-version", pkg_data_error_reading_latest_version, should_fail=.true.), &
& new_unittest("pkg-data-no-download-url", pkg_data_no_download_url, should_fail=.true.), &
& new_unittest("pkg-data-error-reading-donwload-url", pkg_data_error_reading_download_url, should_fail=.true.), &
& new_unittest("pkg-data-no-version", pkg_data_no_version, should_fail=.true.), &
& new_unittest("pkg-data-error-reading-version", pkg_data_error_reading_version, should_fail=.true.), &
& new_unittest("pkg-data-invalid-version", pkg_data_invalid_version, should_fail=.true.) &
& ]
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_cache(unit, error)
if (.not. allocated(error)) then
rewind (unit)
call new_dependency_tree(deps)
call resize(deps%dep, 2)
call deps%load_cache(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_cache(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_cache(table, error)
if (allocated(error)) return
call table%get_keys(list)
if (size(list) /= 4) then
call test_failed(error, "Expected four dependencies in dumped cache")
return
end if
end subroutine test_cache_load_dump
subroutine test_status(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(toml_table), pointer :: ptr
type(dependency_tree_t) :: deps
table = toml_table()
call add_table(table, "dep1", ptr)
call set_value(ptr, "version", "1.1.0")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
call add_table(table, "dep2", ptr)
call set_value(ptr, "version", "0.55.3")
call set_value(ptr, "proj-dir", "fpm-tmp2-dir")
call set_value(ptr, "git", "https://github.com/fortran-lang/dep2")
call new_dependency_tree(deps)
call deps%load_cache(table, error)
if (allocated(error)) return
if (deps%finished()) then
call test_failed(error, "Newly initialized dependency tree cannot be reolved")
return
end if
end subroutine test_status
subroutine test_add_dependencies(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(toml_table), pointer :: ptr
type(mock_dependency_tree_t) :: deps
type(dependency_config_t), allocatable :: nodes(:)
table = toml_table()
call add_table(table, "sub1", ptr)
call set_value(ptr, "path", "external")
call add_table(table, "lin2", ptr)
call set_value(ptr, "git", "https://github.com/fortran-lang/lin2")
call add_table(table, "pkg3", ptr)
call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3")
call set_value(ptr, "rev", "c0ffee")
call add_table(table, "proj4", ptr)
call set_value(ptr, "path", "vendor")
call new_dependencies(nodes, table, error=error)
if (allocated(error)) return
call new_dependencies(nodes, table, root='.', error=error)
if (allocated(error)) return
call new_dependency_tree(deps%dependency_tree_t)
call deps%add(nodes, error)
if (allocated(error)) return
if (deps%finished()) then
call test_failed(error, "Newly added nodes cannot be already resolved")
return
end if
if (deps%ndep /= 4) then
call test_failed(error, "Expected for dependencies in tree")
return
end if
! Do not use polymorphic version due to Ifort issue
call resolve_dependencies(deps, ".", 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
subroutine test_non_updated_dependencies(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: cache, manifest
type(toml_table), pointer :: ptr
type(toml_key), allocatable :: list(:)
type(dependency_tree_t) :: cached, manifest_deps
integer :: ii
! Create a dummy cache
cache = toml_table()
call add_table(cache, "dep1", ptr)
call set_value(ptr, "version", "1.1.0")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
call add_table(cache, "dep2", ptr)
call set_value(ptr, "git", "https://gitlab.com/fortran-lang/lin2")
call set_value(ptr, "rev", "c0ffee")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
call add_table(cache, "dep3", ptr)
call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3")
call set_value(ptr, "rev", "t4a")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
call add_table(cache, "dep4", ptr)
call set_value(ptr, "version", "1.0.0")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
! Load into a dependency tree
call new_dependency_tree(cached)
call cached%load_cache(cache, error)
if (allocated(error)) return
! Mark all dependencies as "cached"
do ii=1,cached%ndep
cached%dep(ii)%cached = .true.
end do
call cache%destroy()
! Create a dummy manifest, with different version
manifest = toml_table()
call add_table(manifest, "dep1", ptr)
call set_value(ptr, "version", "1.1.1")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
call add_table(manifest, "dep2", ptr)
call set_value(ptr, "git", "https://gitlab.com/fortran-lang/lin4")
call set_value(ptr, "rev", "c0ffee")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
call add_table(manifest, "dep3", ptr)
call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3")
call set_value(ptr, "rev", "t4a")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
! Load dependencies from manifest
call new_dependency_tree(manifest_deps)
call manifest_deps%load_cache(manifest, error)
call manifest%destroy()
if (allocated(error)) return
! Add cached dependencies afterwards; will flag those that need udpate
do ii=1,cached%ndep
cached%dep(ii)%cached = .true.
call manifest_deps%add(cached%dep(ii), error)
if (allocated(error)) return
end do
! Test that dependencies 1-2 are flagged as "update"
if (.not. manifest_deps%dep(1)%update) then
call test_failed(error, "Updated dependency (different version) not detected")
return
end if
if (.not. manifest_deps%dep(2)%update) then
call test_failed(error, "Updated dependency (git address) not detected")
return
end if
! Test that dependency 3 is flagged as "not update"
if (manifest_deps%dep(3)%update) then
call test_failed(error, "Updated dependency (git rev) detected, should not be")
return
end if
end subroutine test_non_updated_dependencies
subroutine test_update_dependencies(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: cache, manifest
type(toml_table), pointer :: ptr
type(toml_key), allocatable :: list(:)
type(dependency_tree_t) :: cached, manifest_deps
integer :: ii
! Create a dummy cache
cache = toml_table()
call add_table(cache, "dep1", ptr)
call set_value(ptr, "version", "1.1.0")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
call add_table(cache, "dep2", ptr)
call set_value(ptr, "git", "https://gitlab.com/fortran-lang/lin2")
call set_value(ptr, "rev", "c0ffee")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
call add_table(cache, "dep3", ptr)
call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3")
call set_value(ptr, "rev", "t4a")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
call add_table(cache, "dep4", ptr)
call set_value(ptr, "version", "1.0.0")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
! Load into a dependency tree
call new_dependency_tree(cached)
call cached%load_cache(cache, error)
if (allocated(error)) return
! Mark all dependencies as "cached"
do ii=1,cached%ndep
cached%dep(ii)%cached = .true.
end do
call cache%destroy()
! Create a dummy manifest, with different version
manifest = toml_table()
call add_table(manifest, "dep1", ptr)
call set_value(ptr, "version", "1.1.1")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
call add_table(manifest, "dep2", ptr)
call set_value(ptr, "git", "https://gitlab.com/fortran-lang/lin4")
call set_value(ptr, "rev", "c0ffee")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
call add_table(manifest, "dep3", ptr)
call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3")
call set_value(ptr, "rev", "l4tte")
call set_value(ptr, "proj-dir", "fpm-tmp1-dir")
! Load dependencies from manifest
call new_dependency_tree(manifest_deps)
call manifest_deps%load_cache(manifest, error)
call manifest%destroy()
if (allocated(error)) return
! Add cached dependencies afterwards; will flag those that need udpate
do ii=1,cached%ndep
cached%dep(ii)%cached = .true.
call manifest_deps%add(cached%dep(ii), error)
if (allocated(error)) return
end do
! Test that all dependencies are flagged as "update"
if (.not. manifest_deps%dep(1)%update) then
call test_failed(error, "Updated dependency (different version) not detected")
return
end if
if (.not. manifest_deps%dep(2)%update) then
call test_failed(error, "Updated dependency (git address) not detected")
return
end if
if (.not. manifest_deps%dep(3)%update) then
call test_failed(error, "Updated dependency (git rev) not detected")
return
end if
end subroutine test_update_dependencies
!> Test that a metapackage is overridden if a regular dependency is provided
subroutine test_metapackage_override(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: manifest
type(toml_table), pointer :: ptr
type(dependency_config_t), allocatable :: deps(:)
type(metapackage_config_t) :: meta
logical :: found
integer :: i
! Create a dummy manifest, with a standard git dependency for stdlib
manifest = toml_table()
call add_table(manifest, "stdlib", ptr)
call set_value(ptr, "git", "https://github.com/fortran-lang/stdlib")
call set_value(ptr, "branch", "stdlib-fpm")
! Load dependencies from manifest
call new_dependencies(deps, manifest, meta=meta, error=error)
if (allocated(error)) return
! Check that stdlib is in the regular dependency list
found = .false.
do i=1,size(deps)
if (deps(i)%name=="stdlib") found = .true.
end do
if (.not.found) then
call test_failed(error,"standard git-based dependency for stdlib not recognized")
return
end if
call manifest%destroy()
! Create a dummy manifest, with a version-based metapackage dependency for stdlib
manifest = toml_table()
call set_value(manifest, "stdlib", "*")
! Load dependencies from manifest
call new_dependencies(deps, manifest, meta=meta, error=error)
if (allocated(error)) return
! Check that stdlib is in the metapackage config and not the standard dependencies
found = .false.
do i=1,size(deps)
if (deps(i)%name=="stdlib") found = .true.
end do
if (found) then
call test_failed(error,"metapackage dependency for stdlib should not be in the tree")
return
end if
call manifest%destroy()
if (.not.meta%stdlib%on) then
call test_failed(error,"metapackage dependency for stdlib should be in the metapackage config")
return
end if
end subroutine test_metapackage_override
!> Directories for namespace and package name not found in path registry.
subroutine registry_dir_not_found(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir
type(toml_table), pointer :: child
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'cache')) ! Missing directories for namesapce and package name
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', 'cache')
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine registry_dir_not_found
!> No versions found in path registry.
subroutine no_versions_in_registry(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir
type(toml_table), pointer :: child
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep'))
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', 'cache')
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine no_versions_in_registry
!> Specific version not found in the local registry.
subroutine local_registry_specified_version_not_found(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir
type(toml_table), pointer :: child
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call set_value(table, 'v', '0.1.0')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.0.9'))
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.1'))
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', 'cache')
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine local_registry_specified_version_not_found
!> Target package in path registry does not contain manifest.
subroutine local_registry_specified_no_manifest(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir
type(toml_table), pointer :: child
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call set_value(table, 'v', '0.1.0')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.0.9'))
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0'))
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.1'))
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', 'cache')
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine local_registry_specified_no_manifest
!> Target package in path registry contains manifest.
subroutine local_registry_specified_has_manifest(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir, cwd
type(toml_table), pointer :: child
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call set_value(table, 'v', '0.1.0')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.0.0'))
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0'))
call filewrite(join_path(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0'), 'fpm.toml'), [''])
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.2.0'))
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', 'cache')
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_current_directory(cwd, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
if (target_dir /= join_path(cwd, join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0'))) then
call test_failed(error, 'target_dir not set correctly')
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine local_registry_specified_has_manifest
!> Target is a file, not a directory.
subroutine local_registry_specified_not_a_dir(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir
type(toml_table), pointer :: child
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep'))
call filewrite(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0'), ['']) ! File, not directory
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', 'cache')
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine local_registry_specified_not_a_dir
!> Try fetching the latest version in the local registry, but none are found.
!> Compared to no-versions-in-registry, we aren't requesting a specific version here.
subroutine local_registry_unspecified_no_versions(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir
type(toml_table), pointer :: child
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep'))
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', 'cache')
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine local_registry_unspecified_no_versions
!> Latest version in the local registry does not have a manifest.
subroutine local_registry_unspecified_no_manifest(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir, cwd
type(toml_table), pointer :: child
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.0.0'))
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.3.0'))
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.2.1'))
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', 'cache')
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_current_directory(cwd, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
if (target_dir /= join_path(cwd, join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.3.0'))) then
call test_failed(error, 'target_dir not set correctly: '//target_dir//"'")
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine local_registry_unspecified_no_manifest
!> Latest version in the local registry has a manifest.
subroutine local_registry_unspecified_has_manifest(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir, cwd
type(toml_table), pointer :: child
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.0.0'))
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.3.0'))
call filewrite(join_path(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.3.0'), 'fpm.toml'), [''])
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.2.1'))
call new_table(table)
call add_table(table, 'registry', child)
call set_value(child, 'path', 'cache')
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_current_directory(cwd, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
if (target_dir /= join_path(cwd, join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.3.0'))) then
call test_failed(error, 'target_dir not set correctly: '//target_dir//"'")
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine local_registry_unspecified_has_manifest
!> Version specified in manifest, version found in cache.
subroutine cache_specified_version_found(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir, cwd, path
type(toml_table), pointer :: child
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call set_value(table, 'v', '2.3.0')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
path = join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '2.3.0')
call mkdir(path)
call filewrite(join_path(path, 'fpm.toml'), [''])
call new_table(table)
call add_table(table, 'registry', child) ! No cache_path specified, use default
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_current_directory(cwd, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
if (target_dir /= join_path(cwd, join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '2.3.0'))) then
call test_failed(error, "Target directory not set correctly: '"//target_dir//"'")
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine cache_specified_version_found
!> Version specified in manifest, but not found in cache. Therefore download dependency.
subroutine registry_specified_version_not_found_in_cache(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir, cwd
type(toml_table), pointer :: child
type(mock_downloader_t) :: mock_downloader
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call set_value(table, 'v', '0.1.0')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(tmp_folder) ! Dependencies folder doesn't exist
call new_table(table)
call add_table(table, 'registry', child)
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error, mock_downloader)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_current_directory(cwd, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
if (target_dir /= join_path(cwd, join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '0.1.0'))) then
call test_failed(error, "Target directory not set correctly: '"//target_dir//"'")
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine registry_specified_version_not_found_in_cache
!> Version specified in manifest, but not found in cache or registry.
subroutine registry_specified_version_not_exists(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir
type(toml_table), pointer :: child
type(mock_downloader_t) :: mock_downloader
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call set_value(table, 'v', '9.9.9')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(tmp_folder)
call new_table(table)
call add_table(table, 'registry', child)
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error, mock_downloader)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine registry_specified_version_not_exists
subroutine registry_specified_version_other_versions_exist(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir
type(toml_table), pointer :: child
type(mock_downloader_t) :: mock_downloader
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call set_value(table, 'v', '0.1.0')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '2.1.0'))
call mkdir(join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '9.1.0'))
call new_table(table)
call add_table(table, 'registry', child)
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error, mock_downloader)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine registry_specified_version_other_versions_exist
!> No version specified, get the newest version from the registry.
subroutine registry_unspecified_version(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir, cwd
type(toml_table), pointer :: child
type(mock_downloader_t) :: mock_downloader
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(tmp_folder)
call new_table(table)
call add_table(table, 'registry', child)
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error, mock_downloader)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_current_directory(cwd, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
if (target_dir /= join_path(cwd, join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '0.1.0'))) then
call test_failed(error, "Target directory not set correctly: '"//target_dir//"'")
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine registry_unspecified_version
!> No version specified, therefore load package data from the registry. Find out that there is a cached version of
!> the latest package.
subroutine registry_unspecified_version_exists_in_cache(error)
type(error_t), allocatable, intent(out) :: error
type(toml_table) :: table
type(dependency_node_t) :: node
type(fpm_global_settings) :: global_settings
character(len=:), allocatable :: target_dir, cwd
type(toml_table), pointer :: child
type(mock_downloader_t) :: mock_downloader
call new_table(table)
table%key = 'test-dep'
call set_value(table, 'namespace', 'test-org')
call new_dependency(node%dependency_config_t, table, error=error)
if (allocated(error)) return
call delete_tmp_folder
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.0.0'))
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0'))
call filewrite(join_path(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0'), 'fpm.toml'), [''])
call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.2.1'))
call new_table(table)
call add_table(table, 'registry', child)
call setup_global_settings(global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_registry_settings(child, global_settings, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call node%get_from_registry(target_dir, global_settings, error, mock_downloader)
if (allocated(error)) then
call delete_tmp_folder; return
end if
call get_current_directory(cwd, error)
if (allocated(error)) then
call delete_tmp_folder; return
end if
if (target_dir /= join_path(cwd, join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '0.1.0'))) then
call test_failed(error, "Target directory not set correctly: '"//target_dir//"'")
call delete_tmp_folder; return
end if
call delete_tmp_folder
end subroutine registry_unspecified_version_exists_in_cache
!> Package data returned from the registry does not contain a code field.
subroutine pkg_data_no_code(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{}')
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_no_code
!> Error reading status code from package data.
subroutine pkg_data_corrupt_code(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{"code": "integer expected"}')
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_corrupt_code
subroutine pkg_data_missing_error_msg(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{"code": 123}')
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_missing_error_msg
subroutine pkg_data_error_reading_msg(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{"code": 123, "message": 123}')
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_error_reading_msg
subroutine pkg_data_error_has_msg(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{"code": 123, "message": "Really bad error message"}')
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_error_has_msg
subroutine pkg_data_no_data(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{"code": 200}')
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_no_data
subroutine pkg_data_error_reading_data(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{"code": 200, "data": 123}')
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_error_reading_data
subroutine pkg_data_requested_version_wrong_key(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
allocate (node%requested_version)
call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": 123}}') ! Expected key: "version_data"
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_requested_version_wrong_key
subroutine pkg_data_no_version_requested_wrong_key(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{"code": 200, "data": {"version_data": 123}}') ! Expected key: "latest_version_data"
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_no_version_requested_wrong_key
subroutine pkg_data_error_reading_latest_version(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": 123}}')
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_error_reading_latest_version
subroutine pkg_data_no_download_url(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": {}}}')
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_no_download_url
subroutine pkg_data_error_reading_download_url(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": {"download_url": 123}}}')
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_error_reading_download_url
subroutine pkg_data_no_version(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": {"download_url": "abc"}}}')
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_no_version
subroutine pkg_data_error_reading_version(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": {"download_url": "abc", "version": 123}}}')
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_error_reading_version
subroutine pkg_data_invalid_version(error)
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: node
character(:), allocatable :: url
type(version_t) :: version
type(json_object) :: json
class(json_value), allocatable :: j_value
call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": {"download_url": "abc", "version": "abc"}}}')
json = cast_to_object(j_value)
call check_and_read_pkg_data(json, node, url, version, error)
end subroutine pkg_data_invalid_version
!> Resolve a single dependency node
subroutine resolve_dependency_once(self, dependency, global_settings, 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
!> Global configuration settings.
type(fpm_global_settings), intent(in) :: global_settings
!> Current installation prefix
character(len=*), intent(in) :: root
!> Error handling
type(error_t), allocatable, intent(out) :: error
if (dependency%done) then
call test_failed(error, "Should only visit this node once")
return
end if
dependency%done = .true.
end subroutine resolve_dependency_once
!> Resolve all dependencies in the tree
subroutine resolve_dependencies(self, root, error)
!> Instance of the dependency tree
type(mock_dependency_tree_t), intent(inout) :: self
!> Current installation prefix
character(len=*), intent(in) :: root
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(fpm_global_settings) :: global_settings
integer :: ii
call get_global_settings(global_settings, error)
if (allocated(error)) return
do ii = 1, self%ndep
call resolve_dependency_once(self, self%dep(ii), global_settings, root, error)
if (allocated(error)) exit
end do
if (allocated(error)) return
end subroutine resolve_dependencies
subroutine delete_tmp_folder
if (is_dir(tmp_folder)) call os_delete_dir(os_is_unix(), tmp_folder)
end
subroutine setup_global_settings(global_settings, error)
type(fpm_global_settings), intent(out) :: global_settings
type(error_t), allocatable, intent(out) :: error
character(:), allocatable :: cwd
call get_current_directory(cwd, error)
if (allocated(error)) return
global_settings%path_to_config_folder = join_path(cwd, tmp_folder)
global_settings%config_file_name = config_file_name
end
subroutine get_pkg_data(url, version, tmp_pkg_file, json, error)
character(*), intent(in) :: url
type(version_t), allocatable, intent(in) :: version
character(*), intent(in) :: tmp_pkg_file
type(json_object), intent(out) :: json
type(error_t), allocatable, intent(out) :: error
class(json_value), allocatable :: j_value
if (allocated(version)) then
if (version%s() == '9.9.9') then
call json_loads(j_value, '{"code": 404, "message": "Package not found"}')
else
call json_loads(j_value, '{"code": 200, "data": {"version_data": {"version": "0.1.0", "download_url": "abc"}}}')
end if
else
call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": {"version": "0.1.0", "download_url": "abc"}}}')
end if
json = cast_to_object(j_value)
end
subroutine get_file(url, tmp_pkg_file, error)
character(*), intent(in) :: url
character(*), intent(in) :: tmp_pkg_file
type(error_t), allocatable, intent(out) :: error
end
subroutine unpack_mock_package(tmp_pkg_file, destination, error)
character(*), intent(in) :: tmp_pkg_file
character(*), intent(in) :: destination
type(error_t), allocatable, intent(out) :: error
integer :: stat
call execute_command_line('cp '//tmp_pkg_file//' '//destination, exitstat=stat)
if (stat /= 0) then
call test_failed(error, "Failed to create mock package"); return
end if
end
end module test_package_dependencies
fortran-lang-fpm-90bb83a/test/fpm_test/test_backend.f90 0000664 0001750 0001750 00000037753 15145116760 023255 0 ustar alastair alastair !> 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, FPM_TARGET_SHARED, &
add_target, add_dependency
use fpm_backend, only: sort_target, schedule_targets
use fpm_strings, only: string_t
use fpm_environment, only: OS_LINUX
use fpm_compile_commands, only: compile_command_t, compile_command_table_t
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("target-shared-sort", test_target_shared), &
& new_unittest("schedule-targets", test_schedule_targets), &
& new_unittest("schedule-targets-empty", test_schedule_empty), &
& new_unittest("serialize-compile-commands", compile_commands_roundtrip), &
& new_unittest("compile-commands-write", compile_commands_register_from_cmd), &
& new_unittest("compile-commands-register-string", compile_commands_register_from_string) &
]
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(:)
integer :: i
call add_target(targets,'test-package',FPM_TARGET_ARCHIVE,get_temp_filename())
call add_target(targets,'test-package',FPM_TARGET_OBJECT,get_temp_filename())
call add_target(targets,'test-package',FPM_TARGET_OBJECT,get_temp_filename())
call add_target(targets,'test-package',FPM_TARGET_OBJECT,get_temp_filename())
! 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
subroutine compile_commands_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(compile_command_t) :: cmd
type(compile_command_table_t) :: cc
integer :: i
call cmd%test_serialization('compile_command: empty', error)
if (allocated(error)) return
cmd = compile_command_t(directory = string_t("/test/dir"), &
arguments = [string_t("gfortran"), &
string_t("-c"), string_t("main.f90"), &
string_t("-o"), string_t("main.o")], &
file = string_t("main.f90"))
call cmd%test_serialization('compile_command: non-empty', error)
if (allocated(error)) return
call cc%test_serialization('compile_command_table: empty', error)
if (allocated(error)) return
do i=1,10
call cc%register(cmd,error)
if (allocated(error)) return
end do
call cc%test_serialization('compile_command_table: non-empty', error)
if (allocated(error)) return
end subroutine compile_commands_roundtrip
subroutine compile_commands_register_from_cmd(error)
type(error_t), allocatable, intent(out) :: error
type(compile_command_table_t) :: table
type(compile_command_t) :: cmd
integer :: i
cmd = compile_command_t(directory = string_t("/src"), &
arguments = [string_t("gfortran"), &
string_t("-c"), string_t("example.f90"), &
string_t("-o"), string_t("example.o")], &
file = string_t("example.f90"))
call table%register(cmd, error)
if (allocated(error)) return
if (.not.allocated(table%command)) then
call test_failed(error, "Command table not allocated after registration")
return
endif
if (size(table%command) /= 1) then
call test_failed(error, "Expected one registered command")
return
endif
if (table%command(1)%file%s /= "example.f90") then
call test_failed(error, "Registered file mismatch")
return
endif
end subroutine compile_commands_register_from_cmd
subroutine compile_commands_register_from_string(error)
type(error_t), allocatable, intent(out) :: error
type(compile_command_table_t) :: table
character(len=*), parameter :: cmd_line = "gfortran -c example.f90 -o example.o"
! Register a raw command line string
call table%register(cmd_line, OS_LINUX, error)
if (allocated(error)) return
if (.not.allocated(table%command)) then
call test_failed(error, "Command table not allocated after string registration")
return
end if
if (size(table%command) /= 1) then
call test_failed(error, "Expected one registered command after string registration")
return
end if
if (.not.allocated(table%command(1)%arguments)) then
call test_failed(error, "Command arguments not allocated")
return
end if
if (size(table%command(1)%arguments) /= 5) then
call test_failed(error, "Wrong number of parsed arguments, should be 5")
return
end if
if (table%command(1)%arguments(1)%s /= "gfortran") then
call test_failed(error, "Expected 'gfortran' as first argument")
return
end if
if (table%command(1)%arguments(3)%s /= "example.f90") then
call test_failed(error, "Expected 'example.f90' as third argument")
return
end if
end subroutine compile_commands_register_from_string
!> Check sorting and scheduling for shared library targets
subroutine test_target_shared(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(build_target_ptr), allocatable :: targets(:)
integer :: i
! Create a new test package with a shared library
call add_target(targets, 'test-shared', FPM_TARGET_SHARED, get_temp_filename())
call add_target(targets, 'test-shared', FPM_TARGET_OBJECT, get_temp_filename())
call add_target(targets, 'test-shared', FPM_TARGET_OBJECT, get_temp_filename())
! Shared library depends on the two object files
call add_dependency(targets(1)%ptr, targets(2)%ptr)
call add_dependency(targets(1)%ptr, targets(3)%ptr)
! Perform topological sort
do i = 1, size(targets)
call sort_target(targets(i)%ptr)
end do
! Check scheduling and flags
do i = 1, size(targets)
if (.not.targets(i)%ptr%touched) then
call test_failed(error, "Shared: Target not touched")
return
end if
if (.not.targets(i)%ptr%sorted) then
call test_failed(error, "Shared: Target not sorted")
return
end if
if (targets(i)%ptr%skip) then
call test_failed(error, "Shared: Target incorrectly skipped")
return
end if
end do
! Check dependencies scheduled before the shared lib
if (targets(2)%ptr%schedule >= targets(1)%ptr%schedule) then
call test_failed(error, "Shared: Object 2 scheduled after shared lib")
return
end if
if (targets(3)%ptr%schedule >= targets(1)%ptr%schedule) then
call test_failed(error, "Shared: Object 3 scheduled after shared lib")
return
end if
end subroutine test_target_shared
end module test_backend
fortran-lang-fpm-90bb83a/test/fpm_test/main.f90 0000664 0001750 0001750 00000007726 15145116760 021550 0 ustar alastair alastair !> 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_compiler, only : collect_compiler
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
use test_settings, only : collect_settings
use test_os, only: collect_os
use test_features, only : collect_features
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_features", collect_features), &
& 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), &
& new_testsuite("fpm_settings", collect_settings), &
& new_testsuite("fpm_os", collect_os), &
& new_testsuite("fpm_compiler", collect_compiler) &
& ]
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, arg_stat
call get_command_argument(idx, length=length, status=arg_stat)
if (arg_stat /= 0) then
return
endif
allocate(character(len=length) :: arg, stat=arg_stat)
if (arg_stat /= 0) then
return
endif
if (length > 0) then
call get_command_argument(idx, arg, status=arg_stat)
if (arg_stat /= 0) then
deallocate(arg)
return
end if
end if
end subroutine get_argument
end program fpm_testing
fortran-lang-fpm-90bb83a/test/fpm_test/test_os.f90 0000664 0001750 0001750 00000025345 15145116760 022301 0 ustar alastair alastair module test_os
use testsuite, only: new_unittest, unittest_t, error_t, test_failed
use fpm_filesystem, only: join_path, mkdir, os_delete_dir, is_dir, get_local_prefix, get_home
use fpm_environment, only: os_is_unix, get_env, set_env, delete_env
use fpm_os, only: get_absolute_path, get_absolute_path_by_cd, get_current_directory
implicit none
private
public :: collect_os
character(len=*), parameter :: tmp_folder = 'tmp'
contains
!> Collect unit tests.
subroutine collect_os(tests)
!> Unit tests to collect.
type(unittest_t), allocatable, intent(out) :: tests(:)
tests = [ &
& new_unittest('empty-path', empty_path, should_fail=.true.), &
& new_unittest('only-tilde', only_tilde), &
& new_unittest('set-environment-variable', set_environment), &
& new_unittest('invalid-tilde-path', invalid_tilde_path, should_fail=.true.), &
& new_unittest('tilde-correct-separator', tilde_correct_separator), &
& new_unittest('tilde-wrong-separator', tilde_wrong_separator, should_fail=.true.), &
& new_unittest('tilde-nonexistent-path', tilde_nonexistent_path, should_fail=.true.), &
& new_unittest('abs-path-nonexisting', abs_path_nonexisting, should_fail=.true.), &
& new_unittest('abs-path-root', abs_path_root), &
& new_unittest('abs-path-home', abs_path_home), &
& new_unittest('abs-path-cd-root', abs_path_home), &
& new_unittest('abs-path-cd-home', abs_path_cd_home), &
& new_unittest('abs-path-cd-current', abs_path_cd_current) &
]
end subroutine collect_os
subroutine delete_tmp_folder
if (is_dir(tmp_folder)) call os_delete_dir(os_is_unix(), tmp_folder)
end
subroutine empty_path(error)
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: result
call get_absolute_path('', result, error)
end
subroutine only_tilde(error)
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: result
character(len=:), allocatable :: home
call get_absolute_path('~', result, error)
if (allocated(error)) then
call test_failed(error, "Unexpected error resolving '~'")
return
end if
if (.not. allocated(result)) then
call test_failed(error, "Unexpected null result resolving '~'")
return
end if
call get_home(home, error)
if (allocated(error)) return
if (result /= home) then
call test_failed(error, "Result '"//result//"' doesn't equal home directory '"//home//"'")
return
end if
end subroutine
subroutine invalid_tilde_path(error)
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: result
call get_absolute_path('~a', result, error)
end
subroutine tilde_correct_separator(error)
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: result
character(len=:), allocatable :: separator
character(len=:), allocatable :: home
if (os_is_unix()) then
separator = '/'
else
separator = '\'
end if
call get_absolute_path('~'//separator, result, error)
if (allocated(error)) return
call get_home(home, error)
if (allocated(error)) return
if (result /= home) then
call test_failed(error, "Result '"//result//"' doesn't equal home directory '"//home//"'")
return
end if
end
subroutine tilde_wrong_separator(error)
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: result
character(len=:), allocatable :: separator
if (os_is_unix()) then
separator = '\'
else
separator = '/'
end if
call get_absolute_path('~'//separator, result, error)
end
!> Entering a non-existing path with ~ should fail.
subroutine tilde_nonexistent_path(error)
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: result
call get_absolute_path('~/abcde', result, error)
end
!> Entering a non-existing absolute path should fail.
subroutine abs_path_nonexisting(error)
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: result
call get_absolute_path('/abcde', result, error)
end
!> Get the absolute path of the root directory.
subroutine abs_path_root(error)
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: home_path, result
if (os_is_unix()) then
call get_absolute_path('/', result, error)
if (allocated(error)) return
if (result /= '/') then
call test_failed(error, "Result '"//result//"' doesn't equal input value: '/'"); return
end if
else
home_path = get_env('HOMEDRIVE','') //'\'
call get_absolute_path(home_path, result, error)
if (allocated(error)) return
if (result /= home_path) then
call test_failed(error, "Result '"//result//"' doesn't equal input value: '"//home_path//"'"); return
end if
end if
end
!> Get the absolute path of the home directory.
subroutine abs_path_home(error)
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: home, result
call get_home(home, error)
if (allocated(error)) return
call get_absolute_path(home, result, error)
if (allocated(error)) return
if (result /= home) then
call test_failed(error, "Result '"//result//"' doesn't equal home directory '"//home//"'"); return
end if
end
!> Get the absolute path of the root directory using `getcwd`/`_getcwd`.
subroutine abs_path_cd_root(error)
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: home_path, current_dir_before, current_dir_after, result
call get_current_directory(current_dir_before, error)
if (allocated(error)) return
if (os_is_unix()) then
call get_absolute_path_by_cd('/', result, error)
if (result /= '/') then
call test_failed(error, "Result '"//result//"' doesn't equal input value: '/'"); return
end if
else
home_path = get_env('HOMEDRIVE','')//'\'
call get_absolute_path_by_cd(home_path, result, error)
if (result /= home_path) then
call test_failed(error, "Result '"//result//"' doesn't equal input value: '"//home_path//"'"); return
end if
end if
call get_current_directory(current_dir_after, error)
if (allocated(error)) return
if (current_dir_before /= current_dir_after) then
call test_failed(error, "Current directory before getting absolute path '"//current_dir_before// &
& "' doesn't equal current directory after getting absolute path '"//current_dir_after//"'."); return
end if
end
!> Get the absolute path of the root directory using `getcwd`/`_getcwd`.
subroutine abs_path_cd_home(error)
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: home, current_dir_before, current_dir_after, result
call get_current_directory(current_dir_before, error)
if (allocated(error)) return
call get_home(home, error)
if (allocated(error)) return
call get_absolute_path_by_cd(home, result, error)
if (allocated(error)) return
call get_current_directory(current_dir_after, error)
if (allocated(error)) return
if (current_dir_before /= current_dir_after) then
call test_failed(error, "Current directory before getting absolute path '"//current_dir_before// &
& "' doesn't equal current directory after getting absolute path '"//current_dir_after//"'."); return
end if
if (result /= home) then
call test_failed(error, "Result '"//result//"' doesn't equal home directory '"//home//"'"); return
end if
end
!> Get the absolute path of the current directory using `getcwd`/`_getcwd`.
subroutine abs_path_cd_current(error)
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: current_dir, result
call get_current_directory(current_dir, error)
if (allocated(error)) return
call get_absolute_path_by_cd('.', result, error)
if (allocated(error)) return
if (result /= current_dir) then
call test_failed(error, "Result '"//result//"' doesn't equal current directory '"//current_dir//"'"); return
end if
end
!> Test creation and deletion of an environment variable
subroutine set_environment(error)
type(error_t), allocatable, intent(out) :: error
character(*), parameter :: vname = 'hiufewhiugw'
character(*), parameter :: vvalue = '1234567890'
character(:), allocatable :: old_value,new_value,final_value
logical :: success
!> Ensure there's no such variable
old_value = get_env(vname,default='ERROR')
if (old_value/='ERROR') then
call test_failed(error, "There is already an env variable named "//vname)
return
end if
!> Create variable
success = set_env(vname,value=vvalue)
if (.not.success) then
call test_failed(error, "Cannot create environment variable "//vname)
return
end if
!> Check new value
new_value = get_env(vname,default='ERROR')
if (new_value/=vvalue) then
call test_failed(error, "Env "//vname//"="//new_value//'; expected '//vvalue)
return
end if
!> Delete variable
success = delete_env(vname)
if (.not.success) then
call test_failed(error, "Cannot delete environment variable "//vname)
return
end if
!> Ensure it does not exist anymore
!> Do not test this on Windows: due to a Windows bug, environment variables do not get deleted
!> https://developercommunity.visualstudio.com/t/-putenv-sname-doesnt-always-delete-windows-copy-of/1587426
if (os_is_unix()) then
final_value = get_env(vname,default='ERROR')
if (final_value/='ERROR') then
call test_failed(error, "Env "//vname//"="//final_value//'; it should not exist.')
return
end if
endif
end subroutine set_environment
end module test_os
fortran-lang-fpm-90bb83a/test/fpm_test/test_filesystem.f90 0000664 0001750 0001750 00000035430 15145116760 024040 0 ustar alastair alastair module test_filesystem
use testsuite, only: new_unittest, unittest_t, error_t, test_failed
use fpm_filesystem, only: canon_path, is_dir, mkdir, os_delete_dir, &
join_path, is_absolute_path, get_home, &
delete_file, read_lines, get_temp_filename
use fpm_environment, only: OS_WINDOWS, get_os_type, os_is_unix
use fpm_strings, only: string_t, split_lines_first_last
implicit none
private
public :: collect_filesystem
contains
!> Collect all exported unit tests
subroutine collect_filesystem(tests)
!> Collection of tests
type(unittest_t), allocatable, intent(out) :: tests(:)
tests = [ &
& new_unittest("canon-path", test_canon_path), &
& new_unittest("create-delete-directory", test_mkdir_rmdir), &
& new_unittest("test-is-absolute-path", test_is_absolute_path), &
& new_unittest("test-get-home", test_get_home), &
& new_unittest("test-split-lines-first-last", test_split_lines_first_last), &
& new_unittest("test-crlf-lines", test_dir_with_crlf) &
]
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 mismatch "// &
"expected '"//expected//"' but got '"//actual//"'")
end if
end subroutine check_string
subroutine test_mkdir_rmdir(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
call check_mkdir(error, join_path("tmpdir", "subdir"))
if (allocated(error)) return
call check_rmdir(error, "tmpdir")
if (allocated(error)) return
end subroutine test_mkdir_rmdir
!> Create a directory and verify its existence
subroutine check_mkdir(error, path)
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Directory path
character(len=*), intent(in) :: path
! Directory shouldn't exist before it's created
if (is_dir(path)) then
call test_failed(error, &
"Directory path "//path//" already exists before its creation")
return
end if
! Create directory
call mkdir(path)
! Check that directory is indeed created
if (.not. is_dir(path)) then
call test_failed(error, &
"Directory path "//path//" cannot be created")
end if
end subroutine check_mkdir
!> Create a directory and verify its existence
subroutine check_rmdir(error, path)
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Directory path
character(len=*), intent(in) :: path
! Directory should exist before it's deleted
if (.not. is_dir(path)) then
call test_failed(error, &
"Directory path "//path//" doesn't exist before its deletion")
return
end if
! Delete directory
call os_delete_dir(os_is_unix(), path)
! Check that directory is indeed deleted
if (is_dir(path)) then
call test_failed(error, &
"Directory path "//path//" cannot be deleted")
end if
end subroutine check_rmdir
subroutine test_is_absolute_path(error)
type(error_t), allocatable, intent(out) :: error
! Unix tests
if (is_absolute_path('.', is_unix=.true.)) then
call test_failed(error, "Path '.' isn't absolute")
return
end if
if (is_absolute_path('abc', is_unix=.true.)) then
call test_failed(error, "Path 'abc' isn't absolute")
return
end if
if (is_absolute_path('~a', is_unix=.true.)) then
call test_failed(error, "Path '~a' isn't absolute")
return
end if
if (is_absolute_path('C:', is_unix=.true.)) then
call test_failed(error, "Path 'C:' isn't absolute on Unix")
return
end if
if (is_absolute_path('~', is_unix=.true.)) then
call test_failed(error, "Path '~' isn't absolute")
return
end if
if (is_absolute_path('~/', is_unix=.true.)) then
call test_failed(error, "Path '~/' isn't absolute")
return
end if
if (.not. is_absolute_path('/', is_unix=.true.)) then
call test_failed(error, "Path '/' is absolute")
return
end if
if (.not. is_absolute_path('/a', is_unix=.true.)) then
call test_failed(error, "Path '/a' is absolute")
return
end if
! Windows tests
if (is_absolute_path('abc', is_unix=.false.)) then
call test_failed(error, "Path 'abc' isn't absolute")
return
end if
if (is_absolute_path('..', is_unix=.false.)) then
call test_failed(error, "Path '..' isn't absolute")
return
end if
if (is_absolute_path('~', is_unix=.false.)) then
call test_failed(error, "Path '~' isn't absolute")
return
end if
if (is_absolute_path('/', is_unix=.false.)) then
call test_failed(error, "Path '/' isn't absolute on Windows")
return
end if
if (is_absolute_path('c/', is_unix=.false.)) then
call test_failed(error, "Path 'c/' isn't absolute")
return
end if
if (is_absolute_path('1:', is_unix=.false.)) then
call test_failed(error, "Path '1:' isn't absolute")
return
end if
if (is_absolute_path('C', is_unix=.false.)) then
call test_failed(error, "Path 'C' isn't absolute")
return
end if
if (.not. is_absolute_path('C:', is_unix=.false.)) then
call test_failed(error, "Path 'C:' is absolute")
return
end if
if (.not. is_absolute_path('x:', is_unix=.false.)) then
call test_failed(error, "Path 'x:' is absolute")
return
end if
if (.not. is_absolute_path('x:xyz', is_unix=.false.)) then
call test_failed(error, "Path 'x:xyz' is absolute")
return
end if
end subroutine test_is_absolute_path
subroutine test_get_home(error)
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: home
character(len=*), parameter :: letters = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
call get_home(home, error)
if (allocated(error)) return
if (os_is_unix()) then
if (home(1:1) /= '/') then
call test_failed(error, "This doesn't seem to be the correct home path: '"//home//"'")
return
end if
else
if (index(letters, home(1:1)) == 0 .or. home(2:2) /= ':') then
call test_failed(error, "This doesn't seem to be the correct home path: '"//home//"'")
return
end if
end if
end subroutine test_get_home
! Test line splitting on MS windows
subroutine test_split_lines_first_last(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
character, parameter :: CR = achar(13)
character, parameter :: LF = new_line('A')
character(*), parameter :: CRLF = CR//LF
integer, allocatable :: first(:), last(:)
call split_lines_first_last(CR//LF//'line1'//CR//'line2'//LF//'line3'//CR//LF//'hello', first, last)
if (.not.(all(first==[3,9,15,22]) .and. all(last==[7,13,19,26]))) then
call test_failed(error, "Test split_lines_first_last #1 failed")
return
end if
call split_lines_first_last('single_line', first, last)
if (.not.(all(first==[1]) .and. all(last==[11]))) then
call test_failed(error, "Test split_lines_first_last #2 failed")
return
end if
call split_lines_first_last(CR//LF//CR//LF//'test', first, last)
if (.not.(all(first == [5]) .and. all(last == [8]))) then
call test_failed(error, "Test split_lines_first_last #3 failed")
return
end if
call split_lines_first_last('a'//CR//'b'//LF//'c'//CR//LF//'d', first, last)
if (.not.(all(first == [1, 3, 5, 8]) .and. all(last == [1, 3, 5, 8]))) then
call test_failed(error, "Test split_lines_first_last #4 failed")
return
end if
call split_lines_first_last('', first, last)
if (.not.(size(first) == 0 .and. size(last) == 0)) then
call test_failed(error, "Test split_lines_first_last #5 failed")
return
end if
call split_lines_first_last('build.f90'//CRLF//&
'dependency.f90'//CRLF//&
'example.f90'//CRLF//&
'executable.f90'//CRLF//&
'fortran.f90'//CRLF, &
first, last)
if (.not.(all(first == [1,12,28,41,57]) .and. all(last == [9,25,38,54,67]))) then
call test_failed(error, "Test split_lines_first_last #6 failed")
return
end if
end subroutine test_split_lines_first_last
! On MS windows, directory listings are printed to files with CR//LF endings.
! Check that the lines can be properly read back from such files.
subroutine test_dir_with_crlf(error)
type(error_t), allocatable, intent(out) :: error
character, parameter :: CR = achar(13)
character, parameter :: LF = new_line('A')
character(*), parameter :: CRLF = CR//LF
character(*), parameter :: test_lines = 'build.f90'//CRLF//&
'dependency.f90'//CRLF//&
'example.f90'//CRLF//&
'executable.f90'//CRLF//&
'fortran.f90'//CRLF
type(string_t), allocatable :: lines(:)
character(len=:), allocatable :: temp_file
character(256) :: msg
integer :: unit, i, ios
temp_file = get_temp_filename()
open(newunit=unit,file=temp_file,access='stream',action='write',iostat=ios)
if (ios/=0) then
call test_failed(error, "cannot create temporary file")
return
end if
write(unit,iostat=ios) test_lines
if (ios/=0) then
call test_failed(error, "cannot write to temporary file")
return
end if
close(unit,iostat=ios)
if (ios/=0) then
call test_failed(error, "cannot close temporary file")
return
end if
lines = read_lines(temp_file)
if (.not.allocated(lines)) then
write(msg, 1) 'no output'
call test_failed(error, msg)
return
end if
if (size(lines)/=5) then
write(msg, 1) 'wrong number of lines: expected ',5,', actual ',size(lines)
call test_failed(error, msg)
return
end if
if (lines(1)%s/='build.f90') then
call test_failed(error, "Failed reading file with CRLF: at build.f90")
return
end if
if (lines(2)%s/='dependency.f90') then
call test_failed(error, "Failed reading file with CRLF: at dependency.f90")
return
end if
if (lines(3)%s/='example.f90') then
call test_failed(error, "Failed reading file with CRLF: at example.f90")
return
end if
if (lines(4)%s/='executable.f90') then
call test_failed(error, "Failed reading file with CRLF: at executable.f90")
return
end if
if (lines(5)%s/='fortran.f90') then
call test_failed(error, "Failed reading file with CRLF: at fortran.f90")
return
end if
call delete_file(temp_file)
1 format("Failed reading file with CRLF: ",a,:,i0,:,a,:,i0)
end subroutine test_dir_with_crlf
end module test_filesystem
fortran-lang-fpm-90bb83a/test/fpm_test/test_toml.f90 0000664 0001750 0001750 00000144357 15145116760 022640 0 ustar alastair alastair !> Define tests for the `fpm_toml` modules
module test_toml
use testsuite, only : new_unittest, unittest_t, error_t
use tomlf, only: toml_table, toml_load
use fpm_toml, only: read_package_file, toml_array, toml_key, toml_stat, &
get_value, set_value, get_list, new_table, add_table, add_array, len, &
toml_error, toml_serialize, check_keys, set_list, set_string, &
name_is_json
use tomlf_constants, only: tf_i8
use fpm_git, only: git_target_t, git_target_revision, git_target_branch, &
& git_target_tag
use fpm_dependency, only: dependency_node_t, destroy_dependency_node, dependency_tree_t, &
& new_dependency_node, new_dependency_tree, resize
use fpm_manifest_dependency, only: dependency_config_t, dependency_destroy
use fpm_manifest_install, only: install_config_t
use fpm_manifest_fortran, only: fortran_config_t
use fpm_manifest_library, only: library_config_t
use fpm_manifest_executable, only: executable_config_t
use fpm_manifest_preprocess, only: preprocess_config_t
use fpm_manifest_platform, only: platform_config_t
use fpm_manifest_metapackages, only: metapackage_config_t
use fpm_manifest_feature_collection, only: feature_collection_t
use fpm_manifest_profile, only: profile_config_t
use fpm_environment, only: OS_ALL, OS_LINUX, OS_MACOS
use fpm_versioning, only: new_version
use fpm_strings, only: string_t, operator(==), split
use fpm_model, only: fortran_config_t, package_t, FPM_SCOPE_LIB, FPM_UNIT_MODULE, fpm_model_t, &
& srcfile_t
use fpm_compiler, only: archiver_t, compiler_t, id_all, id_gcc
use fpm_error, only: fatal_error
implicit none
private
public :: collect_toml
character, parameter :: NL = new_line('a')
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.), &
& new_unittest("serialize-git-target", git_target_roundtrip), &
& new_unittest("serialize-git-invalid", git_target_invalid, should_fail=.true.), &
& new_unittest("serialize-dependency-config", dependency_config_roundtrip), &
& new_unittest("serialize-dependency-node", dependency_node_roundtrip), &
& new_unittest("serialize-dependency-invalid", dependency_node_invalid, should_fail=.true.), &
& new_unittest("serialize-dependency-invalid2", dependency_node_invalid_2, should_fail=.true.), &
& new_unittest("serialize-dependency-tree", dependency_tree_roundtrip), &
& new_unittest("serialize-dependency-tree-invalid", dependency_tree_invalid, should_fail=.true.), &
& new_unittest("serialize-dependency-tree-invalid2", dependency_tree_invalid2, should_fail=.true.), &
& new_unittest("serialize-install-config", install_config_roundtrip), &
& new_unittest("serialize-fortran-config", fortran_features_roundtrip), &
& new_unittest("serialize-library-config", library_config_roundtrip), &
& new_unittest("serialize-executable-config", executable_config_roundtrip), &
& new_unittest("serialize-preprocess-config", preprocess_config_roundtrip), &
& new_unittest("serialize-string-array", string_array_roundtrip), &
& new_unittest("serialize-fortran-features", fft_roundtrip), &
& new_unittest("serialize-fortran-invalid", fft_invalid, should_fail=.true.), &
& new_unittest("serialize-package", package_roundtrip), &
& new_unittest("serialize-package-invalid", package_invalid, should_fail=.true.), &
& new_unittest("serialize-srcfile-invalid", source_invalid, should_fail=.true.), &
& new_unittest("serialize-archiver", ar_roundtrip), &
& new_unittest("serialize-archiver-invalid", ar_invalid, should_fail=.true.), &
& new_unittest("serialize-compiler", compiler_roundtrip), &
& new_unittest("serialize-compiler-invalid", compiler_invalid, should_fail=.true.), &
& new_unittest("serialize-model", fpm_model_roundtrip), &
& new_unittest("serialize-model-invalid", fpm_model_invalid, should_fail=.true.), &
& new_unittest("serialize-metapackage-config", metapackage_config_roundtrip), &
& new_unittest("serialize-feature-collection", feature_collection_roundtrip), &
& new_unittest("serialize-profile-config", profile_config_roundtrip)]
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
!> Test git_target_t serialization
subroutine git_target_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(git_target_t) :: git
! Revision type
git = git_target_revision(url="https://github.com/urbanjost/M_CLI2.git", &
sha1="7264878cdb1baff7323cc48596d829ccfe7751b8")
call git%test_serialization("revision git type",error)
if (allocated(error)) return
! Branch type
git = git_target_branch(url="https://github.com/urbanjost/M_CLI2.git", &
branch="main")
call git%test_serialization("branch git type",error)
if (allocated(error)) return
! Tag type
git = git_target_tag(url="https://github.com/urbanjost/M_CLI2.git", &
tag="1.0.0")
call git%test_serialization("target git type",error)
if (allocated(error)) return
! Incomplete type
if (allocated(git%object)) deallocate(git%object)
call git%test_serialization("incomplete git type 1/2",error)
if (allocated(error)) return
! Incomplete type
if (allocated(git%url)) deallocate(git%url)
call git%test_serialization("incomplete git type 2/2",error)
if (allocated(error)) return
end subroutine git_target_roundtrip
!> Test invalid git_target_t serialization
subroutine git_target_invalid(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(git_target_t) :: git
type(toml_table), allocatable :: table
character(*), parameter :: toml = 'descriptor = ""'//NL//& ! invalid descriptor ID
'url = "https://github.com/toml-f/toml-f"'//NL//&
'object = "54686e45993f3a9a1d05d5c7419f39e7d5a4eb3f"'
call string_to_toml(toml, table)
call git%load(table, error)
end subroutine git_target_invalid
!> Test git_target_t serialization
subroutine dependency_config_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(dependency_config_t) :: dep
call dependency_destroy(dep)
dep%name = "M_CLI2"
dep%path = "~/./some/dummy/path"
dep%namespace = "urbanjost"
allocate(dep%requested_version)
call new_version(dep%requested_version, "3.2.0",error); if (allocated(error)) return
allocate(dep%git)
dep%git = git_target_revision(url="https://github.com/urbanjost/M_CLI2.git", &
sha1="7264878cdb1baff7323cc48596d829ccfe7751b8")
! Test full object
call dep%test_serialization("full object",error)
if (allocated(error)) return
! Remove namespace
deallocate(dep%namespace)
call dep%test_serialization("no namespace",error)
if (allocated(error)) return
! Remove git
deallocate(dep%git)
call dep%test_serialization("no git",error)
if (allocated(error)) return
! Remove version
deallocate(dep%requested_version)
call dep%test_serialization("no requested_version",error)
if (allocated(error)) return
! Remove name
deallocate(dep%name)
call dep%test_serialization("no name",error)
if (allocated(error)) return
! Remove path
deallocate(dep%path)
call dep%test_serialization("no path",error)
if (allocated(error)) return
end subroutine dependency_config_roundtrip
!> Test dependency_node_t serialization
subroutine dependency_node_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: dep
call destroy_dependency_node(dep)
dep%name = "M_CLI2"
dep%path = "~/./some/dummy/path"
dep%proj_dir = "~/./"
dep%namespace = "urbanjost"
dep%revision = "7264878cdb1baff7323cc48596d829ccfe7751b8"
dep%cached = .true.
dep%done = .false.
dep%update = .true.
allocate(dep%requested_version)
call new_version(dep%requested_version, "3.2.0",error); if (allocated(error)) return
allocate(dep%version)
call new_version(dep%version, "4.53.2",error); if (allocated(error)) return
allocate(dep%git)
dep%git = git_target_revision(url="https://github.com/urbanjost/M_CLI2.git", &
sha1="7264878cdb1baff7323cc48596d829ccfe7751b8")
! Test full object
call dep%test_serialization("full object",error)
if (allocated(error)) return
! Remove namespace
deallocate(dep%namespace)
call dep%test_serialization("no namespace",error)
if (allocated(error)) return
! Remove git
deallocate(dep%git)
call dep%test_serialization("no git",error)
if (allocated(error)) return
! Remove version
deallocate(dep%requested_version)
call dep%test_serialization("no requested_version",error)
if (allocated(error)) return
! Remove name
deallocate(dep%name)
call dep%test_serialization("no name",error)
if (allocated(error)) return
! Remove path
deallocate(dep%path)
call dep%test_serialization("no path",error)
if (allocated(error)) return
! Remove revision
deallocate(dep%revision)
call dep%test_serialization("no revision",error)
if (allocated(error)) return
! Remove proj_dir
deallocate(dep%proj_dir)
call dep%test_serialization("no proj_dir",error)
if (allocated(error)) return
! Remove version
deallocate(dep%version)
call dep%test_serialization("no version",error)
if (allocated(error)) return
end subroutine dependency_node_roundtrip
!> Test loading invalid dependency node
subroutine dependency_node_invalid(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: dep
type(toml_table), allocatable :: table
character(*), parameter :: toml = 'name = "jonquil" '//NL//&
& 'version = "h0.2.0"'//NL//& ! invalid version
& 'proj-dir = "build/dependencies/jonquil"'//NL//&
& 'revision = "05d30818bb12fb877226ce284b9a3a41b971a889"'//NL//&
& 'done = true'//NL//&
& 'update = false'//NL//&
& 'cached = true'
call string_to_toml(toml, table)
call dep%load(table, error)
end subroutine dependency_node_invalid
!> Test loading invalid dependency node
subroutine dependency_node_invalid_2(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(dependency_node_t) :: dep
type(toml_table), allocatable :: table
character(*), parameter :: toml = 'name = "jonquil" '//NL//&
& 'version = "0.2.0"'//NL//&
& 'proj-dir = "build/dependencies/jonquil"'//NL//&
& 'revision = "05d30818bb12fb877226ce284b9a3a41b971a889"'//NL//&
& 'done = 123'//NL//& ! not a boolean
& 'update = false'//NL//&
& 'cached = true'
call string_to_toml(toml, table)
call dep%load(table, error)
end subroutine dependency_node_invalid_2
!> Test dependency_tree_t serialization
subroutine dependency_tree_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(dependency_tree_t) :: deps
type(dependency_config_t) :: dep
integer, parameter :: ALLOCATED_DEPS = 5
character(36) :: msg
integer :: ii
! Generate dummy tree with ndep=3 but 5 allocated dependencies
call new_dependency_tree(deps)
call resize(deps%dep, ALLOCATED_DEPS)
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)
deps%dep(3)%name = "M_CLI2"
deps%dep(3)%path = "~/./some/dummy/path"
deps%dep(3)%proj_dir = "~/./"
deps%dep(3)%namespace = "urbanjost"
deps%dep(3)%revision = "7264878cdb1baff7323cc48596d829ccfe7751b8"
deps%dep(3)%cached = .true.
deps%dep(3)%done = .false.
deps%dep(3)%update = .true.
allocate(deps%dep(3)%requested_version)
call new_version(deps%dep(3)%requested_version, "3.2.0",error); if (allocated(error)) return
allocate(deps%dep(3)%version)
call new_version(deps%dep(3)%version, "4.53.2",error); if (allocated(error)) return
allocate(deps%dep(3)%git)
deps%dep(3)%git = git_target_revision(url="https://github.com/urbanjost/M_CLI2.git", &
sha1="7264878cdb1baff7323cc48596d829ccfe7751b8")
call deps%test_serialization("full dependency tree", error)
if (allocated(error)) return
! Remove dependencies (including all them)
do ii = 1, ALLOCATED_DEPS
write(msg,1) ii
call resize(deps%dep, size(deps%dep) - 1)
call deps%test_serialization(trim(msg), error)
if (allocated(error)) return
end do
! deallocate dependencies
deallocate(deps%dep)
call deps%test_serialization("unallocated deps(:)", error)
if (allocated(error)) return
! Remove deps dir
deallocate(deps%dep_dir)
call deps%test_serialization("no deps dir", error)
if (allocated(error)) return
1 format('removed ',i0,' dependencies')
end subroutine dependency_tree_roundtrip
!> Test invalid dependency tree loading
subroutine dependency_tree_invalid(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table), allocatable :: table
type(dependency_tree_t) :: dep
character(len=*), parameter :: toml = &
& 'unit = 6 '//NL//&
& 'verbosity = true'//NL//& ! not a number
& 'dep-dir = "build/dependencies"'//NL//&
& 'ndep = 3'//NL//& ! consistency is not checked:
& '[dependencies]'//NL//&
& '[dependencies.dep1]'//NL//&
& 'name = "dep1"'//NL//&
& 'path = "fpm-tmp1-dir"'//NL//&
& 'proj-dir = "fpm-tmp1-dir"'//NL//&
& 'done = false'//NL//&
& 'update = false'//NL//&
& 'cached = false'
call string_to_toml(toml, table)
call dep%load(table, error)
end subroutine dependency_tree_invalid
!> Test invalid dependency tree loading
subroutine dependency_tree_invalid2(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table), allocatable :: table
type(dependency_tree_t) :: dep
character(len=*), parameter :: toml = &
& 'unit = "" '//NL//& ! not provided
& 'verbosity = 1'//NL//&
& 'dep-dir = "build/dependencies"'//NL//&
& 'ndep = 3'//NL//& ! consistency is not checked:
& '[dependencies.M_CLI2]'//NL//&
& 'name = "M_CLI2"'//NL//&
& 'path = "~/./some/dummy/path"'//NL//&
& 'namespace = "urbanjost"'//NL//&
& 'requested_version = "3.2.0"'//NL//&
& 'version = "4.53.2"'//NL//&
& 'proj-dir = "~/./"'//NL//&
& 'revision = "7264878cdb1baff7323cc48596d829ccfe7751b8"'//NL//&
& 'done = false'//NL//&
& 'update = true'//NL//&
& 'cached = true'//NL//&
& '[dependencies.M_CLI2.git]'//NL//&
& 'descriptor = "revision"'//NL//&
& 'url = "https://github.com/urbanjost/M_CLI2.git"'//NL//&
& 'object = "7264878cdb1baff7323cc48596d829ccfe7751b8"'
call string_to_toml(toml, table)
call dep%load(table, error)
end subroutine dependency_tree_invalid2
!> Test serialization/deserialization of a string array
subroutine string_array_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(len=*), parameter :: lorem = "Lorem ipsum dolor sit amet, consectetur adipiscing " &
& //"elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad " &
& //"minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo " &
& //"consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum " &
& //"dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt " &
& //"in culpa qui officia deserunt mollit anim id est laborum"
integer :: ii, nword
character(len=:), allocatable :: tokens(:)
type(string_t), allocatable :: list(:),copy(:)
type(toml_table) :: table
character(len=16) :: key
call split(lorem, tokens)
nword = size(tokens)
!> Convert to string_t array
allocate(list(nword))
do ii = 1, nword
list(ii) = string_t(trim(tokens(ii)))
end do
! Test list with any length
do ii = nword, 1, -1
! Shorten list
list = list(1:ii)
! Set list to table
table = toml_table()
call set_list(table, key="lorem-ipsum", list=list, error=error)
if (allocated(error)) return
! Load list from table
call get_list(table, key="lorem-ipsum", list=copy, error=error)
if (allocated(error)) return
if (.not.(list==copy)) then
call fatal_error(error,'string_array is not equal after TOML roundtrip')
return
end if
end do
! Test empty list
deallocate(list)
allocate(list(0))
! Set list to table
table = toml_table()
call set_list(table, key="lorem-ipsum", list=list, error=error)
if (allocated(error)) return
! Load list from table
call get_list(table, key="lorem-ipsum", list=copy, error=error)
if (allocated(error)) return
if (.not.(list==copy)) then
call fatal_error(error,'empty string_array is not equal after TOML roundtrip')
return
end if
! Test unallocated list
deallocate(list)
table = toml_table()
call set_list(table, key="lorem-ipsum", list=list, error=error)
if (allocated(error)) return
! Load list from table
call get_list(table, key="lorem-ipsum", list=copy, error=error)
if (allocated(error)) return
if (.not.(list==copy)) then
call fatal_error(error,'deallocated string_array is not equal after TOML roundtrip')
return
end if
1 format('word_',i0)
end subroutine string_array_roundtrip
!> Test serialization/deserialization of a fortran-features structure
subroutine fft_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(fortran_config_t) :: fortran
!> Default object
call fortran%test_serialization('fortran_config_t: default object',error)
if (allocated(error)) return
!> Set form
fortran%source_form = "free"
call fortran%test_serialization('fortran_config_t: with form',error)
if (allocated(error)) return
end subroutine fft_roundtrip
!> Test deserialization of an invalid fortran-features structure
subroutine fft_invalid(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(fortran_config_t) :: fortran
type(toml_table), allocatable :: table
character(len=*), parameter :: toml = 'implicit-typing = false '//NL//&
& 'implicit-external = 0 '//NL//& ! not a boolean
& 'source-form = "free" '
call string_to_toml(toml, table)
!> Default object
call fortran%load(table,error)
end subroutine fft_invalid
!> Test serialization/deserialization of a package_t structure
subroutine package_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(package_t) :: pkg
integer :: ierr
!> Default object
call pkg%test_serialization('package_t: default object',error)
if (allocated(error)) return
!> Create a dummy package
pkg%name = "orderpack"
if (.not.allocated(pkg%version)) allocate(pkg%version)
call new_version(pkg%version, "0.1.0", error)
if (allocated(error)) return
pkg%enforce_module_names = .false.
pkg%module_prefix = string_t("")
pkg%features%source_form = "free"
if (allocated(pkg%sources)) deallocate(pkg%sources)
allocate(pkg%sources(4))
pkg%sources(1)%file_name = "build/dependencies/orderpack/src/M_valnth.f90"
pkg%sources(1)%digest = 2662523002405134329_tf_i8
pkg%sources(1)%unit_scope = FPM_SCOPE_LIB
pkg%sources(1)%unit_type = FPM_UNIT_MODULE
pkg%sources(1)%modules_provided = [string_t("m_valnth")]
deallocate(pkg%sources(1)%parent_modules, stat=ierr)
deallocate(pkg%sources(1)%modules_used, stat=ierr)
deallocate(pkg%sources(1)%include_dependencies, stat=ierr)
deallocate(pkg%sources(1)%link_libraries, stat=ierr)
pkg%sources(2)%file_name = "build/dependencies/orderpack/src/M_mrgrnk.f90"
pkg%sources(2)%digest = 7985690966656622651_tf_i8
pkg%sources(2)%unit_scope = FPM_SCOPE_LIB
pkg%sources(2)%unit_type = FPM_UNIT_MODULE
pkg%sources(2)%modules_provided = [string_t("m_mrgrnk")]
pkg%sources(2)%link_libraries = [string_t("netcdf"),string_t("hdf-5")]
deallocate(pkg%sources(2)%parent_modules, stat=ierr)
deallocate(pkg%sources(2)%modules_used, stat=ierr)
deallocate(pkg%sources(2)%include_dependencies, stat=ierr)
deallocate(pkg%sources(2)%link_libraries, stat=ierr)
pkg%sources(3)%file_name = "build/dependencies/orderpack/src/M_median.f90"
pkg%sources(3)%digest = 7985690966656622651_tf_i8
pkg%sources(3)%unit_scope = FPM_SCOPE_LIB
pkg%sources(3)%unit_type = FPM_UNIT_MODULE
pkg%sources(3)%modules_provided = [string_t("m_median")]
deallocate(pkg%sources(3)%parent_modules, stat=ierr)
deallocate(pkg%sources(3)%modules_used, stat=ierr)
deallocate(pkg%sources(3)%include_dependencies, stat=ierr)
deallocate(pkg%sources(3)%link_libraries, stat=ierr)
pkg%sources(4)%file_name = "build/dependencies/orderpack/src/M_unista.f90"
pkg%sources(4)%digest = -7512253540457404792_tf_i8
pkg%sources(4)%unit_scope = FPM_SCOPE_LIB
pkg%sources(4)%unit_type = FPM_UNIT_MODULE
pkg%sources(4)%modules_provided = [string_t("m_unista")]
pkg%sources(4)%modules_used = [string_t("m_uniinv")]
deallocate(pkg%sources(4)%parent_modules, stat=ierr)
deallocate(pkg%sources(4)%include_dependencies, stat=ierr)
deallocate(pkg%sources(4)%link_libraries, stat=ierr)
!> Package mock
call pkg%test_serialization('package_t: orderpack',error)
if (allocated(error)) return
!> Remove some entries
pkg%sources(1)%file_name = ""
pkg%sources(3)%digest = 0
pkg%sources = pkg%sources(1:3)
call pkg%test_serialization('package_t: orderpack (reduced)',error)
if (allocated(error)) return
!> Remove all sources
deallocate(pkg%sources,stat=ierr)
call pkg%test_serialization('package_t: no sources',error)
if (allocated(error)) return
end subroutine package_roundtrip
!> Test deserialization of an invalid package TOML file
subroutine package_invalid(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(len=*), parameter :: toml = &
& 'name = "toml-f" '//NL//&
& 'version = "0.8.0" '//NL//&
& 'module-naming = "prefix" '//NL//& ! this should be boolean
& 'module-prefix = "" '
type(package_t) :: pkg
type(toml_table), allocatable :: table
call string_to_toml(toml, table)
!> Default object
call pkg%load(table,error)
end subroutine package_invalid
!> Test deserialization of an invalid source file
subroutine source_invalid(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(len=*), parameter :: toml = &
& 'file-name = "build/dependencies/toml-f/src/tomlf.f90" '//NL//&
& 'digest = "abcde" '//NL//& ! not a number
& 'unit-scope = "FPM_SCOPE_MODULE" '//NL//&
& 'unit-type = "FPM_UNIT_MODULE" '//NL//&
& 'modules-provided = "tomlf" '//NL//&
& 'parent-modules = [ ] '//NL//&
& 'modules-used = [ "tomlf_build", "tomlf_datetime" ] '//NL//&
& 'include-dependencies = [ ] '//NL//&
& 'link-libraries = [ ] '
type(srcfile_t) :: src
type(toml_table), allocatable :: table
call string_to_toml(toml, table)
!> Default object
call src%load(table,error)
end subroutine source_invalid
!> Test serialization/deserialization of an archiver_t structure
subroutine ar_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(archiver_t) :: ar
integer :: ierr
!> Default object
call ar%test_serialization('archiver_t: default object',error)
if (allocated(error)) return
!> change a few items
ar%ar = "ar"
ar%echo = .true.
ar%use_response_file = .false.
call ar%test_serialization('archiver_t: ar',error)
end subroutine ar_roundtrip
!> Test deserialization of an invalid archiver_t structure
subroutine ar_invalid(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(len=*), parameter :: toml = &
& 'ar = "ar -rs " '//NL//&
& 'use-response-file = false '//NL//&
& 'echo = 123 '//NL//& ! not a boolean
& 'verbose = false '
type(archiver_t) :: ar
type(toml_table), allocatable :: table
call string_to_toml(toml, table)
!> Default object
call ar%load(table,error)
end subroutine ar_invalid
!> Test serialization/deserialization of a compiler_t structure
subroutine compiler_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(compiler_t) :: compiler
!> Default object
call compiler%test_serialization('compiler_t: default object',error)
if (allocated(error)) return
!> change a few items
compiler%id = id_gcc
compiler%fc = "gfortran -ffree-line-length-none -fdefault-real-8 -O3"
compiler%cc = ""
compiler%cxx = "g++ -O3 -std=c++11"
compiler%echo = .false.
call compiler%test_serialization('compiler_t: gcc',error)
end subroutine compiler_roundtrip
!> Test deserialization of an invalid compiler_t TOML structure
subroutine compiler_invalid(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(len=*), parameter :: toml = &
& 'id = "gfortran" '//NL//& ! not an integer identifier
& 'fc = "gfortran" '//NL//&
& 'cc = "gcc" '//NL//&
& 'cxx = "g++" '//NL//&
& 'echo = false '//NL//&
& 'verbose = false '
type(compiler_t) :: cc
type(toml_table), allocatable :: table
call string_to_toml(toml, table)
!> Default object
call cc%load(table,error)
end subroutine compiler_invalid
!> Get a shortened TOML representation of the fpm v0.8.1 model
subroutine fpm_081_table(table)
!> TOML representation of the fpm v0.8.1 model
type(toml_table), allocatable, intent(out) :: table
!> simplified TOML representation of the fpm v0.8.1 model
character(len=:), allocatable :: fpm
integer :: iunit
allocate(character(len=0) :: fpm)
fpm = fpm//NL//'package-name = "fpm"'
fpm = fpm//NL//'fortran-flags = " -Wall -Wextra -Wno-external-argument-mismatch -fPIC -fmax-errors=1 -g "'
fpm = fpm//NL//'c-flags = ""'
fpm = fpm//NL//'cxx-flags = ""'
fpm = fpm//NL//'link-flags = ""'
fpm = fpm//NL//'build-prefix = "build/gfortran"'
fpm = fpm//NL//'include-dirs = [ ]'
fpm = fpm//NL//'link-libraries = [ ]'
fpm = fpm//NL//'external-modules = [ ]'
fpm = fpm//NL//'include-tests = false'
fpm = fpm//NL//'module-naming = false'
fpm = fpm//NL//'module-prefix = ""'
fpm = fpm//NL//'[compiler]'
fpm = fpm//NL//'id = 1'
fpm = fpm//NL//'fc = "gfortran"'
fpm = fpm//NL//'cc = "gcc"'
fpm = fpm//NL//'cxx = "g++"'
fpm = fpm//NL//'echo = false'
fpm = fpm//NL//'verbose = false'
fpm = fpm//NL//'[archiver]'
fpm = fpm//NL//'ar = "ar -rs "'
fpm = fpm//NL//'use-response-file = false'
fpm = fpm//NL//'echo = false'
fpm = fpm//NL//'verbose = false'
fpm = fpm//NL//'[deps]'
fpm = fpm//NL//'unit = 6'
fpm = fpm//NL//'verbosity = 1'
fpm = fpm//NL//'dep-dir = "build/dependencies"'
fpm = fpm//NL//'cache = "build/cache.toml"'
fpm = fpm//NL//'ndep = 4'
fpm = fpm//NL//'[deps.dependencies]'
fpm = fpm//NL//'[deps.dependencies.fpm]'
fpm = fpm//NL//'name = "fpm"'
fpm = fpm//NL//'path = "."'
fpm = fpm//NL//'version = "0.8.0"'
fpm = fpm//NL//'proj-dir = "./."'
fpm = fpm//NL//'done = true'
fpm = fpm//NL//'update = false'
fpm = fpm//NL//'cached = false'
fpm = fpm//NL//'[deps.dependencies.toml-f]'
fpm = fpm//NL//'name = "toml-f"'
fpm = fpm//NL//'version = "0.4.0"'
fpm = fpm//NL//'proj-dir = "build/dependencies/toml-f"'
fpm = fpm//NL//'revision = "54686e45993f3a9a1d05d5c7419f39e7d5a4eb3f"'
fpm = fpm//NL//'done = true'
fpm = fpm//NL//'update = false'
fpm = fpm//NL//'cached = true'
fpm = fpm//NL//'[deps.dependencies.toml-f.git]'
fpm = fpm//NL//'descriptor = "revision"'
fpm = fpm//NL//'url = "https://github.com/toml-f/toml-f"'
fpm = fpm//NL//'object = "54686e45993f3a9a1d05d5c7419f39e7d5a4eb3f"'
fpm = fpm//NL//'[deps.dependencies.UNNAMED_DEPENDENCY_5]'
fpm = fpm//NL//'done = false'
fpm = fpm//NL//'update = false'
fpm = fpm//NL//'cached = false'
fpm = fpm//NL//'[packages]'
fpm = fpm//NL//'[packages.fpm]'
fpm = fpm//NL//'name = "fpm"'
fpm = fpm//NL//'version = "0.8.0"'
fpm = fpm//NL//'module-naming = false'
fpm = fpm//NL//'module-prefix = ""'
fpm = fpm//NL//'[packages.fpm.fortran]'
fpm = fpm//NL//'implicit-typing = false'
fpm = fpm//NL//'implicit-external = false'
fpm = fpm//NL//'source-form = "free"'
fpm = fpm//NL//'[packages.fpm.sources]'
fpm = fpm//NL//'[packages.fpm.sources.src_1]'
fpm = fpm//NL//'file-name = "././src/fpm.f90"'
fpm = fpm//NL//'digest = 4322290725857190613'
fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"'
fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"'
fpm = fpm//NL//'modules-provided = "fpm"'
fpm = fpm//NL//'parent-modules = [ ]'
fpm = fpm//NL//'modules-used = [ "fpm_strings", "fpm_backend", "fpm_compiler", "fpm_error" ]'
fpm = fpm//NL//'include-dependencies = [ ]'
fpm = fpm//NL//'link-libraries = [ ]'
fpm = fpm//NL//'[packages.fpm.sources.src_2]'
fpm = fpm//NL//'file-name = "././src/fpm_backend.F90"'
fpm = fpm//NL//'digest = -3210121688944515946'
fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"'
fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"'
fpm = fpm//NL//'modules-provided = "fpm_backend"'
fpm = fpm//NL//'parent-modules = [ ]'
fpm = fpm//NL//'modules-used = [ "fpm_error", "fpm_filesystem", "fpm_backend_output" ]'
fpm = fpm//NL//'include-dependencies = [ ]'
fpm = fpm//NL//'link-libraries = [ ]'
fpm = fpm//NL//'[packages.fpm.sources.src_3]'
fpm = fpm//NL//'file-name = "././src/fpm_environment.f90"'
fpm = fpm//NL//'digest = 2235607720245152632'
fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"'
fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"'
fpm = fpm//NL//'modules-provided = "fpm_environment"'
fpm = fpm//NL//'parent-modules = [ ]'
fpm = fpm//NL//'modules-used = "fpm_error"'
fpm = fpm//NL//'include-dependencies = [ ]'
fpm = fpm//NL//'link-libraries = [ ]'
fpm = fpm//NL//'[packages.fpm.sources.src_4]'
fpm = fpm//NL//'file-name = "././src/fpm_model.f90"'
fpm = fpm//NL//'digest = -6774177234665080583'
fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"'
fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"'
fpm = fpm//NL//'modules-provided = "fpm_model"'
fpm = fpm//NL//'parent-modules = [ ]'
fpm = fpm//NL//'modules-used = [ "fpm_compiler", "fpm_dependency" ]'
fpm = fpm//NL//'include-dependencies = [ ]'
fpm = fpm//NL//'link-libraries = [ ]'
fpm = fpm//NL//'[packages.fpm.sources.src_5]'
fpm = fpm//NL//'file-name = "././src/filesystem_utilities.c"'
fpm = fpm//NL//'digest = 4957633104775755438'
fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"'
fpm = fpm//NL//'unit-type = "FPM_UNIT_CSOURCE"'
fpm = fpm//NL//'modules-provided = [ ]'
fpm = fpm//NL//'parent-modules = [ ]'
fpm = fpm//NL//'modules-used = [ ]'
fpm = fpm//NL//'include-dependencies = [ ]'
fpm = fpm//NL//'link-libraries = [ ]'
fpm = fpm//NL//'[packages.fpm.sources.src_59]'
fpm = fpm//NL//'file-name = "test/new_test/new_test.f90"'
fpm = fpm//NL//'exe-name = "new-test"'
fpm = fpm//NL//'digest = 4683353150944180202'
fpm = fpm//NL//'unit-scope = "FPM_SCOPE_TEST"'
fpm = fpm//NL//'unit-type = "FPM_UNIT_PROGRAM"'
fpm = fpm//NL//'modules-provided = [ ]'
fpm = fpm//NL//'parent-modules = [ ]'
fpm = fpm//NL//'modules-used = [ "fpm_filesystem", "fpm_strings", "fpm_environment" ]'
fpm = fpm//NL//'include-dependencies = [ ]'
fpm = fpm//NL//'link-libraries = [ ]'
fpm = fpm//NL//'[packages.toml-f]'
fpm = fpm//NL//'name = "toml-f"'
fpm = fpm//NL//'version = "0.8.0"'
fpm = fpm//NL//'module-naming = false'
fpm = fpm//NL//'module-prefix = ""'
fpm = fpm//NL//'[packages.toml-f.fortran]'
fpm = fpm//NL//'implicit-typing = false'
fpm = fpm//NL//'implicit-external = false'
fpm = fpm//NL//'source-form = "free"'
fpm = fpm//NL//'[packages.toml-f.sources]'
fpm = fpm//NL//'[packages.toml-f.sources.src_1]'
fpm = fpm//NL//'file-name = "build/dependencies/toml-f/src/tomlf.f90"'
fpm = fpm//NL//'digest = -8299830903248890534'
fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"'
fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"'
fpm = fpm//NL//'modules-provided = "tomlf"'
fpm = fpm//NL//'parent-modules = [ ]'
fpm = fpm//NL//'modules-used = [ "tomlf_build", "tomlf_datetime" ]'
fpm = fpm//NL//'include-dependencies = [ ]'
fpm = fpm//NL//'link-libraries = [ ]'
fpm = fpm//NL//'[packages.toml-f.sources.src_2]'
fpm = fpm//NL//'file-name = "build/dependencies/toml-f/src/tomlf/constants.f90"'
fpm = fpm//NL//'digest = 7170350792708576173'
fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"'
fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"'
fpm = fpm//NL//'modules-provided = "tomlf_constants"'
fpm = fpm//NL//'parent-modules = [ ]'
fpm = fpm//NL//'modules-used = [ ]'
fpm = fpm//NL//'include-dependencies = [ ]'
fpm = fpm//NL//'link-libraries = [ ]'
fpm = fpm//NL//'[packages.M_CLI2]'
fpm = fpm//NL//'name = "M_CLI2"'
fpm = fpm//NL//'version = "0.8.0"'
fpm = fpm//NL//'module-naming = false'
fpm = fpm//NL//'module-prefix = ""'
fpm = fpm//NL//'[packages.M_CLI2.fortran]'
fpm = fpm//NL//'implicit-typing = false'
fpm = fpm//NL//'implicit-external = false'
fpm = fpm//NL//'source-form = "free"'
fpm = fpm//NL//'[packages.M_CLI2.sources]'
fpm = fpm//NL//'[packages.M_CLI2.sources.src_1]'
fpm = fpm//NL//'file-name = "build/dependencies/M_CLI2/src/M_CLI2.F90"'
fpm = fpm//NL//'digest = -6169834068995303802'
fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"'
fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"'
fpm = fpm//NL//'modules-provided = "m_cli2"'
fpm = fpm//NL//'parent-modules = [ ]'
fpm = fpm//NL//'modules-used = [ ]'
fpm = fpm//NL//'include-dependencies = [ ]'
fpm = fpm//NL//'link-libraries = [ ]'
fpm = fpm//NL//'[packages.jonquil]'
fpm = fpm//NL//'name = "jonquil"'
fpm = fpm//NL//'version = "0.8.0"'
fpm = fpm//NL//'module-naming = false'
fpm = fpm//NL//'module-prefix = ""'
fpm = fpm//NL//'[packages.jonquil.fortran]'
fpm = fpm//NL//'implicit-typing = false'
fpm = fpm//NL//'implicit-external = false'
fpm = fpm//NL//'source-form = "free"'
fpm = fpm//NL//'[packages.jonquil.sources]'
fpm = fpm//NL//'[packages.jonquil.sources.src_1]'
fpm = fpm//NL//'file-name = "build/dependencies/jonquil/src/jonquil.f90"'
fpm = fpm//NL//'digest = 5552073973512025871'
fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"'
fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"'
fpm = fpm//NL//'modules-provided = "jonquil"'
fpm = fpm//NL//'parent-modules = [ ]'
fpm = fpm//NL//'modules-used = [ "tomlf", "tomlf_type", "jonquil_ser" ]'
fpm = fpm//NL//'include-dependencies = [ ]'
fpm = fpm//NL//'link-libraries = [ ]'
fpm = fpm//NL//'[packages.jonquil.sources.src_2]'
fpm = fpm//NL//'file-name = "build/dependencies/jonquil/src/jonquil/version.f90"'
fpm = fpm//NL//'digest = -2934903401983932826'
fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"'
fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"'
fpm = fpm//NL//'modules-provided = "jonquil_version"'
fpm = fpm//NL//'parent-modules = [ ]'
fpm = fpm//NL//'modules-used = [ ]'
fpm = fpm//NL//'include-dependencies = [ ]'
fpm = fpm//NL//'link-libraries = [ ]'
call string_to_toml(fpm, table)
end subroutine fpm_081_table
!> Convert a character string to a TOML table
subroutine string_to_toml(string, table)
!> The input TOML as a string
character(*), intent(in) :: string
!> The TOML table
type(toml_table), allocatable, intent(out) :: table
integer :: iunit
! Write
open(newunit=iunit,form='formatted',status='scratch',action='readwrite',recl=1073741824)
!> Dump to scratch file
write(iunit,*) string
!> Load from scratch file
rewind(iunit)
call toml_load(table, iunit)
close(iunit)
end subroutine string_to_toml
subroutine fpm_model_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(fpm_model_t) :: model
type(toml_table), allocatable :: table
call model%test_serialization('fpm_model_t: default object', error)
if (allocated(error)) return
!> Now init form fpm 0.8.1 table
call fpm_081_table(table)
call model%load(table, error)
if (allocated(error)) then
call fatal_error(error, 'fpm_model_t: cannot load model from fpm v0.8.1 TOML')
return
end if
call model%test_serialization('fpm_model_t: fpm v0.8.1 model test', error)
end subroutine fpm_model_roundtrip
subroutine fpm_model_invalid(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(fpm_model_t) :: model
type(toml_table), allocatable :: table
character(len=:), allocatable :: fpm
allocate(character(len=0) :: fpm)
fpm = fpm//NL//'package-name = "fpm"'
fpm = fpm//NL//'fortran-flags = " -Wall -Wextra -Wno-external-argument-mismatch -fPIC -fmax-errors=1 -g "'
fpm = fpm//NL//'c-flags = ""'
fpm = fpm//NL//'cxx-flags = ""'
fpm = fpm//NL//'link-flags = ""'
fpm = fpm//NL//'build-prefix = "build/gfortran"'
fpm = fpm//NL//'include-dirs = [ ]'
fpm = fpm//NL//'link-libraries = [ ]'
fpm = fpm//NL//'external-modules = "" '
fpm = fpm//NL//'include-tests = "my_test"' ! not a boolean
fpm = fpm//NL//'module-naming = false'
fpm = fpm//NL//'module-prefix = ""'
call string_to_toml(fpm, table)
call model%load(table,error)
end subroutine fpm_model_invalid
subroutine install_config_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(install_config_t) :: install
integer :: loop
do loop=1,2
install % library = mod(loop,2)==0
! Test full object
call install%test_serialization('install_config_roundtrip',error)
if (allocated(error)) return
end do
end subroutine install_config_roundtrip
subroutine fortran_features_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(fortran_config_t) :: fortran
fortran%implicit_external = .true.
fortran%implicit_typing = .false.
fortran%source_form = 'free'
call fortran%test_serialization('fortran_features_roundtrip',error)
if (allocated(error)) return
deallocate(fortran%source_form)
call fortran%test_serialization('fortran_features_roundtrip 2',error)
end subroutine fortran_features_roundtrip
subroutine library_config_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(library_config_t) :: lib
lib%source_dir = 'lib'
lib%include_dir = [string_t('a'),string_t('b')]
call lib%test_serialization('library_config: 1',error)
if (allocated(error)) return
lib%build_script = 'install.sh'
call lib%test_serialization('library_config: 2',error)
if (allocated(error)) return
deallocate(lib%include_dir)
call lib%test_serialization('library_config: 3',error)
end subroutine library_config_roundtrip
subroutine executable_config_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(executable_config_t) :: exe
type(dependency_config_t) :: dep
exe%name = "my_executable"
exe%source_dir = 'app'
call exe%test_serialization('executable_config: 1',error)
if (allocated(error)) return
exe%main = 'main_program.F90'
call exe%test_serialization('executable_config: 2',error)
if (allocated(error)) return
exe%link = [string_t('netcdf'),string_t('hdf5')]
call exe%test_serialization('executable_config: 3',error)
call dependency_destroy(dep)
dep%name = "M_CLI2"
dep%path = "~/./some/dummy/path"
dep%namespace = "urbanjost"
allocate(dep%requested_version)
call new_version(dep%requested_version, "3.2.0",error); if (allocated(error)) return
allocate(dep%git)
dep%git = git_target_revision(url="https://github.com/urbanjost/M_CLI2.git", &
sha1="7264878cdb1baff7323cc48596d829ccfe7751b8")
allocate(exe%dependency(1),source=dep)
call exe%test_serialization('executable_config: 4',error)
end subroutine executable_config_roundtrip
subroutine preprocess_config_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(preprocess_config_t) :: prep
prep%name = "preprocessor config"
prep%macros = [string_t('Whatever'),string_t('FPM_BOOTSTRAP')]
call prep%test_serialization('preprocess_config', error)
end subroutine preprocess_config_roundtrip
!> Test a metapackage configuration
subroutine metapackage_config_roundtrip(error)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(metapackage_config_t) :: meta
meta%mpi%on = .true.
meta%mpi%version = "MPICH"
meta%minpack%on = .true.
meta%blas%on = .false.
call meta%test_serialization('metapackage_config_t', error)
end subroutine metapackage_config_roundtrip
subroutine feature_collection_roundtrip(error)
type(error_t), allocatable, intent(out) :: error
type(feature_collection_t) :: fc
! Base feature (applies everywhere)
fc%base%name = "my_blas"
fc%base%flags = "-O2"
fc%base%link_time_flags = "-lblas -llapack"
! Two platform/compiler-specific variants
if (allocated(fc%variants)) deallocate(fc%variants)
allocate(fc%variants(2))
! Variant 1: GCC on Linux → OpenBLAS
fc%variants(1)%name = "my_blas"
fc%variants(1)%platform = platform_config_t("gfortran",OS_LINUX)
fc%variants(1)%link_time_flags = "-lopenblas"
! Variant 2: any compiler on macOS → Accelerate framework
fc%variants(2)%name = "my_blas"
fc%variants(2)%platform = platform_config_t("all",OS_MACOS)
fc%variants(2)%link_time_flags = "-framework Accelerate"
! Round-trip via the generic serialization tester
call fc%test_serialization('feature_collection: base + 2 variants', error)
end subroutine feature_collection_roundtrip
subroutine profile_config_roundtrip(error)
type(error_t), allocatable, intent(out) :: error
type(profile_config_t) :: profile
! Set up a profile with features
profile%name = "development"
! Allocate and populate features array
allocate(profile%features(3))
profile%features(1)%s = "debug"
profile%features(2)%s = "testing"
profile%features(3)%s = "verbose"
! Round-trip via the generic serialization tester
call profile%test_serialization('profile_config_t: development profile', error)
end subroutine profile_config_roundtrip
end module test_toml
fortran-lang-fpm-90bb83a/test/cli_test/ 0000775 0001750 0001750 00000000000 15145116760 020255 5 ustar alastair alastair fortran-lang-fpm-90bb83a/test/cli_test/cli_test.f90 0000664 0001750 0001750 00000037731 15145116760 022416 0 ustar alastair alastair 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
character(len=15),allocatable :: features(:),act_features(:) ; namelist/act_cli/act_features
integer,parameter :: max_names=10
character(len=:),allocatable :: command
character(len=:),allocatable :: cmd
integer :: cstat, estat
integer :: act_cstat, act_estat
integer :: i, ios
logical :: w_e,act_w_e ; namelist/act_cli/act_w_e
logical :: w_t,act_w_t ; namelist/act_cli/act_w_t
logical :: c_s,act_c_s ; namelist/act_cli/act_c_s
logical :: c_a,act_c_a ; namelist/act_cli/act_c_a
logical :: c_t,act_c_t ; namelist/act_cli/act_c_t
logical :: c_apps,act_c_apps ; namelist/act_cli/act_c_apps
logical :: c_ex,act_c_ex ; namelist/act_cli/act_c_ex
logical :: reg_c,act_reg_c ; namelist/act_cli/act_reg_c
logical :: show_v,act_show_v ; namelist/act_cli/act_show_v
logical :: show_u_d,act_show_u_d; namelist/act_cli/act_show_u_d
logical :: dry_run,act_dry_run ; namelist/act_cli/act_dry_run
character(len=:), allocatable :: token, act_token ; namelist/act_cli/act_token
character(len=:), allocatable :: profile,act_profile ; namelist/act_cli/act_profile
character(len=:), allocatable :: args,act_args ; namelist/act_cli/act_args
namelist/expected/cmd,cstat,estat,w_e,w_t,c_s,c_a,c_t,c_apps,c_ex,reg_c,name,features,profile,args,show_v,show_u_d,dry_run,token
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="",features=,ARGS="",', &
'CMD="build --profile release", NAME=, profile="release",features=,ARGS="",', &
'CMD="build --features debug,mpi", NAME=, profile="",features="debug","mpi",ARGS="",', &
'CMD="build --features single_feature", NAME=, profile="",features="single_feature",ARGS="",', &
'CMD="test --features debug,openmp", NAME=, profile="",features="debug","openmp",ARGS="",', &
'CMD="clean", NAME=, ARGS="",', &
'CMD="clean --skip", C_S=T, NAME=, ARGS="",', &
'CMD="clean --all", C_A=T, NAME=, ARGS="",', &
'CMD="clean --test", C_T=T, NAME=, ARGS="",', &
'CMD="clean --apps", C_APPS=T, NAME=, ARGS="",', &
'CMD="clean --examples", C_EX=T, NAME=, ARGS="",', &
'CMD="clean --test --apps", C_T=T, C_APPS=T, NAME=, ARGS="",', &
'CMD="clean --registry-cache", REG_C=T, NAME=, ARGS="",', &
'CMD="publish --token abc --show-package-version", SHOW_V=T, NAME=, token="abc",ARGS="",', &
'CMD="publish --token abc --show-upload-data", SHOW_U_D=T, NAME=, token="abc",ARGS="",', &
'CMD="publish --token abc --dry-run", DRY_RUN=T, NAME=, token="abc",ARGS="",', &
'CMD="publish --token abc", NAME=, token="abc",ARGS="",', &
' ' ]
character(len=256) :: readme(3)
readme(1)='&EXPECTED' ! top and bottom line for a NAMELIST group read from TEST() used to set the expected values
readme(3)=' /'
tally=[logical ::] ! an array that tabulates the command test results as pass or fail.
if(command_argument_count()==0)then ! assume if called with no arguments to do the tests. This means you cannot
! have a test of no parameters. Could improve on this.
! if called with parameters assume this is a test and call the routine to
! parse the resulting values after calling the CLI command line parser
! and write the NAMELIST group so it can be read and tested against the
! expected results
write(*,*)'start tests of the CLI command line parser'
command=repeat(' ',4096)
call get_command_argument(0,command)
command=trim(command)
write(*,*)'command=',command
do i=1,size(tests)
if(tests(i)==' ')then
open(file='_test_cli',newunit=lun,delim='quote')
close(unit=lun,status='delete')
exit
endif
! blank out name group EXPECTED
name=[(repeat(' ',len(name)),i=1,max_names)] ! the words on the command line sans the subcommand name
if(.not.allocated(features)) allocate(character(len=15) :: features(max_names))
features=[(repeat(' ',15),i=1,max_names)] ! the features on the command line
profile='' ! --profile PROF
w_e=.false. ! --app
w_t=.false. ! --test
c_s=.false. ! --skip
c_a=.false. ! --all
reg_c=.false. ! --registry-cache
show_v=.false. ! --show-package-version
show_u_d=.false. ! --show-upload-data
dry_run=.false. ! --dry-run
token='' ! --token TOKEN
args=repeat(' ',132) ! -- ARGS
cmd=repeat(' ',132) ! the command line arguments to test
cstat=0 ! status values from EXECUTE_COMMAND_LINE()
estat=0
readme(2)=' '//tests(i) ! select command options to test for CMD and set nondefault expected values
read(readme,nml=expected)
write(*,'(*(g0))')'START: TEST ',i,' CMD=',trim(cmd)
! call this program which will crack command line and write results to scratch file _test_cli
call execute_command_line(command//' '//trim(cmd),cmdstat=act_cstat,exitstat=act_estat)
if(cstat==act_cstat.and.estat==act_estat)then
if(estat==0)then
open(file='_test_cli',newunit=lun,delim='quote')
act_name=[(repeat(' ',len(act_name)),i=1,max_names)]
if(.not.allocated(act_features)) allocate(character(len=15) :: act_features(max_names))
act_features=[(repeat(' ',15),i=1,max_names)]
act_profile=''
act_w_e=.false.
act_w_t=.false.
act_c_s=.false.
act_c_a=.false.
act_reg_c=.false.
act_show_v=.false.
act_show_u_d=.false.
act_dry_run=.false.
act_token=''
act_args=repeat(' ',132)
read(lun,nml=act_cli,iostat=ios,iomsg=message)
if(ios/=0)then
write(*,'(a)')'ERROR:',trim(message)
endif
close(unit=lun)
! compare results to expected values
subtally=[logical ::]
call test_test('NAME',all(act_name==name))
call test_test('FEATURES',all(act_features==features))
call test_test('PROFILE',act_profile==profile)
call test_test('SKIP',act_c_s.eqv.c_s)
call test_test('ALL',act_c_a.eqv.c_a)
call test_test('REGISTRY-CACHE',act_reg_c.eqv.reg_c)
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('SHOW-PACKAGE-VERSION',act_show_v.eqv.show_v)
call test_test('SHOW-UPLOAD-DATA',act_show_u_d.eqv.show_u_d)
call test_test('DRY-RUN',act_dry_run.eqv.dry_run)
call test_test('TOKEN',act_token==token)
call test_test('ARGS',act_args==args)
if(all(subtally))then
write(*,'(*(g0))')'PASSED: TEST ',i,' STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,&
& ' for [',trim(cmd),']'
tally=[tally,.true.]
else
write(*,'(*(g0))')'FAILED: TEST ',i,' STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,&
& ' for [',trim(cmd),']'
print '(4a)', &
'This file was compiled by ', &
compiler_version(), &
' using the options ', &
compiler_options()
write(*,nml=act_cli,delim='quote')
tally=[tally,.false.]
endif
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_clean_settings, &
fpm_install_settings, &
get_command_line_settings, &
fpm_publish_settings
use fpm, only: cmd_run, cmd_clean
use fpm_cmd_install, only: cmd_install
use fpm_cmd_new, only: cmd_new
use fpm_cmd_publish, only: cmd_publish
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) )
allocate(character(len=15) :: act_features(max_names))
act_features=[(repeat(' ',15),i=1,max_names)]
act_args=''
act_w_e=.false.
act_w_t=.false.
act_c_s=.false.
act_c_a=.false.
act_reg_c=.false.
act_show_v=.false.
act_show_u_d=.false.
act_dry_run=.false.
act_token=''
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)
if (allocated(settings%profile)) act_profile=settings%profile
if (allocated(settings%features)) then
do i = 1, min(size(settings%features),size(act_features))
act_features(i) = settings%features(i)%s
end do
end if
type is (fpm_run_settings)
if (allocated(settings%profile)) act_profile=settings%profile
if (allocated(settings%features)) then
do i = 1, min(size(settings%features),size(act_features))
act_features(i) = settings%features(i)%s
end do
end if
act_name=settings%name
if (allocated(settings%args)) act_args=settings%args
type is (fpm_test_settings)
if (allocated(settings%profile)) act_profile=settings%profile
if (allocated(settings%features)) then
do i = 1, min(size(settings%features),size(act_features))
act_features(i) = settings%features(i)%s
end do
end if
act_name=settings%name
if (allocated(settings%args)) act_args=settings%args
type is (fpm_clean_settings)
act_c_s=settings%clean_skip
act_c_a=settings%clean_all
act_c_t=settings%clean_test
act_c_apps=settings%clean_apps
act_c_ex=settings%clean_examples
act_reg_c=settings%registry_cache
type is (fpm_install_settings)
type is (fpm_publish_settings)
act_show_v=settings%show_package_version
act_show_u_d=settings%show_upload_data
act_dry_run=settings%is_dry_run
act_token=settings%token
end select
open(file='_test_cli',newunit=lun,delim='quote')
write(lun,nml=act_cli,delim='quote')
close(unit=lun)
end subroutine parse
end program main
fortran-lang-fpm-90bb83a/docs.md 0000664 0001750 0001750 00000010471 15145116760 016745 0 ustar alastair alastair ---
project: Fortran-lang/fpm
summary: Fortran Package Manager
project_github: https://github.com/fortran-lang/fpm
project_download: https://github.com/fortran-lang/fpm/archive/main.zip
author: fortran-lang/fpm contributors
author_pic: https://fortran-lang.org/assets/img/fortran_logo_512x512.png
author_email: fortran-lang@groups.io
github: https://github.com/fortran-lang
twitter: https://twitter.com/fortranlang
website: https://fortran-lang.org
src_dir: ./src
./app
output_dir: ./fpm-doc
page_dir: ./doc
media_dir: ./doc/media
exclude_dir: ./example_packages
./test
display: public
protected
source: true
proc_internals: true
sort: permission-alpha
favicon: doc/media/favicon.ico
print_creation_date: true
extra_mods: iso_fortran_env:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fFORTRAN_005fENV.html
tomlf:https://toml-f.github.io/toml-f
M_CLI2:https://github.com/urbanjost/M_CLI2
creation_date: %Y-%m-%d %H:%M %z
md_extensions: markdown.extensions.toc
markdown.extensions.smarty
---
[TOC]
# Fortran package manager developer documentation
This is the main documentation of the Fortran package manager (*fpm*).
This document serves as developer documentation of *fpm* itself and contains general advice for developing in the *fpm* code base.
## The package manifest
The central object describing an *fpm* project is the package manifest ``fpm.toml``.
The manifest is written in TOML, you can find the TOML specification at the official [TOML homepage](https://toml.io).
The ``fpm.toml`` file targets project developers and maintainers to relieve them from writing build files for their packages.
With the package manifest a central place to collect information about the project is provided.
It contains the versioning and licensing meta data, as well as the information on external dependencies and the required build-tools or compiler settings.
The manifest format specific to *fpm* projects is documented in the [manifest reference](page/Manifest.html).
@Note For a more practical but less complete guide on creating *fpm* projects see the [packaging guide](page/Packaging.html).
The details of the TOML parsing are implemented with using the [tomlf](https://toml-f.github.io/toml-f) module.
Generally, the interface to all TOML related functions for *fpm* is found in the proxy module [[fpm_toml]].
All the manifest types are bundled in [[fpm_manifest]].
While the specific subtables for the package configuration are found in the ``src/fpm/manifest`` directory, they should be reexported in the [[fpm_manifest]] module if they should be elsewhere in *fpm*.
## Command line interface
*fpm* is mainly used as a command line tool.
To work with an *fpm* project as a user you can completely rely on the command line.
The command line interface is build with the [M_CLI2](https://github.com/urbanjost/M_CLI2) module and can be found in [[fpm_command_line]].
## The package model
Once front-end inputs have been received from the package manifest and command line interface, *fpm* will construct an
internal representation of the package and its dependencies. This internal representation is known as the package *model*.
The model and its associated data types should encapsulate all the information required to correctly build a package and
should be independent of the intended backend build system. Information stored in the model includes: build targets and
their inter-dependencies; compiler and compiler flags; library linking information.
For more information on the contents of the package model and the process for constructing it, please see [[fpm_model]].
## The build backend
Once a complete package model has been constructed, it can be passed to a *backend* for either performing the compilation
and linking of targets, or for generating configuration files for a third-party build system.
Currently, only a native backend is implemented in *fpm*. See [[fpm_backend]] for more information.
## Generating this documentation
This documentation is generated by [FORD](https://github.com/Fortran-FOSS-Programmers/FORD).
For more details on the [project file](https://github.com/fortran-lang/fpm/docs.md) and the comment markup in the source code visit the [FORD documentation](https://github.com/Fortran-FOSS-Programmers/ford/wiki).
To regenerate this documentation run:
```shell
ford docs.md
```
fortran-lang-fpm-90bb83a/src/ 0000775 0001750 0001750 00000000000 15145116760 016257 5 ustar alastair alastair fortran-lang-fpm-90bb83a/src/fpm_strings.f90 0000664 0001750 0001750 00000174756 15145116760 021156 0 ustar alastair alastair !> 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
!! - [[SPLIT_FIRST_LAST]] Computes the first and last indices of tokens in input string, delimited by the characters in set,
!! and stores them into first and last output arrays.
!! - [[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 '?').
!! - [[IS_FORTRAN_NAME]] determine whether a string is an acceptable Fortran entity name
!! - [[TO_FORTRAN_NAME]] replace allowed special but unusuable characters in names with underscore
!!### Whitespace
!! - [[NOTABS]] subroutine to expand tab characters assuming a tab space every eight characters
!! - [[DILATE]] function to expand tab characters assuming a tab space every eight characters
!! - [[LEN_TRIM]] Determine total trimmed length of **STRING_T** array
!!### Miscellaneous
!! - [[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
use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, &
& stdout=>output_unit, &
& stderr=>error_unit
use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer, c_size_t
implicit none
private
public :: f_string, lower, upper, split, split_first_last, split_lines_first_last, str_ends_with, string_t, str_begins_with_str
public :: to_fortran_name, is_fortran_name, is_valid_feature_name, add_strings
public :: string_array_contains, string_cat, len_trim, operator(.in.), fnv_1a
public :: replace, resize, str, join, glob
public :: notabs, dilate, remove_newline_characters, remove_characters_in_set
public :: operator(==)
!> Module naming
public :: is_valid_module_name, is_valid_module_prefix, &
has_valid_custom_prefix, has_valid_standard_prefix, &
module_prefix_template, module_prefix_type
type string_t
character(len=:), allocatable :: s
end type
interface len_trim
module procedure :: string_len_trim
module procedure :: strings_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
procedure :: str_ends_with_any_string
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
interface f_string
module procedure f_string, f_string_cptr, f_string_cptr_n
end interface f_string
interface operator(==)
module procedure string_is_same
module procedure string_arrays_same
end interface
interface add_strings
module procedure add_strings_one
module procedure add_strings_many
end interface add_strings
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
!> Test if a CHARACTER string ends with any of an array of string suffixs
pure logical function str_ends_with_any_string(s, e) result(r)
character(*), intent(in) :: s
type(string_t), intent(in) :: e(:)
integer :: i
r = .true.
do i=1,size(e)
if (str_ends_with(s,trim(e(i)%s))) return
end do
r = .false.
end function str_ends_with_any_string
!> test if a CHARACTER string begins with a specified prefix
pure logical function str_begins_with_str(s, e, case_sensitive) result(r)
character(*), intent(in) :: s, e
logical, optional, intent(in) :: case_sensitive ! Default option: case sensitive
integer :: n1, n2
logical :: lower_case
! Check if case sensitive
if (present(case_sensitive)) then
lower_case = .not.case_sensitive
else
lower_case = .false.
end if
n1 = 1
n2 = 1 + len(e)-1
if (n2 > len(s)) then
r = .false.
elseif (lower_case) then
r = lower(s(n1:n2)) == lower(e)
else
r = (s(n1:n2) == e)
end if
end function str_begins_with_str
!> return Fortran character variable when given a C-like array of
!! single characters terminated with a C_NULL_CHAR character
function f_string(c_string)
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
!> return Fortran character variable when given a null-terminated c_ptr
function f_string_cptr(cptr) result(s)
type(c_ptr), intent(in), value :: cptr
character(len=:,kind=c_char), allocatable :: s
interface
function c_strlen(s) result(r) bind(c, name="strlen")
import c_size_t, c_ptr
type(c_ptr), intent(in), value :: s
integer(kind=c_size_t) :: r
end function
end interface
s = f_string_cptr_n(cptr, c_strlen(cptr))
end function
!> return Fortran character variable when given a null-terminated c_ptr and its length
function f_string_cptr_n(cptr, n) result(s)
type(c_ptr), intent(in), value :: cptr
integer(kind=c_size_t), intent(in) :: n
character(len=n,kind=c_char) :: s
character(len=n,kind=c_char), pointer :: sptr
call c_f_pointer(cptr, sptr)
s = sptr
end function
!> 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
!!License: Public Domain
!! Changes a string to upprtcase over optional specified column range
elemental pure function upper(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 capitalized
case default
end select
end do
end function upper
!> 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 strings_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 strings_len_trim
!> Determine total trimmed length of `string_t` array
elemental integer function string_len_trim(string) result(n)
type(string_t), intent(in) :: string
if (allocated(string%s)) then
n = len_trim(string%s)
else
n = 0
end if
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/='')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))==0)then ! if current character is not a delimiter
iterm(i30)=ilen ! initially assume no more tokens
do i10=1,idlim ! search for next delimiter
ifound=index(input_line(ibegin(i30):ilen),dlim(i10:i10))
IF(ifound>0)then
iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2)
endif
enddo
icol=iterm(i30)+2 ! next place to look as found end of this token
inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters
else ! character is a delimiter for a null string
iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning
icol=icol+1 ! advance pointer into input string
endif
imax=max(imax,iterm(i30)-ibegin(i30)+1)
icount=i30 ! increment count of number of tokens found
if(icol>ilen)then ! no text left
exit INFINITE
endif
enddo INFINITE
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) 0) then
p = 0
do while (p < slen)
n = n + 1
istart(n) = min(p + 1, slen)
call split_pos(string, set, p)
iend(n) = p - 1
end do
end if
first = istart(:n)
last = iend(:n)
end subroutine split_first_last
!! Author: Federico Perini
!! Computes the first and last indices of lines in input string, delimited
!! by either CR, LF, or CRLF, and stores them into first and last output
!! arrays.
pure subroutine split_lines_first_last(string, first, last)
character(*), intent(in) :: string
integer, allocatable, intent(out) :: first(:)
integer, allocatable, intent(out) :: last(:)
integer, allocatable, dimension(:) :: istart, iend
integer :: p, n, slen
character, parameter :: CR = achar(13)
character, parameter :: LF = new_line('A')
slen = len(string)
allocate(istart(slen + 1), iend(slen + 1))
n = 0
if (slen > 0) then
p = 1
do while (p <= slen)
if (index(CR//LF, string(p:p)) == 0) then
n = n + 1
istart(n) = p
do while (p <= slen)
if (index(CR//LF, string(p:p)) /= 0) exit
p = p + 1
end do
iend(n) = p - 1
end if
! Handle Windows CRLF by skipping LF after CR
if (p < slen) then
if (string(p:p) == CR .and. string(p+1:p+1) == LF) p = p + 1
endif
p = p + 1
end do
end if
first = istart(:n)
last = iend(:n)
end subroutine split_lines_first_last
!! Author: Milan Curcic
!! If back is absent, computes the leftmost token delimiter in string whose
!! position is > pos. If back is present and true, computes the rightmost
!! token delimiter in string whose position is < pos. The result is stored
!! in pos.
pure subroutine split_pos(string, set, pos, back)
character(*), intent(in) :: string
character(*), intent(in) :: set
integer, intent(in out) :: pos
logical, intent(in), optional :: back
logical :: backward
integer :: result_pos, bound
if (len(string) == 0) then
pos = 1
return
end if
!TODO use optval when implemented in stdlib
!backward = optval(back, .false.)
backward = .false.
if (present(back)) backward = back
if (backward) then
bound = min(len(string), max(pos - 1, 0))
result_pos = scan(string(:bound), set, back=.true.)
else
result_pos = scan(string(min(pos + 1, len(string)):), set) + pos
if (result_pos < pos + 1) result_pos = len(string) + 1
end if
pos = result_pos
end subroutine split_pos
!> 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)==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)=='*')then
wi=wi+1
else
exit
endif
enddo
if(wildtext(wi:wi)==NULL) then ! "x" matches "*"
glob=.true.
return
endif
if(wildtext(wi:wi) /= '?') then
! Fast-forward to next possible match.
do while (tametext(ti:ti) /= wildtext(wi:wi))
ti=ti+1
if (tametext(ti:ti)==NULL)then
glob=.false.
return ! "x" doesn't match "*y*"
endif
enddo
endif
wbookmark = wildtext(wi:)
tbookmark = tametext(ti:)
elseif(tametext(ti:ti) /= wildtext(wi:wi) .and. wildtext(wi:wi) /= '?') then
! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry.
if(wbookmark/=NULL) then
if(wildtext(wi:)/= wbookmark) then
wildtext = wbookmark;
wlen=len_trim(wbookmark)
wi=1
! Don't go this far back again.
if (tametext(ti:ti) /= wildtext(wi:wi)) then
tbookmark=tbookmark(2:)
tametext = tbookmark
ti=1
cycle ! "xy" matches "*y"
else
wi=wi+1
endif
endif
if (tametext(ti:ti)/=NULL) then
ti=ti+1
cycle ! "mississippi" matches "*sip*"
endif
endif
glob=.false.
return ! "xy" doesn't match "x"
endif
ti=ti+1
wi=wi+1
if (tametext(ti:ti)==NULL) then ! How do you match a tame text string?
if(wildtext(wi:wi)/=NULL)then
do while (wildtext(wi:wi) == '*') ! The tame way: unique up on it!
wi=wi+1 ! "x" matches "x*"
if(wildtext(wi:wi)==NULL)exit
enddo
endif
if (wildtext(wi:wi)==NULL)then
glob=.true.
return ! "x" matches "x"
endif
glob=.false.
return ! "x" doesn't match "xy"
endif
enddo
end function glob
!> 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
!> 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
elemental 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)/=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
!> Check that a module name fits the current naming rules:
!> 1) It must be a valid FORTRAN name (<=63 chars, begin with letter, "_" is only allowed non-alphanumeric)
!> 2) It must begin with the package name
!> 3) If longer, package name must be followed by default separator plus at least one char
logical function is_valid_module_name(module_name,package_name,custom_prefix,enforce_module_names) result(valid)
type(string_t), intent(in) :: module_name
type(string_t), intent(in) :: package_name
type(string_t), intent(in) :: custom_prefix
logical , intent(in) :: enforce_module_names
!> Basic check: check the name is Fortran-compliant
valid = is_fortran_name(module_name%s); if (.not.valid) return
!> FPM package enforcing: check that the module name begins with the package name
if (enforce_module_names) then
! Default prefixing is always valid
valid = has_valid_standard_prefix(module_name,package_name)
! If a custom prefix was validated, it provides additional naming options
! Because they never overlap with the default prefix, the former is always an option
if (len_trim(custom_prefix)>0 .and. .not.valid) &
valid = has_valid_custom_prefix(module_name,custom_prefix)
end if
end function is_valid_module_name
!> Check that a custom module prefix fits the current naming rules:
!> 1) Only alphanumeric characters (no spaces, dashes, underscores or other characters)
!> 2) Does not begin with a number (Fortran-compatible syntax)
logical function is_valid_module_prefix(module_prefix) result(valid)
type(string_t), intent(in) :: module_prefix
character(len=*),parameter :: num='0123456789'
character(len=*),parameter :: lower='abcdefghijklmnopqrstuvwxyz'
character(len=*),parameter :: upper='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
character(len=*),parameter :: alpha =upper//lower
character(len=*),parameter :: allowed=alpha//num
character(len=:),allocatable :: name
name = trim(module_prefix%s)
if (len(name)>0 .and. len(name)<=63) then
valid = verify(name(1:1), alpha) == 0 .and. &
verify(name,allowed) == 0
else
valid = .false.
endif
end function is_valid_module_prefix
type(string_t) function module_prefix_template(project_name,custom_prefix) result(prefix)
type(string_t), intent(in) :: project_name
type(string_t), intent(in) :: custom_prefix
if (is_valid_module_prefix(custom_prefix)) then
prefix = string_t(trim(custom_prefix%s)//"_")
else
prefix = string_t(to_fortran_name(project_name%s)//"__")
end if
end function module_prefix_template
type(string_t) function module_prefix_type(project_name,custom_prefix) result(ptype)
type(string_t), intent(in) :: project_name
type(string_t), intent(in) :: custom_prefix
if (is_valid_module_prefix(custom_prefix)) then
ptype = string_t("custom")
else
ptype = string_t("default")
end if
end function module_prefix_type
!> Check that a module name is prefixed with a custom prefix:
!> 1) It must be a valid FORTRAN name subset (<=63 chars, begin with letter, only alphanumeric allowed)
!> 2) It must begin with the prefix
!> 3) If longer, package name must be followed by default separator ("_") plus at least one char
logical function has_valid_custom_prefix(module_name,custom_prefix) result(valid)
type(string_t), intent(in) :: module_name
type(string_t), intent(in) :: custom_prefix
!> custom_module separator: single underscore
character(*), parameter :: SEP = "_"
logical :: is_same,has_separator,same_beginning
integer :: lpkg,lmod,lsep
!> Basic check: check that both names are individually valid
valid = is_fortran_name(module_name%s) .and. &
is_valid_module_prefix(custom_prefix)
!> FPM package enforcing: check that the module name begins with the custom prefix
if (valid) then
!> Query string lengths
lpkg = len_trim(custom_prefix)
lmod = len_trim(module_name)
lsep = len_trim(SEP)
same_beginning = str_begins_with_str(module_name%s,custom_prefix%s,case_sensitive=.false.)
is_same = lpkg==lmod .and. same_beginning
if (lmod>=lpkg+lsep) then
has_separator = str_begins_with_str(module_name%s(lpkg+1:lpkg+lsep),SEP)
else
has_separator = .false.
endif
!> 2) It must begin with the package name.
!> 3) It can be equal to the package name, or, if longer, must be followed by the
! default separator plus at least one character
!> 4) Package name must not end with an underscore
valid = same_beginning .and. (is_same .or. (lmod>lpkg+lsep .and. has_separator))
end if
end function has_valid_custom_prefix
!> Check that a module name is prefixed with the default package prefix:
!> 1) It must be a valid FORTRAN name (<=63 chars, begin with letter, "_" is only allowed non-alphanumeric)
!> 2) It must begin with the package name
!> 3) If longer, package name must be followed by default separator plus at least one char
logical function has_valid_standard_prefix(module_name,package_name) result(valid)
type(string_t), intent(in) :: module_name
type(string_t), intent(in) :: package_name
!> Default package__module separator: two underscores
character(*), parameter :: SEP = "__"
character(len=:), allocatable :: fortranized_pkg
logical :: is_same,has_separator,same_beginning
integer :: lpkg,lmod,lsep
!> Basic check: check the name is Fortran-compliant
valid = is_fortran_name(module_name%s)
!> FPM package enforcing: check that the module name begins with the package name
if (valid) then
fortranized_pkg = to_fortran_name(package_name%s)
!> Query string lengths
lpkg = len_trim(fortranized_pkg)
lmod = len_trim(module_name)
lsep = len_trim(SEP)
same_beginning = str_begins_with_str(module_name%s,fortranized_pkg,case_sensitive=.false.)
is_same = lpkg==lmod .and. same_beginning
if (lmod>=lpkg+lsep) then
has_separator = str_begins_with_str(module_name%s(lpkg+1:lpkg+lsep),SEP)
else
has_separator = .false.
endif
!> 2) It must begin with the package name.
!> 3) It can be equal to the package name, or, if longer, must be followed by the
! default separator plus at least one character
!> 4) Package name must not end with an underscore
valid = is_fortran_name(fortranized_pkg) .and. &
fortranized_pkg(lpkg:lpkg)/='_' .and. &
(same_beginning .and. (is_same .or. (lmod>lpkg+lsep .and. has_separator)))
end if
end function has_valid_standard_prefix
!> Check that two string _objects_ are exactly identical
pure logical function string_is_same(this,that)
!> two strings to be compared
type(string_t), intent(in) :: this, that
integer :: i
string_is_same = .false.
if (allocated(this%s).neqv.allocated(that%s)) return
if (allocated(this%s)) then
if (.not.len(this%s)==len(that%s)) return
if (.not.len_trim(this%s)==len_trim(that%s)) return
do i=1,len_trim(this%s)
if (.not.(this%s(i:i)==that%s(i:i))) return
end do
end if
! All checks passed
string_is_same = .true.
end function string_is_same
!> Check that two allocatable string _object_ arrays are exactly identical
pure logical function string_arrays_same(this,that)
!> two string arrays to be compared
type(string_t), allocatable, intent(in) :: this(:), that(:)
integer :: i
string_arrays_same = .false.
if (allocated(this).neqv.allocated(that)) return
if (allocated(this)) then
if (.not.(size(this)==size(that))) return
if (.not.(ubound(this,1)==ubound(that,1))) return
if (.not.(lbound(this,1)==lbound(that,1))) return
do i=lbound(this,1),ubound(this,1)
if (.not.string_is_same(this(i),that(i))) return
end do
end if
! All checks passed
string_arrays_same = .true.
end function string_arrays_same
! Remove all characters from a set from a string
subroutine remove_characters_in_set(string,set,replace_with)
character(len=:), allocatable, intent(inout) :: string
character(*), intent(in) :: set
character, optional, intent(in) :: replace_with ! Replace with this character instead of removing
integer :: feed,length
if (.not.allocated(string)) return
if (len(set)<=0) return
length = len(string)
feed = scan(string,set)
do while (length>0 .and. feed>0)
! Remove heading
if (length==1) then
string = ""
elseif (feed==1) then
string = string(2:length)
! Remove trailing
elseif (feed==length) then
string = string(1:length-1)
! In between: replace with given character
elseif (present(replace_with)) then
string(feed:feed) = replace_with
! Or just remove
else
string = string(1:feed-1)//string(feed+1:length)
end if
length = len(string)
feed = scan(string,set)
end do
end subroutine remove_characters_in_set
! Remove all new line characters from the current string, replace them with spaces
subroutine remove_newline_characters(string)
type(string_t), intent(inout) :: string
integer :: feed,length
character(*), parameter :: CRLF = achar(13)//new_line('a')
character(*), parameter :: SPACE = ' '
call remove_characters_in_set(string%s,set=CRLF,replace_with=SPACE)
end subroutine remove_newline_characters
!>AUTHOR: John S. Urban
!!LICENSE: Public Domain
!>
!!### NAME
!! notabs(3f) - [fpm_strings:NONALPHA] expand tab characters
!! (LICENSE:PD)
!!
!!### SYNOPSIS
!!
!! subroutine notabs(INSTR,OUTSTR,ILEN)
!!
!! character(len=*),intent=(in) :: INSTR
!! character(len=*),intent=(out) :: OUTSTR
!! integer,intent=(out) :: ILEN
!!
!!### DESCRIPTION
!! NOTABS() converts tabs in INSTR to spaces in OUTSTR while maintaining
!! columns. It assumes a tab is set every 8 characters. Trailing spaces
!! are removed.
!!
!! In addition, trailing carriage returns and line feeds are removed
!! (they are usually a problem created by going to and from MSWindows).
!!
!! What are some reasons for removing tab characters from an input line?
!! Some Fortran compilers have problems with tabs, as tabs are not
!! part of the Fortran character set. Some editors and printers will
!! have problems with tabs. It is often useful to expand tabs in input
!! files to simplify further processing such as tokenizing an input line.
!!
!!### OPTIONS
!! instr Input line to remove tabs from
!!
!!### RESULTS
!! outstr Output string with tabs expanded. Assumed to be of sufficient
!! length
!! ilen Significant length of returned string
!!
!!### EXAMPLES
!!
!! Sample program:
!!
!! program demo_notabs
!!
!! ! test filter to remove tabs and trailing white space from input
!! ! on files up to 1024 characters wide
!! use fpm_strings, only : notabs
!! character(len=1024) :: in,out
!! integer :: ios,iout
!! do
!! read(*,'(A)',iostat=ios)in
!! if(ios /= 0) exit
!! call notabs(in,out,iout)
!! write(*,'(a)')out(:iout)
!! enddo
!! end program demo_notabs
!!
!!### SEE ALSO
!! GNU/Unix commands expand(1) and unexpand(1)
!!
elemental impure subroutine notabs(instr,outstr,ilen)
! ident_31="@(#)fpm_strings::notabs(3f): convert tabs to spaces while maintaining columns, remove CRLF chars"
character(len=*),intent(in) :: instr ! input line to scan for tab characters
character(len=*),intent(out) :: outstr ! tab-expanded version of INSTR produced
integer,intent(out) :: ilen ! column position of last character put into output string
! that is, ILEN holds the position of the last non-blank character in OUTSTR
integer,parameter :: tabsize=8 ! assume a tab stop is set every 8th column
integer :: ipos ! position in OUTSTR to put next character of INSTR
integer :: lenin ! length of input string trimmed of trailing spaces
integer :: lenout ! number of characters output string can hold
integer :: istep ! counter that advances thru input string INSTR one character at a time
character(len=1) :: c ! character in input line being processed
integer :: iade ! ADE (ASCII Decimal Equivalent) of character being tested
ipos=1 ! where to put next character in output string OUTSTR
lenin=len_trim(instr( 1:len(instr) )) ! length of INSTR trimmed of trailing spaces
lenout=len(outstr) ! number of characters output string OUTSTR can hold
outstr=" " ! this SHOULD blank-fill string, a buggy machine required a loop to set all characters
SCAN_LINE: do istep=1,lenin ! look through input string one character at a time
c=instr(istep:istep) ! get next character
iade=ichar(c) ! get ADE of the character
EXPAND_TABS : select case (iade) ! take different actions depending on which character was found
case(9) ! test if character is a tab and move pointer out to appropriate column
ipos = ipos + (tabsize - (mod(ipos-1,tabsize)))
case(10,13) ! convert carriage-return and new-line to space ,typically to handle DOS-format files
ipos=ipos+1
case default ! c is anything else other than a tab,newline,or return insert it in output string
if(ipos > lenout)then
write(stderr,*)"*notabs* output string overflow"
exit
else
outstr(ipos:ipos)=c
ipos=ipos+1
endif
end select EXPAND_TABS
enddo SCAN_LINE
ipos=min(ipos,lenout) ! tabs or newline or return characters or last character might have gone too far
ilen=len_trim(outstr(:ipos)) ! trim trailing spaces
end subroutine notabs
!>AUTHOR: John S. Urban
!!LICENSE: Public Domain
!>
!!##NAME
!! dilate(3f) - [M_strings:NONALPHA] expand tab characters
!! (LICENSE:PD)
!!
!!##SYNOPSIS
!!
!! function dilate(INSTR) result(OUTSTR)
!!
!! character(len=*),intent=(in) :: INSTR
!! character(len=:),allocatable :: OUTSTR
!!
!!##DESCRIPTION
!! dilate() converts tabs in INSTR to spaces in OUTSTR. It assumes a
!! tab is set every 8 characters. Trailing spaces are removed.
!!
!! In addition, trailing carriage returns and line feeds are removed
!! (they are usually a problem created by going to and from MSWindows).
!!
!!##OPTIONS
!! instr Input line to remove tabs from
!!
!!##RESULTS
!! outstr Output string with tabs expanded.
!!
!!##EXAMPLES
!!
!! Sample program:
!!
!! program demo_dilate
!!
!! use M_strings, only : dilate
!! implicit none
!! character(len=:),allocatable :: in
!! integer :: i
!! in=' this is my string '
!! ! change spaces to tabs to make a sample input
!! do i=1,len(in)
!! if(in(i:i) == ' ')in(i:i)=char(9)
!! enddo
!! write(*,'(a)')in,dilate(in)
!! end program demo_dilate
!!
function dilate(instr) result(outstr)
character(len=*), intent(in) :: instr ! input line to scan for tab characters
character(len=:), allocatable :: outstr ! tab-expanded version of INSTR produced
integer :: i
integer :: icount
integer :: lgth
icount = 0
do i = 1, len(instr)
if (instr(i:i) == char(9)) icount = icount + 1
end do
allocate (character(len=(len(instr) + 8*icount)) :: outstr)
call notabs(instr, outstr, lgth)
outstr = outstr(:lgth)
end function dilate
!> Check if feature name is valid (alphanumeric, underscore, dash allowed)
logical function is_valid_feature_name(name) result(valid)
character(len=*), intent(in) :: name
integer :: i
character :: c
valid = .false.
! Must not be empty and not too long
if (len_trim(name) == 0 .or. len_trim(name) > 64) return
! First character must be alphabetic or underscore
c = name(1:1)
if (.not. ((c >= 'a' .and. c <= 'z') .or. (c >= 'A' .and. c <= 'Z') .or. c == '_')) return
! Remaining characters can be alphanumeric, underscore, or dash
do i = 2, len_trim(name)
c = name(i:i)
if (.not. ((c >= 'a' .and. c <= 'z') .or. (c >= 'A' .and. c <= 'Z') .or. &
(c >= '0' .and. c <= '9') .or. c == '_' .or. c == '-')) then
return
end if
end do
valid = .true.
end function is_valid_feature_name
!> Add one element to a string array with a loop (gcc-15 bug on array initializer)
pure subroutine add_strings_one(list,new)
type(string_t), allocatable, intent(inout) :: list(:)
type(string_t), intent(in) :: new
integer :: i,n
type(string_t), allocatable :: tmp(:)
if (allocated(list)) then
n = size(list)
else
n = 0
endif
allocate(tmp(n+1))
do i=1,n
tmp(i) = list(i)
end do
tmp(n+1) = new
call move_alloc(from=tmp,to=list)
end subroutine add_strings_one
!> Add elements to a string array with a loop (gcc-15 bug on array initializer)
pure subroutine add_strings_many(list,new)
type(string_t), allocatable, intent(inout) :: list(:)
type(string_t), intent(in) :: new(:)
integer :: i,n,add
type(string_t), allocatable :: tmp(:)
if (allocated(list)) then
n = size(list)
else
n = 0
endif
add = size(new)
if (add<=0) return
allocate(tmp(n+add))
do i=1,n
tmp(i) = list(i)
end do
do i=1,add
tmp(n+i) = new(i)
end do
call move_alloc(from=tmp,to=list)
end subroutine add_strings_many
end module fpm_strings
fortran-lang-fpm-90bb83a/src/fpm_pkg_config.f90 0000664 0001750 0001750 00000024323 15145116760 021553 0 ustar alastair alastair !># The fpm interface to pkg-config
!>
!> This module contains wrapper functions to interface with a pkg-config installation.
!>
module fpm_pkg_config
use fpm_strings, only: string_t,str_begins_with_str,len_trim,remove_newline_characters, &
split
use fpm_error, only: error_t, fatal_error, fpm_stop
use fpm_filesystem, only: get_temp_filename,getline
use fpm_environment, only: get_env,os_is_unix,set_env,delete_env
use shlex_module, only: shlex_split => split
implicit none
private
public :: assert_pkg_config
public :: pkgcfg_get_version
public :: pkgcfg_get_libs
public :: pkgcfg_get_build_flags
public :: pkgcfg_has_package
public :: pkgcfg_list_all
public :: run_wrapper
contains
!> Check whether pkg-config is available on the local system
logical function assert_pkg_config()
integer :: exitcode
logical :: success
type(string_t) :: log
call run_wrapper(wrapper=string_t('pkg-config'),args=[string_t('-h')], &
exitcode=exitcode,cmd_success=success,screen_output=log)
assert_pkg_config = exitcode==0 .and. success
end function assert_pkg_config
!> Get package version from pkg-config
type(string_t) function pkgcfg_get_version(package,error) result(screen)
!> Package name
character(*), intent(in) :: package
!> Error handler
type(error_t), allocatable, intent(out) :: error
integer :: exitcode
logical :: success
type(string_t) :: log
call run_wrapper(wrapper=string_t('pkg-config'), &
args=[string_t(package),string_t('--modversion')], &
exitcode=exitcode,cmd_success=success,screen_output=log)
if (success .and. exitcode==0) then
call remove_newline_characters(log)
screen = log
else
screen = string_t("")
end if
end function pkgcfg_get_version
!> Check if pkgcfg has package
logical function pkgcfg_has_package(name) result(success)
!> Package name
character(*), intent(in) :: name
integer :: exitcode
logical :: cmdok
type(string_t) :: log
call run_wrapper(wrapper=string_t('pkg-config'), &
args=[string_t(name),string_t('--exists')], &
exitcode=exitcode,cmd_success=cmdok,screen_output=log)
!> pkg-config --exists returns 0 only if the package exists
success = cmdok .and. exitcode==0
end function pkgcfg_has_package
!> Get package libraries from pkg-config
function pkgcfg_get_libs(package,error) result(libraries)
!> Package name
character(*), intent(in) :: package
!> Error handler
type(error_t), allocatable, intent(out) :: error
!> A list of libraries
type(string_t), allocatable :: libraries(:)
integer :: exitcode,nlib,i
logical :: success
character(len=:), allocatable :: tokens(:)
type(string_t) :: log
call run_wrapper(wrapper=string_t('pkg-config'), &
args=[string_t(package),string_t('--libs')], &
exitcode=exitcode,cmd_success=success,screen_output=log)
if (success .and. exitcode==0) then
call remove_newline_characters(log)
! Split all arguments
tokens = shlex_split(log%s)
nlib = size(tokens)
allocate(libraries(nlib))
do i=1,nlib
libraries(i) = string_t(trim(adjustl(tokens(i))))
end do
else
allocate(libraries(0))
call fatal_error(error,'cannot get <'//package//'> libraries from pkg-config')
end if
end function pkgcfg_get_libs
!> Return whole list of available pkg-cfg packages
function pkgcfg_list_all(error,descriptions) result(modules)
!> Error handler
type(error_t), allocatable, intent(out) :: error
!> A list of all available packages
type(string_t), allocatable :: modules(:)
!> An optional list of package descriptions
type(string_t), optional, allocatable, intent(out) :: descriptions(:)
integer :: exitcode,i,spc
logical :: success
character(len=:), allocatable :: lines(:)
type(string_t) :: log
type(string_t), allocatable :: mods(:),descr(:)
character(*), parameter :: CRLF = achar(13)//new_line('a')
call run_wrapper(wrapper=string_t('pkg-config'), &
args=[string_t('--list-all')], &
exitcode=exitcode,cmd_success=success,screen_output=log)
if (.not.(success .and. exitcode==0)) then
call fatal_error(error,'cannot get pkg-config modules')
allocate(modules(0))
return
end if
!> Extract list
call split(log%s,lines,CRLF)
allocate(mods(size(lines)),descr(size(lines)))
do i=1,size(lines)
! Module names have no spaces
spc = index(lines(i),' ')
if (spc>0) then
mods(i) = string_t(trim(adjustl(lines(i)(1:spc))))
descr(i) = string_t(trim(adjustl(lines(i)(spc+1:))))
else
mods(i) = string_t(trim(adjustl(lines(i))))
descr(i) = string_t("")
end if
end do
call move_alloc(from=mods,to=modules)
if (present(descriptions)) call move_alloc(from=descr,to=descriptions)
end function pkgcfg_list_all
!> Get build flags (option to include flags from system directories, that
!> gfortran does not look into by default)
function pkgcfg_get_build_flags(name,allow_system,error) result(flags)
!> Package name
character(*), intent(in) :: name
!> Should pkg-config look in system paths? This is necessary for gfortran
!> that doesn't otherwise look into them
logical, intent(in) :: allow_system
!> Error flag
type(error_t), allocatable, intent(out) :: error
!> List of compile flags
type(string_t), allocatable :: flags(:)
integer :: exitcode,i,nlib
logical :: old_had,success,old_allow
character(:), allocatable :: old,tokens(:)
type(string_t) :: log
! Check if the current environment includes system flags
old = get_env('PKG_CONFIG_ALLOW_SYSTEM_CFLAGS',default='ERROR')
old_had = old/='ERROR'
old_allow = merge(old=='1',.false.,old_had)
! Set system flags
success = set_env('PKG_CONFIG_ALLOW_SYSTEM_CFLAGS',value=merge('1','0',allow_system))
if (.not.success) then
call fatal_error(error,'Cannot get pkg-config build flags: environment variable error.')
return
end if
! Now run wrapper
call run_wrapper(wrapper=string_t('pkg-config'), &
args=[string_t(name),string_t('--cflags')], &
exitcode=exitcode,cmd_success=success,screen_output=log)
if (success .and. exitcode==0) then
call remove_newline_characters(log)
! Split all arguments
tokens = shlex_split(log%s)
nlib = size(tokens)
allocate(flags(nlib))
do i=1,nlib
flags(i) = string_t(trim(adjustl(tokens(i))))
end do
else
allocate(flags(0))
call fatal_error(error,'cannot get <'//name//'> build flags from pkg-config')
end if
! Restore environment variable
if (old_had) then
success = set_env('PKG_CONFIG_ALLOW_SYSTEM_CFLAGS',value=old)
else
success = delete_env('PKG_CONFIG_ALLOW_SYSTEM_CFLAGS')
end if
if (.not.success) then
call fatal_error(error,'Cannot get pkg-config build flags: environment variable error.')
return
end if
end function pkgcfg_get_build_flags
!> Simple call to execute_command_line involving one mpi* wrapper
subroutine run_wrapper(wrapper,args,verbose,exitcode,cmd_success,screen_output)
type(string_t), intent(in) :: wrapper
type(string_t), intent(in), optional :: args(:)
logical, intent(in), optional :: verbose
integer, intent(out), optional :: exitcode
logical, intent(out), optional :: cmd_success
type(string_t), intent(out), optional :: screen_output
logical :: echo_local
character(:), allocatable :: redirect_str,command,redirect,line
integer :: iunit,iarg,stat,cmdstat
if(present(verbose))then
echo_local=verbose
else
echo_local=.false.
end if
! No redirection and non-verbose output
if (present(screen_output)) then
redirect = get_temp_filename()
redirect_str = ">"//redirect//" 2>&1"
else
if (os_is_unix()) then
redirect_str = " >/dev/null 2>&1"
else
redirect_str = " >NUL 2>&1"
end if
end if
! Empty command
if (len_trim(wrapper)<=0) then
if (echo_local) print *, '+ '
if (present(exitcode)) exitcode = 0
if (present(cmd_success)) cmd_success = .true.
if (present(screen_output)) screen_output = string_t("")
return
end if
! Init command
command = trim(wrapper%s)
add_arguments: if (present(args)) then
do iarg=1,size(args)
if (len_trim(args(iarg))<=0) cycle
command = trim(command)//' '//args(iarg)%s
end do
endif add_arguments
if (echo_local) print *, '+ ', command
! Test command
call execute_command_line(command//redirect_str,exitstat=stat,cmdstat=cmdstat)
! Command successful?
if (present(cmd_success)) cmd_success = cmdstat==0
! Program exit code?
if (present(exitcode)) exitcode = stat
! Want screen output?
if (present(screen_output) .and. cmdstat==0) then
allocate(character(len=0) :: screen_output%s)
open(newunit=iunit,file=redirect,status='old',iostat=stat)
if (stat == 0)then
do
call getline(iunit, line, stat)
if (stat /= 0) exit
screen_output%s = screen_output%s//new_line('a')//line
if (echo_local) write(*,'(A)') trim(line)
end do
! Close and delete file
close(iunit,status='delete')
else
call fpm_stop(1,'cannot read temporary file from successful command: '//command)
endif
end if
end subroutine run_wrapper
end module fpm_pkg_config
fortran-lang-fpm-90bb83a/src/fpm_backend.F90 0000664 0001750 0001750 00000031401 15145116760 020767 0 ustar alastair alastair !># 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,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit
use fpm_error, only : fpm_stop, error_t
use fpm_filesystem, only: basename, dirname, join_path, exists, mkdir, run, getline
use fpm_model, only: fpm_model_t
use fpm_strings, only: string_t, operator(.in.)
use fpm_targets, only: build_target_t, build_target_ptr, FPM_TARGET_OBJECT, &
FPM_TARGET_C_OBJECT, FPM_TARGET_ARCHIVE, FPM_TARGET_EXECUTABLE, &
FPM_TARGET_CPP_OBJECT, FPM_TARGET_SHARED
use fpm_backend_output
use fpm_compile_commands, only: compile_command_table_t
implicit none
private
public :: build_package, sort_target, schedule_targets
#ifndef FPM_BOOTSTRAP
interface
function c_isatty() bind(C, name = 'c_isatty')
use, intrinsic :: iso_c_binding, only: c_int
integer(c_int) :: c_isatty
end function
end interface
#endif
contains
!> Top-level routine to build package described by `model`
subroutine build_package(targets,model,verbose,dry_run)
type(build_target_ptr), intent(inout) :: targets(:)
type(fpm_model_t), intent(in) :: model
logical, intent(in) :: verbose
!> If dry_run, the build process is only mocked, but the list of compile_commands
!> is still created
logical, intent(in) :: dry_run
integer :: i, j
type(build_target_ptr), allocatable :: queue(:)
integer, allocatable :: schedule_ptr(:), stat(:)
logical :: build_failed, skip_current
type(string_t), allocatable :: build_dirs(:)
type(string_t) :: temp
type(error_t), allocatable :: error
type(build_progress_t) :: progress
logical :: plain_output
! Need to make output directory for include (mod) files
allocate(build_dirs(0))
do i = 1, size(targets)
associate(target => targets(i)%ptr)
if (target%output_dir .in. build_dirs) cycle
temp%s = target%output_dir
build_dirs = [build_dirs, temp]
end associate
end do
do i = 1, size(build_dirs)
if (.not.dry_run) call mkdir(build_dirs(i)%s,verbose)
end do
! Perform depth-first topological sort of targets
do i=1,size(targets)
call sort_target(targets(i)%ptr, dry_run)
end do
! Construct build schedule queue
call schedule_targets(queue, schedule_ptr, targets)
! Check if queue is empty
if (.not.verbose .and. size(queue) < 1 .and. .not.dry_run) then
write(stderr, '(a)') 'Project is up to date'
return
end if
! Initialise build status flags
allocate(stat(size(queue)),source=0)
build_failed = .false.
! Set output mode
#ifndef FPM_BOOTSTRAP
plain_output = (.not.(c_isatty()==1)) .or. verbose
#else
plain_output = .true.
#endif
progress = build_progress_t(queue,plain_output,model%build_dir)
! Loop over parallel schedule regions
do i=1,size(schedule_ptr)-1
! Build targets in schedule region i
!$omp parallel do default(shared) private(skip_current) schedule(dynamic,1)
do j=schedule_ptr(i),(schedule_ptr(i+1)-1)
! Check if build already failed
!$omp atomic read
skip_current = build_failed
if (.not.skip_current) then
if (.not.dry_run) call progress%compiling_status(j)
call build_target(model,queue(j)%ptr,verbose,dry_run, &
progress%compile_commands,stat(j))
if (.not.dry_run) call progress%completed_status(j,stat(j))
end if
! Set global flag if this target failed to build
if (stat(j) /= 0) then
!$omp atomic write
build_failed = .true.
end if
end do
! Check if this schedule region failed: exit with message if failed
if (build_failed) then
write(*,*)
do j=1,size(stat)
if (stat(j) /= 0) Then
call print_build_log(queue(j)%ptr)
end if
end do
do j=1,size(stat)
if (stat(j) /= 0) then
write(stderr,'(*(g0:,1x))') ' Compilation failed for object "',basename(queue(j)%ptr%output_file),'"'
end if
end do
call fpm_stop(1,'stopping due to failed compilation')
end if
end do
if (.not.dry_run) call progress%success()
call progress%dump_commands(error)
if (allocated(error)) call fpm_stop(1,'error writing compile_commands.json: '//trim(error%message))
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, mock)
type(build_target_t), intent(inout), target :: target
!> Optionally sort ALL targets if this is a dry run
logical, optional, intent(in) :: mock
integer :: i, fh, stat
logical :: dry_run
dry_run = .false.
if (present(mock)) dry_run = mock
! Check if target has already been processed (as a dependency)
if (target%sorted .or. target%skip) return
! Check for a circular dependency
! (If target has been touched but not processed)
if (target%touched) then
call fpm_stop(1,'(!) Circular dependency found with: '//target%output_file)
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') .and. &
(.not.dry_run)) then
allocate(target%digest_cached)
open(newunit=fh,file=target%output_file//'.digest',status='old')
read(fh,*,iostat=stat) target%digest_cached
close(fh)
! Cached digest is not recognized
if (stat /= 0) deallocate(target%digest_cached)
end if
if (dry_run) then
target%skip = .false.
elseif (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, dry_run)
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,verbose,dry_run,table,stat)
type(fpm_model_t), intent(in) :: model
type(build_target_t), intent(in), target :: target
logical, intent(in) :: verbose
!> If dry_run, the build process is only mocked, but compile_commands are still created
logical, intent(in) :: dry_run
type(compile_command_table_t), intent(inout) :: table
integer, intent(out) :: stat
integer :: fh
!$omp critical
if (.not.exists(dirname(target%output_file)) .and. .not.dry_run) then
call mkdir(dirname(target%output_file),verbose)
end if
!$omp end critical
select case(target%target_type)
case (FPM_TARGET_OBJECT)
call model%compiler%compile_fortran(target%source%file_name, target%output_file, &
& target%compile_flags, target%output_log_file, stat, table, dry_run)
case (FPM_TARGET_C_OBJECT)
call model%compiler%compile_c(target%source%file_name, target%output_file, &
& target%compile_flags, target%output_log_file, stat, table, dry_run)
case (FPM_TARGET_CPP_OBJECT)
call model%compiler%compile_cpp(target%source%file_name, target%output_file, &
& target%compile_flags, target%output_log_file, stat, table, dry_run)
case (FPM_TARGET_EXECUTABLE)
call model%compiler%link(target%output_file, &
& target%compile_flags//" "//target%link_flags, target%output_log_file, stat, dry_run)
case (FPM_TARGET_ARCHIVE)
call model%archiver%make_archive(target%output_file, target%link_objects, &
& target%output_log_file, stat, dry_run)
case (FPM_TARGET_SHARED)
call model%compiler%link_shared(target%output_file, target%link_flags, &
& target%output_log_file, stat, dry_run)
end select
if (stat == 0 .and. allocated(target%source) .and. .not.dry_run) then
open(newunit=fh,file=target%output_file//'.digest',status='unknown')
write(fh,*) target%source%digest
close(fh)
end if
end subroutine build_target
!> Read and print the build log for target
!>
subroutine print_build_log(target)
type(build_target_t), intent(in), target :: target
integer :: fh, ios
character(:), allocatable :: line
if (exists(target%output_log_file)) then
open(newunit=fh,file=target%output_log_file,status='old')
do
call getline(fh, line, ios)
if (ios /= 0) exit
write(*,'(A)') trim(line)
end do
close(fh)
else
write(stderr,'(*(g0:,1x))') ' Unable to find build log "',basename(target%output_log_file),'"'
end if
end subroutine print_build_log
end module fpm_backend
fortran-lang-fpm-90bb83a/src/fpm_targets.f90 0000664 0001750 0001750 00000163341 15145116760 021122 0 ustar alastair alastair !># 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, stdout=>output_unit
use fpm_error, only: error_t, fatal_error, fpm_stop
use fpm_model
use fpm_compiler, only : compiler_t
use fpm_environment, only: get_os_type, OS_WINDOWS, OS_MACOS, library_filename
use fpm_filesystem, only: dirname, join_path, canon_path
use fpm_strings, only: string_t, operator(.in.), string_cat, fnv_1a, resize, lower, str_ends_with, &
add_strings
use fpm_compiler, only: get_macros, is_cxx_gnu_based
use fpm_sources, only: get_exe_name_with_suffix
use fpm_manifest_library, only: library_config_t
use fpm_manifest_preprocess, only: preprocess_config_t
use fpm_versioning, only: version_t, new_version
implicit none
private
public FPM_TARGET_UNKNOWN, FPM_TARGET_EXECUTABLE, &
FPM_TARGET_ARCHIVE, FPM_TARGET_OBJECT, &
FPM_TARGET_C_OBJECT, FPM_TARGET_CPP_OBJECT, &
FPM_TARGET_SHARED, FPM_TARGET_NAME
public build_target_t, build_target_ptr
public targets_from_sources, resolve_module_dependencies
public add_target, new_target, add_dependency, get_library_dirs, add_target_ptr
public filter_library_targets, filter_executable_targets, filter_modules
!> 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
!> Target type is c compiled object
integer, parameter :: FPM_TARGET_C_OBJECT = 4
!> Target type is cpp compiled object
integer, parameter :: FPM_TARGET_CPP_OBJECT = 5
!> Target type is a shared library
integer, parameter :: FPM_TARGET_SHARED = 6
!> 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
!> File path of build target object relative to output_dir
character(:), allocatable :: output_name
!> File path of output directory
character(:), allocatable :: output_dir
!> File path of build log file relative to cwd
character(:), allocatable :: output_log_file
!> Name of parent package
character(:), allocatable :: package_name
!> 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.
!> Language features
type(fortran_config_t) :: features
!> Targets in the same schedule group are guaranteed to be independent
integer :: schedule = -1
!> Previous source file hash
integer(int64), allocatable :: digest_cached
!> List of macros
type(string_t), allocatable :: macros(:)
!> Version number
type(version_t), allocatable :: version
contains
!> Print information on this instance
procedure :: info
!> Set output directory
procedure :: set_output_dir
procedure :: is_executable_target
end type build_target_t
interface add_target
module procedure add_new_target
module procedure add_old_target
module procedure add_old_targets
end interface
!> Add one or multiple build target pointers to array (gcc-15 bug workaround)
interface add_target_ptr
module procedure add_target_ptr_one
module procedure add_target_ptr_many
end interface add_target_ptr
contains
!> Target type name
pure function FPM_TARGET_NAME(type) result(msg)
integer, intent(in) :: type
character(:), allocatable :: msg
select case (type)
case (FPM_TARGET_ARCHIVE); msg = 'Archive'
case (FPM_TARGET_SHARED); msg = 'Shared library'
case (FPM_TARGET_CPP_OBJECT); msg = 'C++ object'
case (FPM_TARGET_C_OBJECT); msg = 'C Object'
case (FPM_TARGET_EXECUTABLE); msg = 'Executable'
case (FPM_TARGET_OBJECT); msg = 'Object'
case default; msg = 'Unknown'
end select
end function FPM_TARGET_NAME
!> Write information on a build target
subroutine info(self, unit, verbosity)
class(build_target_t), intent(in) :: self
integer, intent(in) :: unit
integer, intent(in), optional :: verbosity
integer :: pr
character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)'
character(len=*), parameter :: fmt_list = '("#", 1x, a, t30, a, " (", i0, " items)")'
if (present(verbosity)) then
pr = verbosity
else
pr = 1
end if
if (pr < 1) return
write(unit, fmt) "Build target"
write(unit, fmt) "- output file", self%output_file
write(unit, fmt) "- output name", self%output_name
write(unit, fmt) "- output directory", self%output_dir
write(unit, fmt) "- log file", self%output_log_file
write(unit, fmt) "- package", self%package_name
write(unit, fmt) "- type", FPM_TARGET_NAME(self%target_type)
if (allocated(self%source)) then
write(unit, fmt) "- source file", self%source%file_name
end if
if (allocated(self%dependencies)) then
write(unit, fmt_list) "- dependencies", "", size(self%dependencies)
end if
if (allocated(self%link_objects)) then
write(unit, fmt_list) "- link objects", "", size(self%link_objects)
end if
if (allocated(self%link_libraries)) then
write(unit, fmt_list) "- link libraries", "", size(self%link_libraries)
end if
if (allocated(self%compile_flags)) then
write(unit, fmt) "- compile flags", self%compile_flags
end if
if (allocated(self%link_flags)) then
write(unit, fmt) "- link flags", self%link_flags
end if
if (allocated(self%version)) then
write(unit, fmt) "- version", self%version%s()
end if
if (allocated(self%macros)) then
write(unit, fmt_list) "- macros", "", size(self%macros)
end if
write(unit, fmt) "- skip", merge("yes", "no ", self%skip)
write(unit, fmt) "- schedule", trim(adjustl(to_string(self%schedule)))
contains
pure function to_string(i) result(s)
integer, intent(in) :: i
character(len=32) :: s
write(s, '(i0)') i
end function to_string
end subroutine info
!> High-level wrapper to generate build target information
subroutine targets_from_sources(targets,model,prune,library,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
!> Library build configuration
type(library_config_t), intent(in), optional :: library
!> Enable tree-shaking/pruning of module dependencies
logical, intent(in) :: prune
!> Error structure
type(error_t), intent(out), allocatable :: error
logical :: should_prune
call build_target_list(targets,model,library)
call collect_exe_link_dependencies(targets)
call resolve_module_dependencies(targets,model%external_modules,error)
if (allocated(error)) return
! Prune unused source files, unless we're building shared libraries that need
! all sources to be distributable
should_prune = prune
if (present(library)) should_prune = should_prune .and. library%monolithic()
call prune_build_targets(targets,model%packages(1),should_prune)
call resolve_target_linking(targets,model,library,error)
if (allocated(error)) return
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,library)
!> 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
!> The optional model library configuration
type(library_config_t), optional, intent(in) :: library
integer :: i, j, k, n_source, exe_type
character(:), allocatable :: exe_dir, compile_flags, lib_name
logical :: with_lib, monolithic, shared_lib, static_lib, clang_cxx_backend_macos
! Initialize targets
allocate(targets(0))
! 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) return
if (get_os_type()==OS_MACOS) then
clang_cxx_backend_macos = .not. is_cxx_gnu_based(model%compiler)
else
clang_cxx_backend_macos = .false.
endif
with_lib = any(model%packages%has_library())
if (with_lib .and. present(library)) then
shared_lib = library%shared()
static_lib = library%static()
monolithic = library%monolithic()
else
monolithic = with_lib
shared_lib = .false.
static_lib = .false.
end if
! For a static object archive, everything from this package or all its dependencies is
! put into the same file. For a shared library configuration, each package has its own
! dynamic library file to avoid dependency collisions
if (monolithic) then
lib_name = join_path(model%package_name, &
library_filename(model%packages(1)%name,.false.,.false.,get_os_type()))
call add_target(targets,package=model%package_name, &
type = FPM_TARGET_ARCHIVE,output_name = lib_name)
elseif (shared_lib .or. static_lib) then
! Individual package libraries are built.
! Create as many targets as the packages in the dependency tree
do j=1,size(model%packages)
! Create static library target if requested
if (static_lib) then
lib_name = library_filename(model%packages(j)%name,.false.,.false.,get_os_type())
call add_target(targets,package=model%packages(j)%name, &
type=FPM_TARGET_ARCHIVE, &
output_name=lib_name)
end if
! Create shared library target if requested
if (shared_lib) then
lib_name = library_filename(model%packages(j)%name,.true.,.false.,get_os_type())
call add_target(targets,package=model%packages(j)%name, &
type=FPM_TARGET_SHARED, &
output_name=lib_name)
end if
end do
endif
do j=1,size(model%packages)
associate(sources=>model%packages(j)%sources)
do i=1,size(sources)
if (.not. model%include_tests) then
if (sources(i)%unit_scope == FPM_SCOPE_TEST) cycle
end if
select case (sources(i)%unit_type)
case (FPM_UNIT_MODULE,FPM_UNIT_SUBMODULE,FPM_UNIT_SUBPROGRAM,FPM_UNIT_CSOURCE)
call add_target(targets,package=model%packages(j)%name,source = sources(i), &
type = merge(FPM_TARGET_C_OBJECT,FPM_TARGET_OBJECT,&
sources(i)%unit_type==FPM_UNIT_CSOURCE), &
output_name = get_object_name(sources(i)), &
features = model%packages(j)%features, &
preprocess = model%packages(j)%preprocess, &
version = model%packages(j)%version)
if (with_lib .and. sources(i)%unit_scope == FPM_SCOPE_LIB) then
! Library targets depend on object
if (monolithic) then
call add_dependency(targets(1)%ptr, targets(size(targets))%ptr)
elseif (static_lib .and. shared_lib) then
! Both types: static at (2*j-1), shared at (2*j)
call add_dependency(targets(2*j-1)%ptr, targets(size(targets))%ptr)
call add_dependency(targets(2*j)%ptr, targets(size(targets))%ptr)
else
! Single type: package j at index j
call add_dependency(targets(j)%ptr, targets(size(targets))%ptr)
end if
end if
case (FPM_UNIT_CPPSOURCE)
call add_target(targets,package=model%packages(j)%name,source = sources(i), &
type = FPM_TARGET_CPP_OBJECT, &
output_name = get_object_name(sources(i)), &
preprocess = model%packages(j)%preprocess, &
version = model%packages(j)%version)
if (with_lib .and. sources(i)%unit_scope == FPM_SCOPE_LIB) then
! Library targets depend on object
if (monolithic) then
call add_dependency(targets(1)%ptr, targets(size(targets))%ptr)
elseif (static_lib .and. shared_lib) then
! Both types: static at (2*j-1), shared at (2*j)
call add_dependency(targets(2*j-1)%ptr, targets(size(targets))%ptr)
call add_dependency(targets(2*j)%ptr, targets(size(targets))%ptr)
else
! Single type: package j at index j
call add_dependency(targets(j)%ptr, targets(size(targets))%ptr)
end if
end if
!> Add stdc++ as a linker flag. If not already there.
if (.not. ("stdc++" .in. model%link_libraries)) then
if (clang_cxx_backend_macos) then
! On macOS with non-GNU C++ compiler (e.g., Clang), use "c++"
call add_strings(model%link_libraries, string_t("c++"))
else
! For GNU C++ compiler or non-macOS systems, use "stdc++"
call add_strings(model%link_libraries, string_t("stdc++"))
end if
end if
case (FPM_UNIT_PROGRAM)
if (str_ends_with(lower(sources(i)%file_name), [".c"])) then
exe_type = FPM_TARGET_C_OBJECT
else if (str_ends_with(lower(sources(i)%file_name), [".cpp", ".cc "])) then
exe_type = FPM_TARGET_CPP_OBJECT
else ! Default to a Fortran object
exe_type = FPM_TARGET_OBJECT
end if
call add_target(targets,package=model%packages(j)%name,type = exe_type,&
output_name = get_object_name(sources(i)), &
source = sources(i), &
features = model%packages(j)%features, &
preprocess = model%packages(j)%preprocess, &
version = model%packages(j)%version)
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,package=model%packages(j)%name,type = FPM_TARGET_EXECUTABLE,&
link_libraries = sources(i)%link_libraries, &
output_name = join_path(exe_dir,get_exe_name_with_suffix(sources(i))))
associate(target => targets(size(targets))%ptr)
! Linker-only flags are necessary on some compilers for codes with non-Fortran main
select case (exe_type)
case (FPM_TARGET_C_OBJECT)
call model%compiler%get_main_flags("c",compile_flags)
case (FPM_TARGET_CPP_OBJECT)
call model%compiler%get_main_flags("c++",compile_flags)
case default
compile_flags = ""
end select
if (allocated(target%compile_flags)) then
target%compile_flags = target%compile_flags//' '//compile_flags
else
target%compile_flags = ' '//compile_flags
end if
! Executable depends on object
call add_dependency(target, targets(size(targets)-1)%ptr)
if (with_lib) then
! Executable depends on library file(s)
if (monolithic) then
call add_dependency(target, targets(1)%ptr)
elseif (static_lib .and. shared_lib) then
! Both types: depend on static libraries (2*k-1) for all packages
do k=1,size(model%packages)
call add_dependency(target, targets(2*k-1)%ptr)
end do
else
! Single type: depend on library for each package
do k=1,size(model%packages)
call add_dependency(target, targets(k)%ptr)
end do
end if
end if
endassociate
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 = '/'
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%package_name,object_file)//'.o'
end function get_object_name
end subroutine build_target_list
!> Add non-library non-module dependencies for executable targets
!>
!> Executable targets will link to any non-program non-module source files that
!> are in the same directory or in a subdirectory.
!>
!> (Note: Fortran module dependencies are handled separately in
!> `resolve_module_dependencies` and `resolve_target_linking`.)
!>
subroutine collect_exe_link_dependencies(targets)
type(build_target_ptr), intent(inout) :: targets(:)
integer :: i, j
character(:), allocatable :: exe_source_dir
! Add non-module dependencies for executables
do j=1,size(targets)
if (targets(j)%ptr%target_type == FPM_TARGET_EXECUTABLE) then
do i=1,size(targets)
if (i == j) cycle
associate(exe => targets(j)%ptr, dep => targets(i)%ptr)
exe_source_dir = dirname(exe%dependencies(1)%ptr%source%file_name)
if (allocated(dep%source)) then
if (dep%source%unit_scope /= FPM_SCOPE_LIB .and. &
dep%source%unit_type /= FPM_UNIT_PROGRAM .and. &
dep%source%unit_type /= FPM_UNIT_MODULE .and. &
index(dirname(dep%source%file_name), exe_source_dir) == 1) then
call add_dependency(exe, dep)
end if
end if
end associate
end do
end if
end do
end subroutine collect_exe_link_dependencies
!> Allocate a new target
type(build_target_ptr) function new_target(package, type, output_name, source, link_libraries, &
& features, preprocess, version, output_dir)
character(*), intent(in) :: package
integer, intent(in) :: type
character(*), intent(in) :: output_name
type(srcfile_t), intent(in), optional :: source
type(string_t), intent(in), optional :: link_libraries(:)
type(fortran_config_t), intent(in), optional :: features
type(preprocess_config_t), intent(in), optional :: preprocess
type(version_t), intent(in), optional :: version
character(*), intent(in), optional :: output_dir
allocate(new_target%ptr)
associate(target=>new_target%ptr)
target%target_type = type
target%output_name = output_name
target%package_name = package
if (present(source)) target%source = source
if (present(link_libraries)) target%link_libraries = link_libraries
if (present(features)) target%features = features
if (present(preprocess)) then
if (allocated(preprocess%macros)) target%macros = preprocess%macros
endif
if (present(version)) allocate(target%version, source = version)
allocate(target%dependencies(0))
call target%set_output_dir(output_dir)
endassociate
end function new_target
!> Allocate a new target and append to target list
subroutine add_new_target(targets, package, type, output_name, source, link_libraries, &
& features, preprocess, version, output_dir)
type(build_target_ptr), allocatable, intent(inout) :: targets(:)
character(*), intent(in) :: package
integer, intent(in) :: type
character(*), intent(in) :: output_name
type(srcfile_t), intent(in), optional :: source
type(string_t), intent(in), optional :: link_libraries(:)
type(fortran_config_t), intent(in), optional :: features
type(preprocess_config_t), intent(in), optional :: preprocess
type(version_t), intent(in), optional :: version
character(*), intent(in), optional :: output_dir
type(build_target_ptr) :: added
if (.not.allocated(targets)) allocate(targets(0))
! Create new target
added = new_target(package,type,output_name,source,link_libraries,features,preprocess,&
version,output_dir)
call add_old_target(targets, added)
end subroutine add_new_target
subroutine add_old_targets(targets, add_targets)
type(build_target_ptr), allocatable, intent(inout) :: targets(:)
type(build_target_ptr), intent(in) :: add_targets(:)
integer :: i,j
if (.not.allocated(targets)) allocate(targets(0))
! Check for duplicate outputs
do j=1,size(add_targets)
associate(added=>add_targets(j)%ptr)
do i=1,size(targets)
if (targets(i)%ptr%output_name == added%output_name) then
write(*,*) 'Error while building target list: duplicate output object "',&
added%output_name,'"'
if (allocated(added%source)) write(*,*) ' Source file: "',added%source%file_name,'"'
call fpm_stop(1,' ')
end if
end do
endassociate
end do
call add_target_ptr(targets, add_targets)
end subroutine add_old_targets
subroutine add_old_target(targets, add_target)
type(build_target_ptr), allocatable, intent(inout) :: targets(:)
type(build_target_ptr), intent(in) :: add_target
call add_old_targets(targets, [add_target])
end subroutine add_old_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
integer :: i
! Ensure no duplicate dependencies: it may happen if we loop over two library targets that
! contain the same objects
do i=1,size(target%dependencies)
if (target%dependencies(i)%ptr%output_name == dependency%output_name) return
end do
if (dependency%output_name==target%output_name) return
call add_target_ptr(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,external_modules,error)
type(build_target_ptr), intent(inout), target :: targets(:)
type(string_t), intent(in) :: external_modules(:)
type(error_t), allocatable, intent(out) :: error
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 (targets(i)%ptr%source%modules_used(j)%s .in. external_modules) then
! Dependency satisfied in system-installed module
cycle
end if
if (any(targets(i)%ptr%source%unit_scope == &
[FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST])) then
dep%ptr => &
find_module_dependency(targets,targets(i)%ptr%source%modules_used(j)%s, &
include_dir = dirname(targets(i)%ptr%source%file_name))
else
dep%ptr => &
find_module_dependency(targets,targets(i)%ptr%source%modules_used(j)%s)
end if
if (.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
!> Perform tree-shaking to remove unused module targets
subroutine prune_build_targets(targets, root_package, prune_unused_objects)
!> Build target list to prune
type(build_target_ptr), intent(inout), allocatable :: targets(:)
!> Root package
type(package_t), intent(in) :: root_package
!> Whether unused objects should be pruned
logical, intent(in) :: prune_unused_objects
integer :: i, j, nexec
type(string_t), allocatable :: modules_used(:)
logical :: exclude_target(size(targets))
logical, allocatable :: exclude_from_archive(:)
if (size(targets) < 1) then
return
end if
nexec = 0
allocate(modules_used(0))
! Enumerate modules used by executables, non-module subprograms and their dependencies
do i=1,size(targets)
if (targets(i)%ptr%target_type == FPM_TARGET_EXECUTABLE) then
nexec = nexec + 1
call collect_used_modules(targets(i)%ptr)
elseif (allocated(targets(i)%ptr%source)) then
if (targets(i)%ptr%source%unit_type == FPM_UNIT_SUBPROGRAM) then
call collect_used_modules(targets(i)%ptr)
end if
end if
end do
! If there aren't any executables, then prune
! based on modules used in root package
if (nexec < 1) then
do i=1,size(targets)
if (targets(i)%ptr%package_name == root_package%name .and. &
all(targets(i)%ptr%target_type /= [FPM_TARGET_ARCHIVE,FPM_TARGET_SHARED])) then
call collect_used_modules(targets(i)%ptr)
end if
end do
end if
call reset_target_flags(targets)
exclude_target = .false.
! Exclude purely module targets if they are not used anywhere
do i=1,size(targets)
associate(target=>targets(i)%ptr)
if (allocated(target%source)) then
if (target%source%unit_type == FPM_UNIT_MODULE) then
exclude_target(i) = prune_unused_objects
target%skip = prune_unused_objects
do j=1,size(target%source%modules_provided)
if (target%source%modules_provided(j)%s .in. modules_used) then
exclude_target(i) = .false.
target%skip = .false.
end if
end do
elseif (target%source%unit_type == FPM_UNIT_SUBMODULE) then
! Remove submodules if their parents are not used
exclude_target(i) = prune_unused_objects
target%skip = prune_unused_objects
do j=1,size(target%source%parent_modules)
if (target%source%parent_modules(j)%s .in. modules_used) then
exclude_target(i) = .false.
target%skip = .false.
end if
end do
end if
elseif (any(target%target_type == [FPM_TARGET_ARCHIVE,FPM_TARGET_SHARED])) then
! Remove empty library files
if (size(target%dependencies)==0) then
exclude_target(i) = .true.
target%skip = .true.
endif
end if
! (If there aren't any executables then we only prune modules from dependencies,
! unless the root package is also empty)
if (nexec < 1 .and. target%package_name == root_package%name) then
exclude_target(i) = .not.root_package%has_library()
target%skip = exclude_target(i)
end if
end associate
end do
targets = pack(targets,.not.exclude_target)
! Remove unused targets from library dependency list
do j=1,size(targets)
associate(archive=>targets(j)%ptr)
if (any(archive%target_type==[FPM_TARGET_ARCHIVE,FPM_TARGET_OBJECT])) then
allocate(exclude_from_archive(size(archive%dependencies)),source=.false.)
do i=1,size(archive%dependencies)
if (archive%dependencies(i)%ptr%skip) then
exclude_from_archive(i) = .true.
end if
end do
archive%dependencies = pack(archive%dependencies,.not.exclude_from_archive)
deallocate(exclude_from_archive)
endif
end associate
end do
contains
!> Recursively collect which modules are actually used
recursive subroutine collect_used_modules(target)
type(build_target_t), intent(inout) :: target
integer :: j, k
if (target%touched) then
return
else
target%touched = .true.
end if
if (allocated(target%source)) then
! Add modules from this target and from any of it's children submodules
do j=1,size(target%source%modules_provided)
if (.not.(target%source%modules_provided(j)%s .in. modules_used)) then
call add_strings(modules_used, target%source%modules_provided(j))
end if
! Recurse into child submodules
do k=1,size(targets)
if (allocated(targets(k)%ptr%source)) then
if (targets(k)%ptr%source%unit_type == FPM_UNIT_SUBMODULE) then
if (target%source%modules_provided(j)%s .in. targets(k)%ptr%source%parent_modules) then
call collect_used_modules(targets(k)%ptr)
end if
end if
end if
end do
end do
end if
! Recurse into dependencies
do j=1,size(target%dependencies)
if (target%dependencies(j)%ptr%target_type /= FPM_TARGET_ARCHIVE) then
call collect_used_modules(target%dependencies(j)%ptr)
end if
end do
end subroutine collect_used_modules
!> Reset target flags after recursive search
subroutine reset_target_flags(targets)
type(build_target_ptr), intent(inout) :: targets(:)
integer :: i
do i=1,size(targets)
targets(i)%ptr%touched = .false.
end do
end subroutine reset_target_flags
end subroutine prune_build_targets
!> Construct the linker flags string for each target
!> `target%link_flags` includes non-library objects and library flags
!>
subroutine resolve_target_linking(targets, model, library, error)
type(build_target_ptr), intent(inout), target :: targets(:)
type(fpm_model_t), intent(in) :: model
type(library_config_t), intent(in), optional :: library
type(error_t), allocatable, intent(out) :: error
integer :: i,j
logical :: shared,static,monolithic,has_self_lib
integer, allocatable :: package_deps(:),dep_target_ID(:)
character(:), allocatable :: global_link_flags, local_link_flags
character(:), allocatable :: global_include_flags, shared_lib_paths
if (size(targets) == 0) return
global_link_flags = ""
if (allocated(model%link_libraries)) then
if (size(model%link_libraries) > 0) then
global_link_flags = model%compiler%enumerate_libraries(global_link_flags, model%link_libraries)
end if
end if
allocate(character(0) :: global_include_flags)
if (allocated(model%include_dirs)) then
if (size(model%include_dirs) > 0) then
global_include_flags = global_include_flags // &
& " -I" // string_cat(model%include_dirs," -I")
end if
end if
if (present(library)) then
shared = library%shared()
static = library%static()
monolithic = library%monolithic()
else
shared = .false.
static = .false.
monolithic = .true.
end if
do i=1,size(targets)
associate(target => targets(i)%ptr)
! If the main program is a C/C++ one, some compilers require additional linking flags, see
! https://stackoverflow.com/questions/36221612/p3dfft-compilation-ifort-compiler-error-multiple-definiton-of-main
! In this case, compile_flags were already allocated
if (.not.allocated(target%compile_flags)) allocate(character(len=0) :: target%compile_flags)
target%compile_flags = target%compile_flags//' '
select case (target%target_type)
case (FPM_TARGET_C_OBJECT)
target%compile_flags = target%compile_flags//model%c_compile_flags
case (FPM_TARGET_CPP_OBJECT)
target%compile_flags = target%compile_flags//model%cxx_compile_flags
case default
if (allocated(model%fortran_compile_flags)) then
target%compile_flags = target%compile_flags//model%fortran_compile_flags
end if
target%compile_flags = target%compile_flags // get_feature_flags(model%compiler, target%features)
end select
!> Get macros as flags.
target%compile_flags = target%compile_flags // get_macros(model%compiler%id, &
target%macros, &
target%version)
if (len(global_include_flags) > 0) then
target%compile_flags = target%compile_flags//global_include_flags
end if
call target%set_output_dir(get_output_dir(model%build_prefix, target%compile_flags))
end associate
end do
call add_include_build_dirs(model, targets)
call add_library_link_dirs(model, targets, shared_lib_paths)
call library_targets_to_deps(model, targets, dep_target_ID)
do i=1,size(targets)
associate(target => targets(i)%ptr)
allocate(target%link_objects(0))
select case (target%target_type)
case (FPM_TARGET_ARCHIVE)
! This adds the monolithic archive to the link flags
if (monolithic) global_link_flags = " " // target%output_file // global_link_flags
call get_link_objects(target%link_objects,target,is_exe=.false.)
allocate(character(0) :: target%link_flags)
case (FPM_TARGET_SHARED)
! Gather object files from this package only
call get_link_objects(target%link_objects, target, is_exe=.false.)
! Build link flags
target%link_flags = string_cat(target%link_objects, " ")
! Add global link flags (including metapackage flags like OpenMP)
if (allocated(model%link_flags)) then
target%link_flags = model%link_flags//" "//target%link_flags
endif
target%link_flags = target%link_flags // shared_lib_paths
! Add dependencies' shared libraries (excluding self)
target%link_flags = model%get_package_libraries_link(target%package_name, &
target%link_flags, &
exclude_self=.true., &
dep_IDs=package_deps, &
error=error)
if (allocated(error)) return
! Now that they're available, add these dependencies to the targets
if (size(package_deps)>0) then
do j=1,size(package_deps)
if (dep_target_ID(package_deps(j))<=0) cycle
call add_dependency(target, targets(dep_target_ID(package_deps(j)))%ptr)
end do
end if
! Add any per-target libraries (e.g., `target%link_libraries`)
if (allocated(target%link_libraries)) then
if (size(target%link_libraries) > 0) then
target%link_flags = model%compiler%enumerate_libraries(target%link_flags, &
target%link_libraries)
end if
end if
! Add shared library exports (import library + .def)
target%link_flags = target%link_flags // " " // &
model%compiler%get_export_flags(target%output_dir,target%package_name)
! Add install_name flag (macOS only)
target%link_flags = target%link_flags // " " // &
model%compiler%get_install_name_flags(target%output_dir, target%package_name)
! Add global link flags (e.g., system-wide libraries)
target%link_flags = target%link_flags // " " // global_link_flags
case (FPM_TARGET_EXECUTABLE)
local_link_flags = ""
if (allocated(model%link_flags)) local_link_flags = model%link_flags
call get_link_objects(target%link_objects,target,is_exe=.true.)
if (allocated(model%link_flags)) then
target%link_flags = model%link_flags//" "//string_cat(target%link_objects," ")
else
target%link_flags = " "//string_cat(target%link_objects," ")
end if
! Add shared libs
if (.not.monolithic) then
target%link_flags = target%link_flags // shared_lib_paths
! Check if there's a library with this name (maybe not, if it is a
! single-file app with only external dependencies)
has_self_lib = .false.
find_self: do j=1,size(targets)
associate(target_loop=>targets(j)%ptr)
if ((target_loop%target_type==FPM_TARGET_ARCHIVE .or. &
(target_loop%target_type==FPM_TARGET_SHARED .and. .not.static)) &
.and. target_loop%package_name==target%package_name) then
has_self_lib = .true.
exit find_self
end if
end associate
end do find_self
! Add dependencies' shared libraries (including self if there is a library)
target%link_flags = model%get_package_libraries_link(target%package_name, &
target%link_flags, &
error=error, &
exclude_self=.not.has_self_lib)
end if
! On macOS, add room for 2 install_name_tool paths
target%link_flags = target%link_flags // model%compiler%get_headerpad_flags()
! On macOS, add room for 2 install_name_tool paths (always needed for executables)
if (allocated(target%link_libraries)) then
if (size(target%link_libraries) > 0) then
target%link_flags = model%compiler%enumerate_libraries(target%link_flags, target%link_libraries)
local_link_flags = model%compiler%enumerate_libraries(local_link_flags, target%link_libraries)
end if
end if
target%link_flags = target%link_flags//" "//global_link_flags
end select
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
call add_strings(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
subroutine add_include_build_dirs(model, targets)
type(fpm_model_t), intent(in) :: model
type(build_target_ptr), intent(inout), target :: targets(:)
integer :: i
type(string_t), allocatable :: build_dirs(:)
type(string_t) :: temp
allocate(build_dirs(0))
do i = 1, size(targets)
associate(target => targets(i)%ptr)
if (target%target_type /= FPM_TARGET_OBJECT) cycle
if (target%output_dir .in. build_dirs) cycle
temp%s = target%output_dir
call add_strings(build_dirs, temp)
end associate
end do
do i = 1, size(targets)
associate(target => targets(i)%ptr)
if (target%target_type /= FPM_TARGET_OBJECT) cycle
target%compile_flags = target%compile_flags // &
" " // model%compiler%get_module_flag(target%output_dir) // &
" -I" // string_cat(build_dirs, " -I")
end associate
end do
end subroutine add_include_build_dirs
!> Add link directories for all shared libraries in the dependency graph
subroutine get_library_dirs(model, targets, shared_lib_dirs)
type(fpm_model_t), intent(in) :: model
type(build_target_ptr), intent(inout), target :: targets(:)
type(string_t), allocatable, intent(out) :: shared_lib_dirs(:)
integer :: i
type(string_t) :: temp
allocate(shared_lib_dirs(0))
do i = 1, size(targets)
associate(target => targets(i)%ptr)
if (all(target%target_type /= [FPM_TARGET_SHARED,FPM_TARGET_ARCHIVE])) cycle
if (target%output_dir .in. shared_lib_dirs) cycle
temp = string_t(target%output_dir)
call add_strings(shared_lib_dirs, temp)
end associate
end do
end subroutine get_library_dirs
!> Add link directories for all shared libraries in the dependency graph
subroutine add_library_link_dirs(model, targets, shared_lib_path)
type(fpm_model_t), intent(in) :: model
type(build_target_ptr), intent(inout), target :: targets(:)
character(:), allocatable, intent(out) :: shared_lib_path
type(string_t), allocatable :: shared_lib_dirs(:)
call get_library_dirs(model, targets, shared_lib_dirs)
shared_lib_path = " -L" // string_cat(shared_lib_dirs, " -L")
end subroutine add_library_link_dirs
function get_output_dir(build_prefix, args) result(path)
character(len=*), intent(in) :: build_prefix
character(len=*), intent(in) :: args
character(len=:), allocatable :: path
character(len=16) :: build_hash
write(build_hash, '(z16.16)') fnv_1a(args)
path = build_prefix//"_"//build_hash
end function get_output_dir
!> Returns pointers to all library targets
subroutine filter_library_targets(targets, list)
type(build_target_ptr), intent(in) :: targets(:)
type(build_target_ptr), allocatable, intent(out) :: list(:)
integer :: i, n
n = 0
do i = 1, size(targets)
if (any(targets(i)%ptr%target_type == [FPM_TARGET_ARCHIVE,FPM_TARGET_SHARED])) then
n = n + 1
end if
end do
allocate(list(n))
n = 0
do i = 1, size(targets)
if (any(targets(i)%ptr%target_type == [FPM_TARGET_ARCHIVE,FPM_TARGET_SHARED])) then
n = n + 1
list(n)%ptr => targets(i)%ptr
end if
end do
end subroutine filter_library_targets
subroutine filter_executable_targets(targets, scope, list)
type(build_target_ptr), intent(in) :: targets(:)
integer, intent(in) :: scope
type(string_t), allocatable, intent(out) :: list(:)
integer :: i, n
n = 0
call resize(list)
do i = 1, size(targets)
if (is_executable_target(targets(i)%ptr, scope)) then
if (n >= size(list)) call resize(list)
n = n + 1
list(n)%s = targets(i)%ptr%output_file
end if
end do
call resize(list, n)
end subroutine filter_executable_targets
elemental function is_executable_target(target_ptr, scope) result(is_exe)
class(build_target_t), intent(in) :: target_ptr
integer, intent(in) :: scope
logical :: is_exe
is_exe = target_ptr%target_type == FPM_TARGET_EXECUTABLE .and. &
allocated(target_ptr%dependencies)
if (is_exe) then
is_exe = target_ptr%dependencies(1)%ptr%source%unit_scope == scope
end if
end function is_executable_target
subroutine filter_modules(targets, list)
type(build_target_ptr), intent(in) :: targets(:)
type(string_t), allocatable, intent(out) :: list(:)
integer :: i, j, n
n = 0
call resize(list)
do i = 1, size(targets)
associate(target => targets(i)%ptr)
if (.not.allocated(target%source)) cycle
if (target%source%unit_type == FPM_UNIT_SUBMODULE) cycle
if (n + size(target%source%modules_provided) >= size(list)) call resize(list)
do j = 1, size(target%source%modules_provided)
n = n + 1
list(n)%s = join_path(target%output_dir, &
target%source%modules_provided(j)%s)
end do
end associate
end do
call resize(list, n)
end subroutine filter_modules
function get_feature_flags(compiler, features) result(flags)
type(compiler_t), intent(in) :: compiler
type(fortran_config_t), intent(in) :: features
character(:), allocatable :: flags
flags = ""
if (features%implicit_typing) then
flags = flags // compiler%get_feature_flag("implicit-typing")
else
flags = flags // compiler%get_feature_flag("no-implicit-typing")
end if
if (features%implicit_external) then
flags = flags // compiler%get_feature_flag("implicit-external")
else
flags = flags // compiler%get_feature_flag("no-implicit-external")
end if
if (allocated(features%source_form)) then
flags = flags // compiler%get_feature_flag(features%source_form//"-form")
end if
end function get_feature_flags
!> Helper function: update output directory of a target
subroutine set_output_dir(self, output_dir)
class(build_target_t), intent(inout) :: self
character(*), optional, intent(in) :: output_dir
character(:), allocatable :: outdir
! Normalize: if output_dir is empty, use no path
outdir = ""
if (present(output_dir)) outdir = trim(output_dir)
self%output_dir = outdir
self%output_file = join_path(outdir, self%output_name)
self%output_log_file = self%output_file // ".log"
end subroutine set_output_dir
!> Build a lookup table mapping each package dependency to its corresponding
!> shared or archive build target in the targets list.
!>
!> This mapping is essential when model%deps%dep(i) indices do not match
!> the pruned or reordered targets(:) array.
subroutine library_targets_to_deps(model, targets, target_ID)
class(fpm_model_t), intent(in) :: model
type(build_target_ptr), intent(in) :: targets(:)
!> For each package (by dependency index), gives the index of the corresponding target
integer, allocatable, intent(out) :: target_ID(:)
integer :: it, ip, n
n = model%deps%ndep
allocate(target_ID(n), source=0)
do it = 1, size(targets)
associate(target => targets(it)%ptr)
! Only shared libraries and archives are mapped
if (all(target%target_type /= [FPM_TARGET_ARCHIVE, FPM_TARGET_SHARED])) cycle
! Get the dependency graph index of this package
ip = model%deps%find(target%package_name)
if (ip > 0) target_ID(ip) = it
end associate
end do
end subroutine library_targets_to_deps
!> Add one build target pointer to array with a loop (gcc-15 bug on array initializer)
subroutine add_target_ptr_one(list,new)
type(build_target_ptr), allocatable, intent(inout) :: list(:)
type(build_target_ptr), intent(in) :: new
integer :: i,n
type(build_target_ptr), allocatable :: tmp(:)
if (allocated(list)) then
n = size(list)
else
n = 0
end if
allocate(tmp(n+1))
do i=1,n
tmp(i) = list(i)
end do
tmp(n+1) = new
call move_alloc(from=tmp,to=list)
end subroutine add_target_ptr_one
!> Add multiple build target pointers to array with a loop (gcc-15 bug on array initializer)
subroutine add_target_ptr_many(list,new)
type(build_target_ptr), allocatable, intent(inout) :: list(:)
type(build_target_ptr), intent(in) :: new(:)
integer :: i,n,add
type(build_target_ptr), allocatable :: tmp(:)
if (allocated(list)) then
n = size(list)
else
n = 0
end if
add = size(new)
if (add == 0) return
allocate(tmp(n+add))
do i=1,n
tmp(i) = list(i)
end do
do i=1,add
tmp(n+i) = new(i)
end do
call move_alloc(from=tmp,to=list)
end subroutine add_target_ptr_many
end module fpm_targets
fortran-lang-fpm-90bb83a/src/metapackage/ 0000775 0001750 0001750 00000000000 15145116760 020521 5 ustar alastair alastair fortran-lang-fpm-90bb83a/src/metapackage/fpm_meta_util.f90 0000664 0001750 0001750 00000010556 15145116760 023675 0 ustar alastair alastair module fpm_meta_util
use fpm_meta_base, only: metapackage_t, destroy
use fpm_filesystem, only: join_path
use fpm_strings, only: split, string_t, str_begins_with_str, add_strings
use fpm_error, only: error_t
use fpm_versioning, only: new_version
use fpm_pkg_config, only: pkgcfg_get_libs, pkgcfg_get_build_flags, pkgcfg_get_version
implicit none
private
public :: add_pkg_config_compile_options, lib_get_trailing, add_strings
contains
!> Add pkgconfig compile options to a metapackage
subroutine add_pkg_config_compile_options(this, name, include_flag, libdir, error)
class(metapackage_t), intent(inout) :: this
character(len=*), intent(in) :: name
character(len=*), intent(in) :: include_flag
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: libdir
type(string_t) :: log, current_include_dir, current_lib
type(string_t), allocatable :: libs(:), flags(:)
integer :: i
!> Get version
if (.not. allocated(this%version)) then
log = pkgcfg_get_version(name, error)
if (allocated(error)) return
allocate(this%version)
call new_version(this%version, log%s, error)
if (allocated(error)) return
end if
!> Get libraries
libs = pkgcfg_get_libs(name, error)
if (allocated(error)) return
libdir = ""
do i = 1, size(libs)
if (str_begins_with_str(libs(i)%s, '-l')) then
current_lib = string_t(libs(i)%s(3:))
if (len_trim(current_lib%s) == 0) cycle
this%has_link_libraries = .true.
call add_strings(this%link_libs, current_lib)
else ! -L and others: concatenate
this%has_link_flags = .true.
this%link_flags = string_t(trim(this%link_flags%s)//' '//libs(i)%s)
! Also save library dir
if (str_begins_with_str(libs(i)%s, '-L')) then
libdir = libs(i)%s(3:)
elseif (str_begins_with_str(libs(i)%s, '/LIBPATH')) then
libdir = libs(i)%s(9:)
end if
end if
end do
!> Get compiler flags
flags = pkgcfg_get_build_flags(name, .true., error)
if (allocated(error)) return
do i = 1, size(flags)
if (str_begins_with_str(flags(i)%s, include_flag)) then
current_include_dir = string_t(flags(i)%s(len(include_flag)+1:))
if (len_trim(current_include_dir%s) == 0) cycle
this%has_include_dirs = .true.
call add_strings(this%incl_dirs, current_include_dir)
else
this%has_build_flags = .true.
this%flags = string_t(trim(this%flags%s)//' '//flags(i)%s)
end if
end do
end subroutine add_pkg_config_compile_options
!> Given a library name and folder, find extension and prefix
subroutine lib_get_trailing(lib_name,lib_dir,prefix,suffix,found)
character(*), intent(in) :: lib_name,lib_dir
character(:), allocatable, intent(out) :: prefix,suffix
logical, intent(out) :: found
character(*), parameter :: extensions(*) = [character(11) :: '.dll.a','.a','.dylib','.dll']
logical :: is_file
character(:), allocatable :: noext,tokens(:),path
integer :: l,k
! Extract name with no extension
call split(lib_name,tokens,'.')
noext = trim(tokens(1))
! Get library extension: find file name: NAME.a, NAME.dll.a, NAME.dylib, libNAME.a, etc.
found = .false.
suffix = ""
prefix = ""
with_pref: do l=1,2
if (l==2) then
prefix = "lib"
else
prefix = ""
end if
find_ext: do k=1,size(extensions)
path = join_path(lib_dir,prefix//noext//trim(extensions(k)))
inquire(file=path,exist=is_file)
if (is_file) then
suffix = trim(extensions(k))
found = .true.
exit with_pref
end if
end do find_ext
end do with_pref
if (.not.found) then
prefix = ""
suffix = ""
end if
end subroutine lib_get_trailing
end module fpm_meta_util
fortran-lang-fpm-90bb83a/src/metapackage/fpm_meta_stdlib.f90 0000664 0001750 0001750 00000005661 15145116760 024202 0 ustar alastair alastair module fpm_meta_stdlib
use fpm_compiler, only: compiler_t
use fpm_error, only: error_t, fatal_error
use fpm_meta_base, only: metapackage_t, destroy
use fpm_git, only: git_target_branch
use fpm_manifest_metapackages, only: metapackage_request_t
use fpm_strings, only: string_t
use iso_fortran_env, only: stdout => output_unit
implicit none
private
public :: init_stdlib
contains
!> Initialize stdlib metapackage for the current system
subroutine init_stdlib(this,compiler,all_meta,error)
class(metapackage_t), intent(inout) :: this
type(compiler_t), intent(in) :: compiler
type(metapackage_request_t), intent(in) :: all_meta(:)
type(error_t), allocatable, intent(out) :: error
integer :: i
logical :: with_blas
!> Cleanup
call destroy(this)
!> Set name
this%name = "stdlib"
!> Stdlib is queried as a dependency from the official repository
this%has_dependencies = .true.
allocate(this%dependency(2))
!> 1) Test-drive
this%dependency(1)%name = "test-drive"
this%dependency(1)%git = git_target_branch("https://github.com/fortran-lang/test-drive","v0.4.0")
if (.not.allocated(this%dependency(1)%git)) then
call fatal_error(error,'cannot initialize test-drive git dependency for stdlib metapackage')
return
end if
!> 2) stdlib
this%dependency(2)%name = "stdlib"
this%dependency(2)%git = git_target_branch("https://github.com/fortran-lang/stdlib","stdlib-fpm")
if (.not.allocated(this%dependency(2)%git)) then
call fatal_error(error,'cannot initialize git repo dependency for stdlib metapackage')
return
end if
!> If an external BLAS is available, deploy appropriate macros
with_blas = external_blas(all_meta)
if (with_blas) then
allocate(this%preprocess)
call this%preprocess%new([string_t('STDLIB_EXTERNAL_BLAS'),string_t('STDLIB_EXTERNAL_LAPACK')])
call this%dependency(2)%add_preprocess(this%preprocess)
end if
! Stdlib is not 100% thread safe. print a warning to the user
do i=1,size(all_meta)
if (all_meta(i)%name=="openmp") then
write(stdout,'(a)')' both openmp and stdlib requested: some functions may not be thread-safe!'
end if
end do
end subroutine init_stdlib
logical function external_blas(all_meta)
type(metapackage_request_t), intent(in) :: all_meta(:)
integer :: i
external_blas = .false.
do i=1,size(all_meta)
if (all_meta(i)%name=="blas") then
external_blas = .true.
exit
end if
end do
end function external_blas
end module fpm_meta_stdlib
fortran-lang-fpm-90bb83a/src/metapackage/fpm_meta_base.f90 0000664 0001750 0001750 00000025301 15145116760 023624 0 ustar alastair alastair module fpm_meta_base
use fpm_error, only: error_t, fatal_error
use fpm_versioning, only: version_t
use fpm_model, only: fpm_model_t, fortran_config_t
use fpm_command_line, only: fpm_cmd_settings, fpm_run_settings
use fpm_manifest_dependency, only: dependency_config_t
use fpm_manifest_preprocess, only: preprocess_config_t
use fpm_manifest, only: package_config_t
use fpm_strings, only: string_t, len_trim, split, join
use fpm_compiler, only: append_clean_flags, append_clean_flags_array
implicit none
private
public :: destroy
!> Type for describing a source file
type, public :: metapackage_t
!> Package name
character(:), allocatable :: name
!> Package version (if supported)
type(version_t), allocatable :: version
logical :: has_link_libraries = .false.
logical :: has_link_flags = .false.
logical :: has_build_flags = .false.
logical :: has_fortran_flags = .false.
logical :: has_c_flags = .false.
logical :: has_cxx_flags = .false.
logical :: has_include_dirs = .false.
logical :: has_dependencies = .false.
logical :: has_run_command = .false.
logical :: has_external_modules = .false.
!> List of compiler flags and options to be added
type(string_t) :: flags
type(string_t) :: fflags
type(string_t) :: cflags
type(string_t) :: cxxflags
type(string_t) :: link_flags
type(string_t) :: run_command
type(string_t), allocatable :: incl_dirs(:)
type(string_t), allocatable :: link_libs(:)
type(string_t), allocatable :: external_modules(:)
!> Special fortran features
type(fortran_config_t), allocatable :: fortran
!> Preprocessor configuration
type(preprocess_config_t), allocatable :: preprocess
!> List of Development dependency meta data.
!> Metapackage dependencies are never exported from the model
type(dependency_config_t), allocatable :: dependency(:)
contains
!> Clean metapackage structure
procedure :: destroy
!> Add metapackage dependencies to the model
procedure, private :: resolve_cmd
procedure, private :: resolve_model
procedure, private :: resolve_package_config
generic :: resolve => resolve_cmd,resolve_model,resolve_package_config
end type metapackage_t
!> Add dependencies to array (gcc-15 bug workaround)
interface add_dependency_config
module procedure add_dependency_config_one
module procedure add_dependency_config_many
end interface add_dependency_config
contains
elemental subroutine destroy(this)
class(metapackage_t), intent(inout) :: this
this%has_link_libraries = .false.
this%has_link_flags = .false.
this%has_build_flags = .false.
this%has_fortran_flags = .false.
this%has_c_flags = .false.
this%has_cxx_flags = .false.
this%has_include_dirs = .false.
this%has_dependencies = .false.
this%has_run_command = .false.
this%has_external_modules = .false.
if (allocated(this%fortran)) deallocate(this%fortran)
if (allocated(this%preprocess)) deallocate(this%preprocess)
if (allocated(this%name)) deallocate(this%name)
if (allocated(this%version)) deallocate(this%version)
if (allocated(this%flags%s)) deallocate(this%flags%s)
if (allocated(this%link_libs)) deallocate(this%link_libs)
if (allocated(this%incl_dirs)) deallocate(this%incl_dirs)
if (allocated(this%external_modules)) deallocate(this%external_modules)
if (allocated(this%dependency)) deallocate(this%dependency)
end subroutine destroy
!> Resolve metapackage dependencies into the command line settings
subroutine resolve_cmd(self,settings,error)
class(metapackage_t), intent(in) :: self
class(fpm_cmd_settings), intent(inout) :: settings
type(error_t), allocatable, intent(out) :: error
! Add customize run commands
if (self%has_run_command) then
select type (cmd=>settings)
class is (fpm_run_settings) ! includes fpm_test_settings
! Only override runner if user has not provided a custom one
if (.not.len_trim(cmd%runner)>0) cmd%runner = self%run_command%s
end select
endif
end subroutine resolve_cmd
!> Resolve metapackage dependencies into the model
subroutine resolve_model(self,model,error)
class(metapackage_t), intent(in) :: self
type(fpm_model_t), intent(inout) :: model
type(error_t), allocatable, intent(out) :: error
! Add global build flags, to apply to all sources
if (self%has_build_flags) then
call append_clean_flags(model%fortran_compile_flags, self%flags%s)
call append_clean_flags(model%c_compile_flags, self%flags%s)
call append_clean_flags(model%cxx_compile_flags, self%flags%s)
endif
! Add language-specific flags
if (self%has_fortran_flags) call append_clean_flags(model%fortran_compile_flags, self%fflags%s)
if (self%has_c_flags) call append_clean_flags(model%c_compile_flags, self%cflags%s)
if (self%has_cxx_flags) call append_clean_flags(model%cxx_compile_flags, self%cxxflags%s)
if (self%has_link_flags) then
call append_clean_flags(model%link_flags, self%link_flags%s)
end if
if (self%has_link_libraries) then
call append_clean_flags_array(model%link_libraries, self%link_libs)
end if
if (self%has_include_dirs) then
call append_clean_flags_array(model%include_dirs, self%incl_dirs)
end if
if (self%has_external_modules) then
call append_clean_flags_array(model%external_modules, self%external_modules)
end if
end subroutine resolve_model
subroutine resolve_package_config(self,package,error)
class(metapackage_t), intent(in) :: self
type(package_config_t), intent(inout) :: package
type(error_t), allocatable, intent(out) :: error
integer :: i
! All metapackage dependencies are added as dev-dependencies,
! as they may change if built upstream
if (self%has_dependencies) then
if (allocated(package%dev_dependency)) then
call add_dependency_config(package%dev_dependency,self%dependency)
else
package%dev_dependency = self%dependency
end if
end if
! Check if there are any special fortran requests which the package does not comply to
if (allocated(self%fortran)) then
if (self%fortran%implicit_external.neqv.package%fortran%implicit_external) then
call fatal_error(error,'metapackage fortran error: metapackage '// &
dn(self%fortran%implicit_external)//' require implicit-external, main package '//&
dn(package%fortran%implicit_external))
return
end if
if (self%fortran%implicit_typing.neqv.package%fortran%implicit_typing) then
call fatal_error(error,'metapackage fortran error: metapackage '// &
dn(self%fortran%implicit_external)//' require implicit-typing, main package '//&
dn(package%fortran%implicit_external))
return
end if
end if
! Check if there are preprocessor configurations
if (allocated(self%preprocess)) then
if (self%preprocess%is_cpp()) then
if (allocated(package%preprocess)) then
if (size(package%preprocess)<1) then
deallocate(package%preprocess)
allocate(package%preprocess(1),source=self%preprocess)
else
do i=1,size(package%preprocess)
if (package%preprocess(i)%is_cpp()) then
call package%preprocess(i)%add_config(self%preprocess)
exit
end if
end do
end if
else
! Copy configuration
allocate(package%preprocess(1),source=self%preprocess)
end if
else
call fatal_error(error,'non-cpp preprocessor configuration '// &
self%preprocess%name//' is not supported')
return
end if
end if
contains
pure function dn(bool)
logical, intent(in) :: bool
character(len=:), allocatable :: dn
if (bool) then
dn = "does"
else
dn = "does not"
end if
end function dn
end subroutine resolve_package_config
!> Add one dependency to array with a loop (gcc-15 bug on array initializer)
pure subroutine add_dependency_config_one(list,new)
type(dependency_config_t), allocatable, intent(inout) :: list(:)
type(dependency_config_t), intent(in) :: new
integer :: i,n
type(dependency_config_t), allocatable :: tmp(:)
if (allocated(list)) then
n = size(list)
else
n = 0
end if
allocate(tmp(n+1))
do i=1,n
tmp(i) = list(i)
end do
tmp(n+1) = new
call move_alloc(from=tmp,to=list)
end subroutine add_dependency_config_one
!> Add multiple dependencies to array with a loop (gcc-15 bug on array initializer)
pure subroutine add_dependency_config_many(list,new)
type(dependency_config_t), allocatable, intent(inout) :: list(:)
type(dependency_config_t), intent(in) :: new(:)
integer :: i,n,add
type(dependency_config_t), allocatable :: tmp(:)
if (allocated(list)) then
n = size(list)
else
n = 0
end if
add = size(new)
if (add == 0) return
allocate(tmp(n+add))
do i=1,n
tmp(i) = list(i)
end do
do i=1,add
tmp(n+i) = new(i)
end do
call move_alloc(from=tmp,to=list)
end subroutine add_dependency_config_many
end module fpm_meta_base
fortran-lang-fpm-90bb83a/src/metapackage/fpm_meta_minpack.f90 0000664 0001750 0001750 00000002603 15145116760 024334 0 ustar alastair alastair module fpm_meta_minpack
use fpm_compiler, only: compiler_t
use fpm_meta_base, only: metapackage_t, destroy
use fpm_error, only: error_t, fatal_error
use fpm_git, only: git_target_tag
use fpm_manifest_metapackages, only: metapackage_request_t
implicit none
private
public :: init_minpack
contains
!> Initialize minpack metapackage for the current system
subroutine init_minpack(this,compiler,all_meta,error)
class(metapackage_t), intent(inout) :: this
type(compiler_t), intent(in) :: compiler
type(metapackage_request_t), intent(in) :: all_meta(:)
type(error_t), allocatable, intent(out) :: error
!> Cleanup
call destroy(this)
!> Set name
this%name = "minpack"
!> minpack is queried as a dependency from the official repository
this%has_dependencies = .true.
allocate(this%dependency(1))
!> 1) minpack. There are no true releases currently. Fetch HEAD
this%dependency(1)%name = "minpack"
this%dependency(1)%git = git_target_tag("https://github.com/fortran-lang/minpack", "v2.0.0-rc.1")
if (.not.allocated(this%dependency(1)%git)) then
call fatal_error(error,'cannot initialize git repo dependency for minpack metapackage')
return
end if
end subroutine init_minpack
end module fpm_meta_minpack
fortran-lang-fpm-90bb83a/src/metapackage/fpm_meta_netcdf.f90 0000664 0001750 0001750 00000005534 15145116760 024163 0 ustar alastair alastair module fpm_meta_netcdf
use fpm_compiler, only: compiler_t, get_include_flag
use fpm_meta_base, only: metapackage_t, destroy
use fpm_meta_util, only: add_pkg_config_compile_options
use fpm_pkg_config, only: assert_pkg_config, pkgcfg_has_package
use fpm_strings, only: string_t
use fpm_error, only: error_t, fatal_error
use fpm_manifest_metapackages, only: metapackage_request_t
implicit none
private
public :: init_netcdf
contains
!> Initialize NetCDF metapackage for the current system
subroutine init_netcdf(this, compiler, all_meta, error)
class(metapackage_t), intent(inout) :: this
type(compiler_t), intent(in) :: compiler
type(metapackage_request_t), intent(in) :: all_meta(:)
type(error_t), allocatable, intent(out) :: error
logical :: s
character(len=:), allocatable :: include_flag, libdir
include_flag = get_include_flag(compiler, "")
!> Cleanup
call destroy(this)
allocate (this % link_libs(0), this % incl_dirs(0), this % external_modules(0))
this % link_flags = string_t("")
this % flags = string_t("")
!> Set name
this%name = "netcdf"
!> Assert pkg-config is installed
if (.not. assert_pkg_config()) then
call fatal_error(error, 'netcdf metapackage requires pkg-config')
return
end if
if (.not. pkgcfg_has_package('netcdf')) then
call fatal_error(error, 'pkg-config could not find a suitable netcdf package.')
return
end if
call add_pkg_config_compile_options(this, 'netcdf', include_flag, libdir, error)
if (allocated(error)) return
if (.not. pkgcfg_has_package('netcdf-fortran')) then
call fatal_error(error, &
'pkg-config could not find a suitable netcdf-fortran package.')
return
end if
call add_pkg_config_compile_options(this, 'netcdf-fortran', include_flag, libdir, error)
if (allocated(error)) return
!> Add NetCDF modules as external
this % has_external_modules = .true.
this % external_modules = [string_t('netcdf'), &
string_t('netcdf4_f03'), &
string_t('netcdf4_nc_interfaces'), &
string_t('netcdf4_nf_interfaces'), &
string_t('netcdf_f03'), &
string_t('netcdf_fortv2_c_interfaces'), &
string_t('netcdf_nc_data'), &
string_t('netcdf_nc_interfaces'), &
string_t('netcdf_nf_data'), &
string_t('netcdf_nf_interfaces')]
end subroutine init_netcdf
end module fpm_meta_netcdf
fortran-lang-fpm-90bb83a/src/metapackage/fpm_meta_hdf5.f90 0000664 0001750 0001750 00000013751 15145116760 023546 0 ustar alastair alastair module fpm_meta_hdf5
use fpm_compiler, only: compiler_t, get_include_flag
use fpm_strings, only: str_begins_with_str, str_ends_with, string_t
use fpm_filesystem, only: join_path
use fpm_pkg_config, only: assert_pkg_config, pkgcfg_has_package, pkgcfg_list_all
use fpm_meta_base, only: metapackage_t, destroy
use fpm_meta_util, only: add_pkg_config_compile_options, lib_get_trailing, add_strings
use fpm_manifest_metapackages, only: metapackage_request_t
use fpm_error, only: error_t, fatal_error
implicit none
private
public :: init_hdf5
contains
!> Initialize HDF5 metapackage for the current system
subroutine init_hdf5(this,compiler,all_meta,error)
class(metapackage_t), intent(inout) :: this
type(compiler_t), intent(in) :: compiler
type(metapackage_request_t), intent(in) :: all_meta(:)
type(error_t), allocatable, intent(out) :: error
character(*), parameter :: find_hl(*) = &
[character(11) :: '_hl_fortran','hl_fortran','_fortran','_hl']
character(*), parameter :: candidates(*) = &
[character(15) :: 'hdf5_hl_fortran','hdf5-hl-fortran','hdf5_fortran','hdf5-fortran',&
'hdf5_hl','hdf5','hdf5-serial']
integer :: i,j,k,l
logical :: s,found_hl(size(find_hl)),found
type(string_t) :: log,this_lib
type(string_t), allocatable :: libs(:),flags(:),modules(:),non_fortran(:)
character(len=:), allocatable :: name, include_flag, libdir, ext, pref
include_flag = get_include_flag(compiler,"")
!> Cleanup
call destroy(this)
allocate(this%link_libs(0),this%incl_dirs(0),this%external_modules(0),non_fortran(0))
this%link_flags = string_t("")
this%flags = string_t("")
!> Set name
this%name = "hdf5"
!> Assert pkg-config is installed
if (.not.assert_pkg_config()) then
call fatal_error(error,'hdf5 metapackage requires pkg-config')
return
end if
!> Find pkg-config package file by priority
name = 'NOT_FOUND'
find_package: do i=1,size(candidates)
if (pkgcfg_has_package(trim(candidates(i)))) then
name = trim(candidates(i))
exit find_package
end if
end do find_package
!> some distros put hdf5-1.2.3.pc with version number in .pc filename.
if (name=='NOT_FOUND') then
modules = pkgcfg_list_all(error)
find_global_package: do i=1,size(modules)
if (str_begins_with_str(modules(i)%s,'hdf5')) then
name = modules(i)%s
exit find_global_package
end if
end do find_global_package
end if
if (name=='NOT_FOUND') then
call fatal_error(error,'pkg-config could not find a suitable hdf5 package.')
return
end if
call add_pkg_config_compile_options(this, name, include_flag, libdir, error)
if (allocated(error)) return
! Some pkg-config hdf5.pc (e.g. Ubuntu) don't include the commonly-used HL HDF5 libraries,
! so let's add them if they exist
if (len_trim(libdir)>0) then
do i=1,size(this%link_libs)
found_hl = .false.
if (.not.str_ends_with(this%link_libs(i)%s, find_hl)) then
! Extract name with no extension
call lib_get_trailing(this%link_libs(i)%s, libdir, pref, ext, found)
! Search how many versions with the Fortran endings there are
finals: do k=1,size(find_hl)
do j=1,size(this%link_libs)
if (str_begins_with_str(this%link_libs(j)%s,this%link_libs(i)%s) .and. &
str_ends_with(this%link_libs(j)%s,trim(find_hl(k)))) then
found_hl(k) = .true.
cycle finals
end if
end do
end do finals
! For each of the missing ones, if there is a file, add it
add_missing: do k=1,size(find_hl)
if (found_hl(k)) cycle add_missing
! Build file name
this_lib%s = join_path(libdir,pref//this%link_libs(i)%s//trim(find_hl(k))//ext)
inquire(file=this_lib%s,exist=found)
! File exists, but it is not linked against
if (found) call add_strings(this%link_libs, &
string_t(this%link_libs(i)%s//trim(find_hl(k))))
end do add_missing
end if
end do
endif
!> Add HDF5 modules as external
this%has_external_modules = .true.
this%external_modules = [string_t('h5a'), &
string_t('h5d'), &
string_t('h5es'), &
string_t('h5e'), &
string_t('h5f'), &
string_t('h5g'), &
string_t('h5i'), &
string_t('h5l'), &
string_t('h5o'), &
string_t('h5p'), &
string_t('h5r'), &
string_t('h5s'), &
string_t('h5t'), &
string_t('h5vl'), &
string_t('h5z'), &
string_t('h5lt'), &
string_t('h5lib'), &
string_t('h5global'), &
string_t('h5_gen'), &
string_t('h5fortkit'), &
string_t('hdf5')]
end subroutine init_hdf5
end module fpm_meta_hdf5
fortran-lang-fpm-90bb83a/src/metapackage/fpm_meta_blas.f90 0000664 0001750 0001750 00000007232 15145116760 023636 0 ustar alastair alastair module fpm_meta_blas
use fpm_compiler, only: compiler_t, get_include_flag
use fpm_environment, only: get_os_type, OS_MACOS, OS_WINDOWS
use fpm_meta_base, only: metapackage_t, destroy
use fpm_meta_util, only: add_pkg_config_compile_options
use fpm_pkg_config, only: assert_pkg_config, pkgcfg_has_package
use fpm_manifest_metapackages, only: metapackage_request_t
use fpm_strings, only: string_t
use fpm_error, only: error_t, fatal_error
implicit none
private
public :: init_blas
contains
!> Initialize blas metapackage for the current system
subroutine init_blas(this, compiler, all_meta, error)
class(metapackage_t), intent(inout) :: this
type(compiler_t), intent(in) :: compiler
type(metapackage_request_t), intent(in) :: all_meta(:)
type(error_t), allocatable, intent(out) :: error
integer :: i
character(len=:), allocatable :: include_flag, libdir
character(*), parameter :: candidates(*) = &
[character(20) :: 'mkl-dynamic-lp64-tbb', 'openblas', 'blas', 'flexiblas']
include_flag = get_include_flag(compiler, "")
!> Cleanup
call destroy(this)
allocate (this%link_libs(0), this%incl_dirs(0), this%external_modules(0))
this%link_flags = string_t("")
this%flags = string_t("")
this%has_external_modules = .false.
!> Set name
this%name = ""
if (get_os_type() == OS_MACOS) then
if (compile_and_link_flags_supported(compiler, "-framework Accelerate")) then
call set_compile_and_link_flags(this, compiler, "-framework Accelerate")
return
end if
end if
if (compiler%is_intel()) then
if (get_os_type() == OS_WINDOWS) then
if (compile_and_link_flags_supported(compiler, "/Qmkl")) then
call set_compile_and_link_flags(this, compiler, "/Qmkl")
return
end if
else if (compile_and_link_flags_supported(compiler, "-qmkl")) then
call set_compile_and_link_flags(this, compiler, "-qmkl")
return
endif
end if
!> Assert pkg-config is installed
if (.not. assert_pkg_config()) then
call fatal_error(error, 'blas metapackage requires pkg-config to continue lookup')
return
end if
do i = 1, size(candidates)
if (pkgcfg_has_package(trim(candidates(i)))) then
call add_pkg_config_compile_options( &
this, trim(candidates(i)), include_flag, libdir, error)
print *, 'found blas package: ', trim(candidates(i))
return
end if
end do
call fatal_error(error, 'pkg-config could not find a suitable blas package.')
end subroutine init_blas
function compile_and_link_flags_supported(compiler, flags) result(is_supported)
type(compiler_t), intent(in) :: compiler
character(len=*), intent(in) :: flags
logical :: is_supported
is_supported = compiler%check_flags_supported(compile_flags=flags, link_flags=flags)
end function compile_and_link_flags_supported
subroutine set_compile_and_link_flags(this, compiler, flags)
class(metapackage_t), intent(inout) :: this
type(compiler_t), intent(in) :: compiler
character(len=*), intent(in) :: flags
this%flags = string_t(flags)
this%link_flags = string_t(flags)
this%has_build_flags = .true.
this%has_link_flags = .true.
end subroutine set_compile_and_link_flags
end module fpm_meta_blas
fortran-lang-fpm-90bb83a/src/metapackage/fpm_meta_openmp.f90 0000664 0001750 0001750 00000010040 15145116760 024202 0 ustar alastair alastair module fpm_meta_openmp
use fpm_compiler, only: compiler_t, id_gcc, id_f95, id_intel_classic_windows, &
id_intel_llvm_windows, id_intel_classic_nix, id_intel_llvm_nix, &
id_intel_classic_mac, id_pgi, id_nvhpc, id_ibmxl, id_nag, id_lfortran, &
id_flang, id_flang_classic, flag_gnu_openmp, flag_intel_openmp_win, &
flag_intel_openmp, flag_pgi_openmp, flag_nag_openmp, &
flag_lfortran_openmp, flag_flang_openmp
use fpm_strings, only: string_t
use fpm_meta_base, only: metapackage_t, destroy
use fpm_error, only: error_t, fatal_error
use fpm_manifest_metapackages, only: metapackage_request_t
implicit none
private
public :: init_openmp
contains
!> Initialize OpenMP metapackage for the current system
subroutine init_openmp(this,compiler,all_meta,error)
class(metapackage_t), intent(inout) :: this
type(compiler_t), intent(in) :: compiler
type(metapackage_request_t), intent(in) :: all_meta(:)
type(error_t), allocatable, intent(out) :: error
!> Local variables for OpenMP testing
character(:), allocatable :: openmp_flag, link_flag
character(len=*), parameter :: openmp_test_fortran = &
"use omp_lib; if (omp_get_max_threads() <= 0) stop 1; end"
character(len=*), parameter :: openmp_test_c = &
"#include " // new_line('a') // &
"int main() { return omp_get_max_threads() > 0 ? 0 : 1; }"
character(len=*), parameter :: openmp_test_cxx = &
"#include " // new_line('a') // &
"int main() { return omp_get_max_threads() > 0 ? 0 : 1; }"
!> Cleanup
call destroy(this)
!> Set name
this%name = "openmp"
!> Get OpenMP flags based on compiler
which_compiler: select case (compiler%id)
case (id_gcc,id_f95)
openmp_flag = flag_gnu_openmp
link_flag = flag_gnu_openmp
case (id_intel_classic_windows,id_intel_llvm_windows)
openmp_flag = flag_intel_openmp_win
link_flag = flag_intel_openmp_win
case (id_intel_classic_nix,id_intel_classic_mac,&
id_intel_llvm_nix)
openmp_flag = flag_intel_openmp
link_flag = flag_intel_openmp
case (id_pgi,id_nvhpc)
openmp_flag = flag_pgi_openmp
link_flag = flag_pgi_openmp
case (id_ibmxl)
openmp_flag = " -qsmp=omp"
link_flag = " -qsmp=omp"
case (id_nag)
openmp_flag = flag_nag_openmp
link_flag = flag_nag_openmp
case (id_lfortran)
openmp_flag = flag_lfortran_openmp
link_flag = flag_lfortran_openmp
case (id_flang, id_flang_classic)
openmp_flag = flag_flang_openmp
link_flag = flag_flang_openmp
case default
call fatal_error(error,'openmp not supported on compiler '//compiler%name()//' yet')
return
end select which_compiler
!> Test Fortran OpenMP support
if (compiler%check_fortran_source_runs(openmp_test_fortran, openmp_flag, link_flag)) then
this%has_fortran_flags = .true.
this%fflags = string_t(openmp_flag)
endif
!> Test C OpenMP support
if (compiler%check_c_source_runs(openmp_test_c, openmp_flag, link_flag)) then
this%has_c_flags = .true.
this%cflags = string_t(openmp_flag)
endif
!> Test C++ OpenMP support
if (compiler%check_cxx_source_runs(openmp_test_cxx, openmp_flag, link_flag)) then
this%has_cxx_flags = .true.
this%cxxflags = string_t(openmp_flag)
endif
!> Always set link flags when OpenMP is requested
!> The linker needs OpenMP flags regardless of individual compiler support
this%has_link_flags = .true.
this%link_flags = string_t(link_flag)
end subroutine init_openmp
end module fpm_meta_openmp
fortran-lang-fpm-90bb83a/src/metapackage/fpm_meta_mpi.f90 0000664 0001750 0001750 00000146560 15145116760 023512 0 ustar alastair alastair module fpm_meta_mpi
use fpm_compiler, only: compiler_t, id_gcc, get_os_type, OS_WINDOWS, get_include_flag, &
get_module_flag, new_compiler, compiler_name, id_f95, id_intel_classic_windows, &
id_intel_llvm_windows, id_intel_classic_nix, id_intel_llvm_nix, id_intel_classic_mac, &
id_intel_llvm_unknown, id_pgi, id_nvhpc, id_cray
use fpm_filesystem, only: join_path, exists, get_dos_path, run, getline, is_dir, &
get_temp_filename
use fpm_os, only: get_absolute_path
use fpm_error, only: error_t, fatal_error, syntax_error
use fpm_versioning, only: version_t, new_version, regex_version_from_text
use fpm_strings, only: string_t, len_trim, split, str_begins_with_str, str_ends_with, &
remove_newline_characters
use fpm_environment, only: get_env, get_os_type, os_is_unix, OS_MACOS, OS_WINDOWS
use fpm_meta_base, only: metapackage_t, destroy
use fpm_meta_util, only: add_strings
use fpm_manifest_metapackages, only: metapackage_request_t
use fpm_pkg_config, only: run_wrapper
use shlex_module, only: shlex_split => split
implicit none
private
public :: init_mpi, MPI_TYPE_NAME
integer, parameter :: MPI_TYPE_NONE = 0
integer, parameter :: MPI_TYPE_OPENMPI = 1
integer, parameter :: MPI_TYPE_MPICH = 2
integer, parameter :: MPI_TYPE_INTEL = 3
integer, parameter :: MPI_TYPE_MSMPI = 4
!> Debugging information
logical, parameter, private :: verbose = .false.
integer, parameter, private :: LANG_FORTRAN = 1
integer, parameter, private :: LANG_C = 2
integer, parameter, private :: LANG_CXX = 3
character(*), parameter :: LANG_NAME(*) = [character(7) :: 'Fortran','C','C++']
contains
!> Initialize MPI metapackage for the current system
subroutine init_mpi(this,compiler,all_meta,error)
class(metapackage_t), intent(inout) :: this
type(compiler_t), intent(in) :: compiler
type(metapackage_request_t), intent(in) :: all_meta(:)
type(error_t), allocatable, intent(out) :: error
type(string_t), allocatable :: c_wrappers(:),cpp_wrappers(:),fort_wrappers(:)
type(string_t) :: output,fwrap,cwrap,cxxwrap
character(256) :: msg_out
character(len=:), allocatable :: tokens(:)
integer :: wcfit(3),mpilib(3),ic,icpp,i
logical :: found
!> Cleanup
call destroy(this)
!> Set name
this%name = "mpi"
!> Get all candidate MPI wrappers
call mpi_wrappers(compiler,fort_wrappers,c_wrappers,cpp_wrappers)
if (verbose) print 1, size(fort_wrappers),size(c_wrappers),size(cpp_wrappers)
call wrapper_compiler_fit(fort_wrappers,c_wrappers,cpp_wrappers,compiler,wcfit,mpilib,error)
if (allocated(error) .or. all(wcfit==0)) then
!> No wrapper compiler fit. Are we on Windows? use MSMPI-specific search
found = msmpi_init(this,compiler,error)
if (allocated(error)) return
!> All attempts failed
if (.not.found) then
call fatal_error(error,"cannot find MPI wrappers or libraries for "//compiler%name()//" compiler")
return
endif
else
if (wcfit(LANG_FORTRAN)>0) fwrap = fort_wrappers(wcfit(LANG_FORTRAN))
if (wcfit(LANG_C)>0) cwrap = c_wrappers (wcfit(LANG_C))
if (wcfit(LANG_CXX)>0) cxxwrap = cpp_wrappers (wcfit(LANG_CXX))
!> If there's only an available Fortran wrapper, and the compiler's different than fpm's baseline
!> fortran compiler suite, we still want to enable C language flags as that is most likely being
!> ABI-compatible anyways. However, issues may arise.
!> see e.g. Homebrew with clabng C/C++ and GNU fortran at https://gitlab.kitware.com/cmake/cmake/-/issues/18139
if (wcfit(LANG_FORTRAN)>0 .and. all(wcfit([LANG_C,LANG_CXX])==0)) then
cwrap = fort_wrappers(wcfit(LANG_FORTRAN))
cxxwrap = fort_wrappers(wcfit(LANG_FORTRAN))
end if
if (verbose) print *, '+ MPI fortran wrapper: ',fwrap%s
if (verbose) print *, '+ MPI c wrapper: ',cwrap%s
if (verbose) print *, '+ MPI c++ wrapper: ',cxxwrap%s
!> Initialize MPI package from wrapper command
call init_mpi_from_wrappers(this,compiler,mpilib(LANG_FORTRAN),fwrap,cwrap,cxxwrap,error)
if (allocated(error)) return
!> Request Fortran implicit typing
if (mpilib(LANG_FORTRAN)/=MPI_TYPE_INTEL) then
allocate(this%fortran)
this%fortran%implicit_typing = .true.
this%fortran%implicit_external = .true.
endif
end if
!> Not all MPI implementations offer modules mpi and mpi_f08: hence, include them
!> to the list of external modules, so they won't be requested as standard source files
this%has_external_modules = .true.
this%external_modules = [string_t("mpi"),string_t("mpi_f08")]
1 format('MPI wrappers found: fortran=',i0,' c=',i0,' c++=',i0)
end subroutine init_mpi
!> Check if we're on a 64-bit environment
!> Accept answer from https://stackoverflow.com/questions/49141093/get-system-information-with-fortran
logical function is_64bit_environment()
use iso_c_binding, only: c_intptr_t
integer, parameter :: nbits = bit_size(0_c_intptr_t)
is_64bit_environment = nbits==64
end function is_64bit_environment
!> Return a name for the MPI library
pure function MPI_TYPE_NAME(mpilib) result(name)
integer, intent(in) :: mpilib
character(len=:), allocatable :: name
select case (mpilib)
case (MPI_TYPE_NONE); name = "none"
case (MPI_TYPE_OPENMPI); name = "OpenMPI"
case (MPI_TYPE_MPICH); name = "MPICH"
case (MPI_TYPE_INTEL); name = "INTELMPI"
case (MPI_TYPE_MSMPI); name = "MS-MPI"
case default; name = "UNKNOWN"
end select
end function MPI_TYPE_NAME
!> Check if there is a wrapper-compiler fit
subroutine wrapper_compiler_fit(fort_wrappers,c_wrappers,cpp_wrappers,compiler,wrap,mpi,error)
type(string_t), allocatable, intent(in) :: fort_wrappers(:),c_wrappers(:),cpp_wrappers(:)
type(compiler_t), intent(in) :: compiler
type(error_t), allocatable, intent(out) :: error
integer, intent(out), dimension(3) :: wrap, mpi
type(error_t), allocatable :: wrap_error
wrap = 0
mpi = MPI_TYPE_NONE
if (size(fort_wrappers)>0) &
call mpi_compiler_match(LANG_FORTRAN,fort_wrappers,compiler,wrap(LANG_FORTRAN),mpi(LANG_FORTRAN),wrap_error)
if (size(c_wrappers)>0) &
call mpi_compiler_match(LANG_C,c_wrappers,compiler,wrap(LANG_C),mpi(LANG_C),wrap_error)
if (size(cpp_wrappers)>0) &
call mpi_compiler_match(LANG_CXX,cpp_wrappers,compiler,wrap(LANG_CXX),mpi(LANG_CXX),wrap_error)
!> Find a Fortran wrapper for the current compiler
if (all(wrap==0)) then
call fatal_error(error,'no valid wrappers match current compiler, '//compiler_name(compiler))
return
end if
end subroutine wrapper_compiler_fit
!> Check if a local MS-MPI SDK build is found
logical function msmpi_init(this,compiler,error) result(found)
class(metapackage_t), intent(inout) :: this
type(compiler_t), intent(in) :: compiler
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: incdir,windir,libdir,bindir,post,reall,msysdir
type(version_t) :: ver,ver10
type(string_t) :: cpath,msys_path,runner_path
logical :: msys2
!> Default: not found
found = .false.
if (get_os_type()==OS_WINDOWS) then
! to run MSMPI on Windows,
is_minGW: if (compiler%id==id_gcc) then
call compiler_get_version(compiler,ver,msys2,error)
if (allocated(error)) return
endif is_minGW
! Check we're on a 64-bit environment
if (is_64bit_environment()) then
libdir = get_env('MSMPI_LIB64')
post = 'x64'
else
libdir = get_env('MSMPI_LIB32')
post = 'x86'
!> Not working on 32-bit Windows yet
call fatal_error(error,'MS-MPI error: this package requires 64-bit Windows environment')
return
end if
! Check that the runtime is installed
bindir = ""
call get_absolute_path(get_env('MSMPI_BIN'),bindir,error)
if (verbose) print *, '+ %MSMPI_BIN%=',bindir
! In some environments, variable %MSMPI_BIN% is missing (i.e. in GitHub Action images).
! Do a second attempt: search for the default location
if (len_trim(bindir)<=0 .or. allocated(error)) then
if (verbose) print *, '+ %MSMPI_BIN% empty, searching C:\Program Files\Microsoft MPI\Bin\ ...'
call get_absolute_path('C:\Program Files\Microsoft MPI\Bin\mpiexec.exe',bindir,error)
endif
! Third attempt for bash-style shell
if (len_trim(bindir)<=0 .or. allocated(error)) then
if (verbose) print *, '+ %MSMPI_BIN% empty, searching /c/Program Files/Microsoft MPI/Bin/ ...'
call get_absolute_path('/c/Program Files/Microsoft MPI/Bin/mpiexec.exe',bindir,error)
endif
! Do a fourth attempt: search for mpiexec.exe in PATH location
if (len_trim(bindir)<=0 .or. allocated(error)) then
if (verbose) print *, '+ C:\Program Files\Microsoft MPI\Bin\ not found. searching %PATH%...'
call get_mpi_runner(runner_path,verbose,error)
if (.not.allocated(error)) then
if (verbose) print *, '+ mpiexec found: ',runner_path%s
call find_command_location(runner_path%s,bindir,verbose=verbose,error=error)
endif
endif
if (allocated(error)) then
call fatal_error(error,'MS-MPI error: MS-MPI Runtime directory is missing. '//&
'check environment variable %MSMPI_BIN% or that the folder is in %PATH%.')
return
end if
! Success!
found = .true.
! Init ms-mpi
call destroy(this)
! MSYS2 provides a pre-built static msmpi.dll.a library. Use that if possible
use_prebuilt: if (msys2) then
! MSYS executables are in %MSYS_ROOT%/bin
call compiler_get_path(compiler,cpath,error)
if (allocated(error)) return
call get_absolute_path(join_path(cpath%s,'..'),msys_path%s,error)
if (allocated(error)) return
call get_absolute_path(join_path(msys_path%s,'include'),incdir,error)
if (allocated(error)) return
call get_absolute_path(join_path(msys_path%s,'lib'),libdir,error)
if (allocated(error)) return
if (verbose) print 1, 'include',incdir,exists(incdir)
if (verbose) print 1, 'library',libdir,exists(libdir)
! Check that the necessary files exist
call get_absolute_path(join_path(libdir,'libmsmpi.dll.a'),post,error)
if (allocated(error)) return
if (len_trim(post)<=0 .or. .not.exists(post)) then
call fatal_error(error,'MS-MPI available through the MSYS2 system not found. '// &
'Run '// &
'or your system-specific version to install.')
return
end if
! Add dir cpath
this%has_link_flags = .true.
this%link_flags = string_t(' -L'//get_dos_path(libdir,error))
this%has_link_libraries = .true.
this%link_libs = [string_t('msmpi.dll')]
if (allocated(error)) return
this%has_include_dirs = .true.
this%incl_dirs = [string_t(get_dos_path(incdir,error))]
if (allocated(error)) return
else
call fatal_error(error,'MS-MPI cannot work with non-MSYS2 GNU compilers yet')
return
! Add dir path
this%has_link_flags = .true.
this%link_flags = string_t(' -L'//get_dos_path(libdir,error))
this%has_link_libraries = .true.
this%link_libs = [string_t('msmpi'),string_t('msmpifec'),string_t('msmpifmc')]
if (allocated(error)) return
this%has_include_dirs = .true.
this%incl_dirs = [string_t(get_dos_path(incdir,error)), &
string_t(get_dos_path(incdir//post,error))]
if (allocated(error)) return
end if use_prebuilt
!> Request Fortran implicit typing
allocate(this%fortran)
this%fortran%implicit_typing = .true.
this%fortran%implicit_external = .true.
! gfortran>=10 is incompatible with the old-style mpif.h MS-MPI headers.
! If so, add flags to allow old-style BOZ constants in mpif.h
allow_BOZ: if (compiler%id==id_gcc) then
call new_version(ver10,'10.0.0',error)
if (allocated(error)) return
if (ver>=ver10) then
this%has_build_flags = .true.
this%flags = string_t(' -fallow-invalid-boz')
end if
endif allow_BOZ
!> Add default run command
this%has_run_command = .true.
this%run_command = string_t(join_path(get_dos_path(bindir,error),'mpiexec.exe')//' -np * ')
else
!> Not on Windows
found = .false.
end if
1 format('MSMSPI ',a,' directory: PATH=',a,' EXISTS=',l1)
end function msmpi_init
!> Check if we're under a WSL bash shell
logical function wsl_shell()
if (get_os_type()==OS_WINDOWS) then
wsl_shell = exists('/proc/sys/fs/binfmt_misc/WSLInterop')
else
wsl_shell = .false.
endif
end function wsl_shell
!> Find the location of a valid command
subroutine find_command_location(command,path,echo,verbose,error)
character(*), intent(in) :: command
character(len=:), allocatable, intent(out) :: path
logical, optional, intent(in) :: echo,verbose
type(error_t), allocatable, intent(out) :: error
character(:), allocatable :: tmp_file,screen_output,line,fullpath,search_command
integer :: stat,iunit,ire,length,try
character(*), parameter :: search(2) = ["where ","which "]
if (len_trim(command)<=0) then
call fatal_error(error,'empty command provided in find_command_location')
return
end if
tmp_file = get_temp_filename()
! On Windows, we try both commands because we may be on WSL
do try=merge(1,2,get_os_type()==OS_WINDOWS),2
search_command = search(try)//command
call run(search_command, echo=echo, exitstat=stat, verbose=verbose, redirect=tmp_file)
if (stat==0) exit
end do
if (stat/=0) then
call fatal_error(error,'find_command_location failed for '//command)
return
end if
! Only read first instance (first line)
allocate(character(len=0) :: screen_output)
open(newunit=iunit,file=tmp_file,status='old',iostat=stat)
if (stat == 0)then
do
call getline(iunit, line, stat)
if (stat /= 0) exit
if (len(screen_output)>0) then
screen_output = screen_output//new_line('a')//line
else
screen_output = line
endif
end do
! Close and delete file
close(iunit,status='delete')
else
call fatal_error(error,'cannot read temporary file from successful find_command_location')
return
endif
! Only use the first instance
length = index(screen_output,new_line('a'))
multiline: if (length>1) then
fullpath = screen_output(1:length-1)
else
fullpath = screen_output
endif multiline
if (len_trim(fullpath)<1) then
call fatal_error(error,'no paths found to command ('//command//')')
return
end if
! Extract path only
length = index(fullpath,command,BACK=.true.)
if (length<=0) then
call fatal_error(error,'full path to command ('//command//') does not include command name')
return
elseif (length==1) then
! Compiler is in the current folder
path = '.'
else
path = fullpath(1:length-1)
end if
if (allocated(error)) return
! On Windows, be sure to return a path with no spaces
if (get_os_type()==OS_WINDOWS) path = get_dos_path(path,error)
if (allocated(error) .or. .not.is_dir(path)) then
call fatal_error(error,'full path ('//path//') to command ('//command//') is not a directory')
return
end if
end subroutine find_command_location
!> Get MPI runner in $PATH
subroutine get_mpi_runner(command,verbose,error)
type(string_t), intent(out) :: command
logical, intent(in) :: verbose
type(error_t), allocatable, intent(out) :: error
character(*), parameter :: try(*) = [character(11) :: 'mpiexec','mpirun','mpiexec.exe','mpirun.exe','srun']
character(:), allocatable :: bindir
integer :: itri
logical :: success
! Try several commands
do itri=1,size(try)
call find_command_location(trim(try(itri)),command%s,verbose=verbose,error=error)
if (allocated(error)) cycle
! Success!
success = len_trim(command%s)>0
if (success) then
if (verbose) print *, '+ runner folder found: '//command%s
command%s = join_path(command%s,trim(try(itri)))
return
endif
end do
! On windows, also search in %MSMPI_BIN%
if (get_os_type()==OS_WINDOWS) then
! Check that the runtime is installed
bindir = ""
call get_absolute_path(get_env('MSMPI_BIN'),bindir,error)
if (verbose) print *, '+ %MSMPI_BIN%=',bindir
! In some environments, variable %MSMPI_BIN% is missing (i.e. in GitHub Action images).
! Do a second attempt: search for the default location
if (len_trim(bindir)<=0 .or. allocated(error)) then
if (verbose) print *, '+ %MSMPI_BIN% empty, searching C:\Program Files\Microsoft MPI\Bin\ ...'
call get_absolute_path('C:\Program Files\Microsoft MPI\Bin\mpiexec.exe',bindir,error)
endif
if (len_trim(bindir)>0 .and. .not.allocated(error)) then
! MSMPI_BIN directory found
command%s = join_path(bindir,'mpiexec.exe')
return
endif
endif
! No valid command found
call fatal_error(error,'cannot find a valid mpi runner command')
return
end subroutine get_mpi_runner
!> Return compiler path
subroutine compiler_get_path(self,path,error)
type(compiler_t), intent(in) :: self
type(string_t), intent(out) :: path
type(error_t), allocatable, intent(out) :: error
call find_command_location(self%fc,path%s,self%echo,self%verbose,error)
end subroutine compiler_get_path
!> Return compiler version
subroutine compiler_get_version(self,version,is_msys2,error)
type(compiler_t), intent(in) :: self
type(version_t), intent(out) :: version
logical, intent(out) :: is_msys2
type(error_t), allocatable, intent(out) :: error
character(:), allocatable :: tmp_file,screen_output,line
type(string_t) :: ver
integer :: stat,iunit,ire,length
is_msys2 = .false.
select case (self%id)
case (id_gcc)
tmp_file = get_temp_filename()
call run(self%fc // " --version ", echo=self%echo, verbose=self%verbose, redirect=tmp_file, exitstat=stat)
if (stat/=0) then
call fatal_error(error,'compiler_get_version failed for '//self%fc)
return
end if
allocate(character(len=0) :: screen_output)
open(newunit=iunit,file=tmp_file,status='old',iostat=stat)
if (stat == 0)then
do
call getline(iunit, line, stat)
if (stat /= 0) exit
screen_output = screen_output//' '//line//' '
end do
! Close and delete file
close(iunit,status='delete')
else
call fatal_error(error,'cannot read temporary file from successful compiler_get_version')
return
endif
! Check if this gcc is from the MSYS2 project
is_msys2 = index(screen_output,'MSYS2')>0
ver = regex_version_from_text(screen_output,self%fc//' compiler',error)
if (allocated(error)) return
! Extract version
call new_version(version,ver%s,error)
case default
call fatal_error(error,'compiler_get_version not yet implemented for compiler '//self%fc)
return
end select
end subroutine compiler_get_version
!> Initialize an MPI metapackage from a valid wrapper command ('mpif90', etc...)
subroutine init_mpi_from_wrappers(this,compiler,mpilib,fort_wrapper,c_wrapper,cxx_wrapper,error)
class(metapackage_t), intent(inout) :: this
type(compiler_t), intent(in) :: compiler
integer, intent(in) :: mpilib
type(string_t), intent(in) :: fort_wrapper,c_wrapper,cxx_wrapper
type(error_t), allocatable, intent(out) :: error
type(version_t) :: version
type(error_t), allocatable :: runner_error
! Cleanup structure
call destroy(this)
! Get linking flags
this%link_flags = mpi_wrapper_query(mpilib,fort_wrapper,'link',verbose,error)
if (allocated(error)) return
! Remove useless/dangerous flags
call filter_link_arguments(compiler,this%link_flags)
this%has_link_flags = len_trim(this%link_flags)>0
! Request to use libs in arbitrary order
if (this%has_link_flags .and. compiler%is_gnu() .and. os_is_unix() .and. get_os_type()/=OS_MACOS) then
this%link_flags = string_t(' -Wl,--start-group '//this%link_flags%s)
end if
! Add language-specific flags
call set_language_flags(compiler,mpilib,fort_wrapper,this%has_fortran_flags,this%fflags,verbose,error)
if (allocated(error)) return
call set_language_flags(compiler,mpilib,c_wrapper,this%has_c_flags,this%cflags,verbose,error)
if (allocated(error)) return
call set_language_flags(compiler,mpilib,cxx_wrapper,this%has_cxx_flags,this%cxxflags,verbose,error)
if (allocated(error)) return
! Get library version
version = mpi_version_get(mpilib,fort_wrapper,error)
if (allocated(error)) then
return
else
allocate(this%version,source=version)
end if
!> Add default run command, if present
this%run_command = mpi_wrapper_query(mpilib,fort_wrapper,'runner',verbose,runner_error)
this%has_run_command = (len_trim(this%run_command)>0) .and. .not.allocated(runner_error)
contains
subroutine set_language_flags(compiler,mpilib,wrapper,has_flags,flags,verbose,error)
type(compiler_t), intent(in) :: compiler
integer, intent(in) :: mpilib
type(string_t), intent(in) :: wrapper
logical, intent(inout) :: has_flags
type(string_t), intent(inout) :: flags
logical, intent(in) :: verbose
type(error_t), allocatable, intent(out) :: error
! Get build flags for each language
if (len_trim(wrapper)>0) then
flags = mpi_wrapper_query(mpilib,wrapper,'flags',verbose,error)
if (allocated(error)) return
has_flags = len_trim(flags)>0
! Add heading space
flags = string_t(' '//flags%s)
if (verbose) print *, '+ MPI language flags from wrapper <',wrapper%s,'>: flags=',flags%s
call filter_build_arguments(compiler,flags)
endif
end subroutine set_language_flags
end subroutine init_mpi_from_wrappers
!> Match one of the available compiler wrappers with the current compiler
subroutine mpi_compiler_match(language,wrappers,compiler,which_one,mpilib,error)
integer, intent(in) :: language
type(string_t), intent(in) :: wrappers(:)
type(compiler_t), intent(in) :: compiler
integer, intent(out) :: which_one, mpilib
type(error_t), allocatable, intent(out) :: error
integer :: i, same_vendor, vendor_mpilib
type(string_t) :: screen
character(128) :: msg_out
type(compiler_t) :: mpi_compiler
which_one = 0
same_vendor = 0
mpilib = MPI_TYPE_NONE
if (verbose) print *, '+ Trying to match available ',LANG_NAME(language),' MPI wrappers to ',compiler%fc,'...'
do i=1,size(wrappers)
mpilib = which_mpi_library(wrappers(i),compiler,verbose=.false.)
screen = mpi_wrapper_query(mpilib,wrappers(i),'compiler',verbose=.false.,error=error)
if (allocated(error)) return
if (verbose) print *, ' Wrapper ',wrappers(i)%s,' lib=',MPI_TYPE_NAME(mpilib),' uses ',screen%s
select case (language)
case (LANG_FORTRAN)
! Build compiler type. The ID is created based on the Fortran name
call new_compiler(mpi_compiler,screen%s,'','',echo=.true.,verbose=.false.)
! Fortran match found!
if (mpi_compiler%id == compiler%id) then
which_one = i
return
end if
case (LANG_C)
! For other languages, we can only hope that the name matches the expected one
if (screen%s==compiler%cc .or. screen%s==compiler%fc) then
which_one = i
return
end if
case (LANG_CXX)
if (screen%s==compiler%cxx .or. screen%s==compiler%fc) then
which_one = i
return
end if
end select
! Because the intel mpi library does not support llvm_ compiler wrappers yet,
! we must check for that manually
if (is_intel_classic_option(language,same_vendor,screen,compiler,mpi_compiler)) then
same_vendor = i
vendor_mpilib = mpilib
end if
end do
! Intel compiler: if an exact match is not found, attempt closest wrapper
if (which_one==0 .and. same_vendor>0) then
which_one = same_vendor
mpilib = vendor_mpilib
end if
! None of the available wrappers matched the current Fortran compiler
write(msg_out,1) size(wrappers),compiler%fc
call fatal_error(error,trim(msg_out))
1 format(' None out of ',i0,' valid MPI wrappers matches compiler ',a)
end subroutine mpi_compiler_match
!> Because the Intel mpi library does not support llvm_ compiler wrappers yet,
!> we must save the Intel-classic option and later manually replace it
logical function is_intel_classic_option(language,same_vendor_ID,screen_out,compiler,mpi_compiler)
integer, intent(in) :: language,same_vendor_ID
type(string_t), intent(in) :: screen_out
type(compiler_t), intent(in) :: compiler,mpi_compiler
if (same_vendor_ID/=0) then
is_intel_classic_option = .false.
else
select case (language)
case (LANG_FORTRAN)
is_intel_classic_option = mpi_compiler%is_intel() .and. compiler%is_intel()
case (LANG_C)
is_intel_classic_option = screen_out%s=='icc' .and. compiler%cc=='icx'
case (LANG_CXX)
is_intel_classic_option = screen_out%s=='icpc' .and. compiler%cc=='icpx'
end select
end if
end function is_intel_classic_option
!> Return library version from the MPI wrapper command
type(version_t) function mpi_version_get(mpilib,wrapper,error)
integer, intent(in) :: mpilib
type(string_t), intent(in) :: wrapper
type(error_t), allocatable, intent(out) :: error
type(string_t) :: version_line
! Get version string
version_line = mpi_wrapper_query(mpilib,wrapper,'version',error=error)
if (allocated(error)) return
! Wrap to object
call new_version(mpi_version_get,version_line%s,error)
end function mpi_version_get
!> Return several mpi wrappers, and return
subroutine mpi_wrappers(compiler,fort_wrappers,c_wrappers,cpp_wrappers)
type(compiler_t), intent(in) :: compiler
type(string_t), allocatable, intent(out) :: c_wrappers(:),cpp_wrappers(:),fort_wrappers(:)
character(len=:), allocatable :: mpi_root,intel_wrap
type(error_t), allocatable :: error
! Attempt gathering MPI wrapper names from the environment variables
c_wrappers = [string_t(get_env('MPICC' ,'mpicc'))]
cpp_wrappers = [string_t(get_env('MPICXX','mpic++'))]
fort_wrappers = [string_t(get_env('MPIFC' ,'mpifc' )),&
string_t(get_env('MPIf90','mpif90')),&
string_t(get_env('MPIf77','mpif77'))]
if (get_os_type()==OS_WINDOWS) then
call add_strings(c_wrappers,[string_t('mpicc.bat')])
call add_strings(cpp_wrappers,[string_t('mpicxx.bat')])
call add_strings(fort_wrappers,[string_t('mpifc.bat')])
endif
! Add compiler-specific wrappers
compiler_specific: select case (compiler%id)
case (id_gcc,id_f95)
call add_strings(c_wrappers,[string_t('mpigcc'),string_t('mpgcc')])
call add_strings(cpp_wrappers,[string_t('mpig++'),string_t('mpg++')])
call add_strings(fort_wrappers,[string_t('mpigfortran'),string_t('mpgfortran'),&
string_t('mpig77'),string_t('mpg77')])
case (id_intel_classic_windows,id_intel_classic_nix,id_intel_classic_mac)
c_wrappers = [string_t(get_env('I_MPI_CC' ,'mpiicc'))]
cpp_wrappers = [string_t(get_env('I_MPI_CXX','mpiicpc'))]
fort_wrappers = [string_t(get_env('I_MPI_F90','mpiifort'))]
! Also search MPI wrappers via the base MPI folder
mpi_root = get_env('I_MPI_ROOT')
if (mpi_root/="") then
mpi_root = join_path(mpi_root,'bin')
intel_wrap = join_path(mpi_root,'mpiifort')
if (get_os_type()==OS_WINDOWS) intel_wrap = get_dos_path(intel_wrap,error)
if (intel_wrap/="") call add_strings(fort_wrappers,[string_t(intel_wrap)])
intel_wrap = join_path(mpi_root,'mpiicc')
if (get_os_type()==OS_WINDOWS) intel_wrap = get_dos_path(intel_wrap,error)
if (intel_wrap/="") call add_strings(c_wrappers,[string_t(intel_wrap)])
intel_wrap = join_path(mpi_root,'mpiicpc')
if (get_os_type()==OS_WINDOWS) intel_wrap = get_dos_path(intel_wrap,error)
if (intel_wrap/="") call add_strings(cpp_wrappers,[string_t(intel_wrap)])
end if
case (id_intel_llvm_windows,id_intel_llvm_nix,id_intel_llvm_unknown)
c_wrappers = [string_t(get_env('I_MPI_CC' ,'mpiicx'))]
cpp_wrappers = [string_t(get_env('I_MPI_CXX','mpiicpx'))]
fort_wrappers = [string_t(get_env('I_MPI_F90','mpiifx'))]
! Also search MPI wrappers via the base MPI folder
mpi_root = get_env('I_MPI_ROOT')
if (mpi_root/="") then
mpi_root = join_path(mpi_root,'bin')
intel_wrap = join_path(mpi_root,'mpiifx')
if (get_os_type()==OS_WINDOWS) intel_wrap = get_dos_path(intel_wrap,error)
if (intel_wrap/="") call add_strings(fort_wrappers,[string_t(intel_wrap)])
intel_wrap = join_path(mpi_root,'mpiicx')
if (get_os_type()==OS_WINDOWS) intel_wrap = get_dos_path(intel_wrap,error)
if (intel_wrap/="") call add_strings(c_wrappers,[string_t(intel_wrap)])
intel_wrap = join_path(mpi_root,'mpiicpx')
if (get_os_type()==OS_WINDOWS) intel_wrap = get_dos_path(intel_wrap,error)
if (intel_wrap/="") call add_strings(cpp_wrappers,[string_t(intel_wrap)])
end if
case (id_pgi,id_nvhpc)
call add_strings(c_wrappers,[string_t('mpipgicc'),string_t('mpgcc')])
call add_strings(cpp_wrappers,[string_t('mpipgic++')])
call add_strings(fort_wrappers,[string_t('mpipgifort'),string_t('mpipgf90')])
case (id_cray)
call add_strings(c_wrappers,[string_t('cc')])
call add_strings(cpp_wrappers,[string_t('CC')])
call add_strings(fort_wrappers,[string_t('ftn')])
end select compiler_specific
call assert_mpi_wrappers('Fortran',fort_wrappers,compiler)
call assert_mpi_wrappers('C',c_wrappers,compiler)
call assert_mpi_wrappers('C++',cpp_wrappers,compiler)
end subroutine mpi_wrappers
!> Filter out invalid/unavailable mpi wrappers
subroutine assert_mpi_wrappers(language,wrappers,compiler,verbose)
character(*), intent(in) :: language
type(string_t), allocatable, intent(inout) :: wrappers(:)
type(compiler_t), intent(in) :: compiler
logical, optional, intent(in) :: verbose
integer :: i
integer, allocatable :: works(:)
allocate(works(size(wrappers)))
do i=1,size(wrappers)
if (present(verbose)) then
if (verbose) print *, '+ MPI <',language,'> test wrapper <',wrappers(i)%s,'>'
endif
works(i) = which_mpi_library(wrappers(i),compiler,verbose)
end do
! Filter out non-working wrappers
wrappers = pack(wrappers,works/=MPI_TYPE_NONE)
end subroutine assert_mpi_wrappers
!> Get MPI library type from the wrapper command. Currently, only OpenMPI is supported
integer function which_mpi_library(wrapper,compiler,verbose)
type(string_t), intent(in) :: wrapper
type(compiler_t), intent(in) :: compiler
logical, intent(in), optional :: verbose
logical :: is_mpi_wrapper
integer :: stat
! Init as currently unsupported library
which_mpi_library = MPI_TYPE_NONE
if (len_trim(wrapper)<=0) return
! Run mpi wrapper first
call run_wrapper(wrapper,verbose=verbose,cmd_success=is_mpi_wrapper)
if (is_mpi_wrapper) then
if (compiler%is_intel()) then
which_mpi_library = MPI_TYPE_INTEL
return
end if
! Attempt to decipher which library this wrapper comes from.
! OpenMPI responds to '--showme' calls
call run_wrapper(wrapper,[string_t('--showme')],verbose,&
exitcode=stat,cmd_success=is_mpi_wrapper)
if (stat==0 .and. is_mpi_wrapper) then
which_mpi_library = MPI_TYPE_OPENMPI
return
endif
! MPICH responds to '-show' calls
call run_wrapper(wrapper,[string_t('-show')],verbose,&
exitcode=stat,cmd_success=is_mpi_wrapper)
if (stat==0 .and. is_mpi_wrapper) then
which_mpi_library = MPI_TYPE_MPICH
return
endif
end if
end function which_mpi_library
!> Test if an MPI wrapper works
type(string_t) function mpi_wrapper_query(mpilib,wrapper,command,verbose,error) result(screen)
integer, intent(in) :: mpilib
type(string_t), intent(in) :: wrapper
character(*), intent(in) :: command
logical, intent(in), optional :: verbose
type(error_t), allocatable, intent(out) :: error
logical :: success
character(:), allocatable :: redirect_str,tokens(:),unsupported_msg
type(string_t) :: cmdstr
type(compiler_t) :: mpi_compiler
integer :: stat,cmdstat,ire,length
unsupported_msg = 'the MPI library of wrapper '//wrapper%s//' does not support task '//trim(command)
select case (command)
! Get MPI compiler name
case ('compiler')
select case (mpilib)
case (MPI_TYPE_OPENMPI); cmdstr = string_t('--showme:command')
case (MPI_TYPE_MPICH); cmdstr = string_t('-compile-info')
case (MPI_TYPE_INTEL); cmdstr = string_t('-show')
case default
call fatal_error(error,unsupported_msg)
return
end select
call run_wrapper(wrapper,[cmdstr],verbose=verbose, &
exitcode=stat,cmd_success=success,screen_output=screen)
if (stat/=0 .or. .not.success) then
call syntax_error(error,'local '//MPI_TYPE_NAME(mpilib)//&
' library wrapper does not support flag '//cmdstr%s)
return
end if
! Take out the first command from the whole line
call remove_newline_characters(screen)
call split(screen%s,tokens,delimiters=' ')
screen%s = trim(adjustl(tokens(1)))
! Get a list of additional compiler flags
case ('flags')
select case (mpilib)
case (MPI_TYPE_OPENMPI); cmdstr = string_t('--showme:compile')
case (MPI_TYPE_MPICH); cmdstr = string_t('-compile-info')
case (MPI_TYPE_INTEL); cmdstr = string_t('-show')
case default
call fatal_error(error,unsupported_msg)
return
end select
call run_wrapper(wrapper,[cmdstr],verbose=verbose, &
exitcode=stat,cmd_success=success,screen_output=screen)
if (stat/=0 .or. .not.success) then
call syntax_error(error,'local '//MPI_TYPE_NAME(mpilib)//&
' library wrapper does not support flag '//cmdstr%s)
return
end if
! Post-process output
select case (mpilib)
case (MPI_TYPE_OPENMPI)
! This library reports the compiler name only
call remove_newline_characters(screen)
case (MPI_TYPE_MPICH,MPI_TYPE_INTEL)
! These libraries report the full command including the compiler name. Remove it if so
call remove_newline_characters(screen)
call split(screen%s,tokens)
! Remove trailing compiler name
screen%s = screen%s(len_trim(tokens(1))+1:)
case default
call fatal_error(error,'invalid MPI library type')
return
end select
! Get a list of additional linker flags
case ('link')
select case (mpilib)
case (MPI_TYPE_OPENMPI); cmdstr = string_t('--showme:link')
case (MPI_TYPE_MPICH); cmdstr = string_t('-link-info')
case (MPI_TYPE_INTEL); cmdstr = string_t('-show')
case default
call fatal_error(error,unsupported_msg)
return
end select
call run_wrapper(wrapper,[cmdstr],verbose=verbose, &
exitcode=stat,cmd_success=success,screen_output=screen)
if (stat/=0 .or. .not.success) then
call syntax_error(error,'local '//MPI_TYPE_NAME(mpilib)//&
' library wrapper does not support flag '//cmdstr%s)
return
end if
select case (mpilib)
case (MPI_TYPE_OPENMPI)
call remove_newline_characters(screen)
case (MPI_TYPE_MPICH,MPI_TYPE_INTEL)
! MPICH reports the full command including the compiler name. Remove it if so
call remove_newline_characters(screen)
call split(screen%s,tokens)
! Remove trailing compiler name
screen%s = screen%s(len_trim(tokens(1))+1:)
case default
call fatal_error(error,unsupported_msg)
return
end select
! Get a list of MPI library directories
case ('link_dirs')
select case (mpilib)
case (MPI_TYPE_OPENMPI)
! --showme:command returns the build command of this wrapper
call run_wrapper(wrapper,[string_t('--showme:libdirs')],verbose=verbose, &
exitcode=stat,cmd_success=success,screen_output=screen)
if (stat/=0 .or. .not.success) then
call syntax_error(error,'local OpenMPI library does not support --showme:libdirs')
return
end if
case default
call fatal_error(error,unsupported_msg)
return
end select
! Get a list of include directories for the MPI headers/modules
case ('incl_dirs')
select case (mpilib)
case (MPI_TYPE_OPENMPI)
! --showme:command returns the build command of this wrapper
call run_wrapper(wrapper,[string_t('--showme:incdirs')],verbose=verbose, &
exitcode=stat,cmd_success=success,screen_output=screen)
if (stat/=0 .or. .not.success) then
call syntax_error(error,'local OpenMPI library does not support --showme:incdirs')
return
end if
case default
call fatal_error(error,unsupported_msg)
return
end select
call remove_newline_characters(screen)
! Retrieve library version
case ('version')
select case (mpilib)
case (MPI_TYPE_OPENMPI)
! --showme:command returns the build command of this wrapper
call run_wrapper(wrapper,[string_t('--showme:version')],verbose=verbose, &
exitcode=stat,cmd_success=success,screen_output=screen)
if (stat/=0 .or. .not.success) then
call syntax_error(error,'local OpenMPI library does not support --showme:version')
return
else
call remove_newline_characters(screen)
end if
case (MPI_TYPE_MPICH)
!> MPICH offers command "mpichversion" in the same system folder as the MPI wrappers.
!> So, attempt to run that first
cmdstr = string_t('mpichversion')
call run_wrapper(cmdstr,verbose=verbose, &
exitcode=stat,cmd_success=success,screen_output=screen)
! Second option: run mpich wrapper + "-v"
if (stat/=0 .or. .not.success) then
call run_wrapper(wrapper,[string_t('-v')],verbose=verbose, &
exitcode=stat,cmd_success=success,screen_output=screen)
call remove_newline_characters(screen)
endif
! Third option: mpiexec --version
if (stat/=0 .or. .not.success) then
cmdstr = string_t('mpiexec --version')
call run_wrapper(cmdstr,verbose=verbose, &
exitcode=stat,cmd_success=success,screen_output=screen)
endif
if (stat/=0 .or. .not.success) then
call syntax_error(error, &
'cannot retrieve MPICH library version from ')
return
end if
case (MPI_TYPE_INTEL)
! -v returns the build command of this wrapper
call run_wrapper(wrapper,[string_t('-v')],verbose=verbose, &
exitcode=stat,cmd_success=success,screen_output=screen)
! LLVM wrappers bug: non-zero exit code when checking for "-v" -> only check for
! successful command: https://github.com/spack/spack/issues/47672
if (.not.success) then
call syntax_error(error,'local INTEL MPI library does not support -v')
return
else
call remove_newline_characters(screen)
end if
case default
call fatal_error(error,unsupported_msg)
return
end select
! Extract version
screen = regex_version_from_text(screen%s,MPI_TYPE_NAME(mpilib)//' library',error)
if (allocated(error)) return
! Get path to the MPI runner command
case ('runner')
select case (mpilib)
case (MPI_TYPE_OPENMPI,MPI_TYPE_MPICH,MPI_TYPE_MSMPI,MPI_TYPE_INTEL)
call get_mpi_runner(screen,verbose,error)
case default
call fatal_error(error,unsupported_msg)
return
end select
case default;
call fatal_error(error,'an invalid MPI wrapper command ('//command//&
') was invoked for wrapper <'//wrapper%s//'>.')
return
end select
end function mpi_wrapper_query
!> Check if input is a useful linker argument
logical function is_link_argument(compiler,string)
type(compiler_t), intent(in) :: compiler
character(*), intent(in) :: string
select case (compiler%id)
case (id_intel_classic_windows,id_intel_llvm_windows)
is_link_argument = string=='/link' &
.or. str_begins_with_str(string,'/LIBPATH')&
.or. str_ends_with(string,'.lib') ! always .lib whether static or dynamic
case default
! fix OpenMPI's Fortran wrapper bug (https://github.com/open-mpi/ompi/issues/11636) here
is_link_argument = ( str_begins_with_str(string,'-L') &
.or. str_begins_with_str(string,'-l') &
.or. str_begins_with_str(string,'-Xlinker') &
.or. string=='-pthread' &
.or. (str_begins_with_str(string,'-W') .and. &
(string/='-Wall') .and. (.not.str_begins_with_str(string,'-Werror'))) ) &
.and. .not. ( &
(get_os_type()==OS_MACOS .and. index(string,'-commons,use_dylibs')>0) )
end select
end function is_link_argument
!> From build, remove optimization and other unnecessary flags
subroutine filter_build_arguments(compiler,command)
type(compiler_t), intent(in) :: compiler
type(string_t), intent(inout) :: command
character(len=:), allocatable :: tokens(:)
integer :: i,n,re_i,re_l
logical, allocatable :: keep(:)
logical :: keep_next
character(len=:), allocatable :: module_flag,include_flag
if (len_trim(command)<=0) return
! Split command into arguments
tokens = shlex_split(command%s)
module_flag = get_module_flag(compiler,"")
include_flag = get_include_flag(compiler,"")
n = size(tokens)
allocate(keep(n),source=.false.)
keep_next = .false.
do i=1,n
if (get_os_type()==OS_MACOS .and. index(tokens(i),'-commons,use_dylibs')>0) then
keep(i) = .false.
keep_next = .false.
elseif (str_begins_with_str(tokens(i),'-D') .or. &
str_begins_with_str(tokens(i),'-f') .or. &
str_begins_with_str(tokens(i),'-I') .or. &
str_begins_with_str(tokens(i),module_flag) .or. &
str_begins_with_str(tokens(i),include_flag) .or. &
tokens(i)=='-pthread' .or. &
(str_begins_with_str(tokens(i),'-W') .and. tokens(i)/='-Wall' .and. &
.not.str_begins_with_str(tokens(i),'-Werror')) &
) then
keep(i) = .true.
if (tokens(i)==module_flag .or. tokens(i)==include_flag .or. tokens(i)=='-I') keep_next = .true.
elseif (keep_next) then
keep(i) = .true.
keep_next = .false.
end if
end do
! Backfill
command = string_t("")
do i=1,n
if (.not.keep(i)) cycle
command%s = command%s//' '//trim(tokens(i))
end do
end subroutine filter_build_arguments
!> From the linker flags, remove optimization and other unnecessary flags
subroutine filter_link_arguments(compiler,command)
type(compiler_t), intent(in) :: compiler
type(string_t), intent(inout) :: command
character(len=:), allocatable :: tokens(:)
integer :: i,n
logical, allocatable :: keep(:)
logical :: keep_next
if (len_trim(command)<=0) return
! Split command into arguments
tokens = shlex_split(command%s)
n = size(tokens)
allocate(keep(n),source=.false.)
keep_next = .false.
do i=1,n
if (is_link_argument(compiler,tokens(i))) then
keep(i) = .true.
if (tokens(i)=='-L' .or. tokens(i)=='-Xlinker') keep_next = .true.
elseif (keep_next) then
keep(i) = .true.
keep_next = .false.
end if
end do
! Backfill
command = string_t("")
do i=1,n
if (.not.keep(i)) cycle
command%s = command%s//' '//trim(tokens(i))
end do
end subroutine filter_link_arguments
end module fpm_meta_mpi
fortran-lang-fpm-90bb83a/src/fpm_os.F90 0000664 0001750 0001750 00000021501 15145116760 020021 0 ustar alastair alastair module fpm_os
use, intrinsic :: iso_c_binding, only: c_char, c_int, c_null_char, c_ptr, c_associated
use fpm_filesystem, only: exists, join_path, get_home
use fpm_environment, only: os_is_unix
use fpm_error, only: error_t, fatal_error
implicit none
private
public :: change_directory, get_current_directory, get_absolute_path, convert_to_absolute_path, &
& get_absolute_path_by_cd
integer(c_int), parameter :: buffersize = 1000_c_int
#ifndef _WIN32
character(len=*), parameter :: pwd_env = "PWD"
#else
character(len=*), parameter :: pwd_env = "CD"
#endif
interface
function chdir_(path) result(stat) &
#ifndef _WIN32
bind(C, name="chdir")
#else
bind(C, name="_chdir")
#endif
import :: c_char, c_int
character(kind=c_char, len=1), intent(in) :: path(*)
integer(c_int) :: stat
end function chdir_
function getcwd_(buf, bufsize) result(path) &
#ifndef _WIN32
bind(C, name="getcwd")
#else
bind(C, name="_getcwd")
#endif
import :: c_char, c_int, c_ptr
character(kind=c_char, len=1), intent(in) :: buf(*)
integer(c_int), value, intent(in) :: bufsize
type(c_ptr) :: path
end function getcwd_
!> Determine the absolute, canonicalized path for a given path. Unix-only.
function realpath(path, resolved_path) result(ptr) bind(C)
import :: c_ptr, c_char, c_int
character(kind=c_char, len=1), intent(in) :: path(*)
character(kind=c_char, len=1), intent(out) :: resolved_path(*)
type(c_ptr) :: ptr
end function realpath
!> Determine the absolute, canonicalized path for a given path. Windows-only.
function fullpath(resolved_path, path, maxLength) result(ptr) bind(C, name="_fullpath")
import :: c_ptr, c_char, c_int
character(kind=c_char, len=1), intent(in) :: path(*)
character(kind=c_char, len=1), intent(out) :: resolved_path(*)
integer(c_int), value, intent(in) :: maxLength
type(c_ptr) :: ptr
end function fullpath
!> Determine the absolute, canonicalized path for a given path.
!> Calls custom C routine because the `_WIN32` macro is correctly exported
!> in C using `gfortran`.
function c_realpath(path, resolved_path, maxLength) result(ptr) &
bind(C, name="c_realpath")
import :: c_ptr, c_char, c_int
character(kind=c_char, len=1), intent(in) :: path(*)
character(kind=c_char, len=1), intent(out) :: resolved_path(*)
integer(c_int), value, intent(in) :: maxLength
type(c_ptr) :: ptr
end function c_realpath
end interface
contains
subroutine change_directory(path, error)
character(len=*), intent(in) :: path
type(error_t), allocatable, intent(out) :: error
character(kind=c_char, len=1), allocatable :: cpath(:)
integer :: stat
allocate (cpath(len(path) + 1))
call f_c_character(path, cpath, len(path) + 1)
stat = chdir_(cpath)
if (stat /= 0) then
call fatal_error(error, "Failed to change directory to '"//path//"'")
end if
end subroutine change_directory
subroutine get_current_directory(path, error)
character(len=:), allocatable, intent(out) :: path
type(error_t), allocatable, intent(out) :: error
character(kind=c_char, len=1), allocatable :: cpath(:)
type(c_ptr) :: tmp
allocate (cpath(buffersize))
tmp = getcwd_(cpath, buffersize)
if (c_associated(tmp)) then
call c_f_character(cpath, path)
else
call fatal_error(error, "Failed to retrieve current directory")
end if
end subroutine get_current_directory
subroutine f_c_character(rhs, lhs, len)
character(kind=c_char), intent(out) :: lhs(*)
character(len=*), intent(in) :: rhs
integer, intent(in) :: len
integer :: length
length = min(len - 1, len_trim(rhs))
lhs(1:length) = transfer(rhs(1:length), lhs(1:length))
lhs(length + 1:length + 1) = c_null_char
end subroutine f_c_character
subroutine c_f_character(rhs, lhs)
character(kind=c_char), intent(in) :: rhs(*)
character(len=:), allocatable, intent(out) :: lhs
integer :: ii
do ii = 1, huge(ii) - 1
if (rhs(ii) == c_null_char) then
exit
end if
end do
allocate (character(len=ii - 1) :: lhs)
lhs = transfer(rhs(1:ii - 1), lhs)
end subroutine c_f_character
!> Determine the canonical, absolute path for the given path.
!>
!> Calls a C routine that uses the `_WIN32` macro to determine the correct function.
!>
!> Cannot be used in bootstrap mode.
subroutine get_realpath(path, real_path, error)
character(len=*), intent(in) :: path
character(len=:), allocatable, intent(out) :: real_path
type(error_t), allocatable, intent(out) :: error
character(kind=c_char, len=1), allocatable :: appended_path(:)
character(kind=c_char, len=1), allocatable :: cpath(:)
type(c_ptr) :: ptr
if (.not. exists(path)) then
call fatal_error(error, "Cannot determine absolute path. Path '"//path//"' does not exist.")
return
end if
allocate (appended_path(len(path) + 1))
call f_c_character(path, appended_path, len(path) + 1)
allocate (cpath(buffersize))
#ifndef FPM_BOOTSTRAP
ptr = c_realpath(appended_path, cpath, buffersize)
#endif
if (c_associated(ptr)) then
call c_f_character(cpath, real_path)
else
call fatal_error(error, "Failed to retrieve absolute path for '"//path//"'.")
end if
end subroutine
!> Determine the canonical, absolute path for the given path.
!> Expands home folder (~) on both Unix and Windows.
subroutine get_absolute_path(path, absolute_path, error)
character(len=*), intent(in) :: path
character(len=:), allocatable, intent(out) :: absolute_path
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: home
#ifdef FPM_BOOTSTRAP
call get_absolute_path_by_cd(path, absolute_path, error); return
#endif
if (len_trim(path) < 1) then
call fatal_error(error, 'Path cannot be empty'); return
else if (path(1:1) == '~') then
call get_home(home, error)
if (allocated(error)) return
if (len_trim(path) == 1) then
absolute_path = home; return
end if
if (os_is_unix()) then
if (path(2:2) /= '/') then
call fatal_error(error, "Wrong separator in path: '"//path//"'"); return
end if
else
if (path(2:2) /= '\') then
call fatal_error(error, "Wrong separator in path: '"//path//"'"); return
end if
end if
if (len_trim(path) == 2) then
absolute_path = home; return
end if
absolute_path = join_path(home, path(3:len_trim(path)))
if (.not. exists(absolute_path)) then
call fatal_error(error, "Path not found: '"//absolute_path//"'"); return
end if
else
! Get canonicalized absolute path from either the absolute or the relative path.
call get_realpath(path, absolute_path, error)
end if
end subroutine
!> Alternative to `get_absolute_path` that uses `chdir`/`_chdir` to determine the absolute path.
!>
!> `get_absolute_path` is preferred but `get_absolute_path_by_cd` can be used in bootstrap mode.
subroutine get_absolute_path_by_cd(path, absolute_path, error)
character(len=*), intent(in) :: path
character(len=:), allocatable, intent(out) :: absolute_path
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: current_path
call get_current_directory(current_path, error)
if (allocated(error)) return
call change_directory(path, error)
if (allocated(error)) return
call get_current_directory(absolute_path, error)
if (allocated(error)) return
call change_directory(current_path, error)
if (allocated(error)) return
end subroutine
!> Converts a path to an absolute, canonical path.
subroutine convert_to_absolute_path(path, error)
character(len=:), allocatable, intent(inout) :: path
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: absolute_path
call get_absolute_path(path, absolute_path, error)
path = absolute_path
end subroutine
end module fpm_os
fortran-lang-fpm-90bb83a/src/fpm_meta.f90 0000664 0001750 0001750 00000014217 15145116760 020374 0 ustar alastair alastair !># The fpm meta-package model
!>
!> This is a wrapper data type that encapsulate all pre-processing information
!> (compiler flags, linker libraries, etc.) required to correctly enable a package
!> to use a core library.
!>
!>
!>### Available core libraries
!>
!> - OpenMP
!> - MPI
!> - HDF5
!> - fortran-lang stdlib
!> - fortran-lang minpack
!>
!>
!> @note Core libraries are enabled in the [build] section of the fpm.toml manifest
!>
!>
module fpm_meta
use fpm_compiler, only: compiler_t
use fpm_manifest, only: package_config_t, get_package_data
use fpm_model, only: fpm_model_t
use fpm_command_line, only: fpm_cmd_settings, fpm_build_settings, fpm_run_settings
use fpm_error, only: error_t, syntax_error, fatal_error
use fpm_filesystem, only: join_path
use fpm_meta_base, only: metapackage_t, destroy
use fpm_meta_openmp, only: init_openmp
use fpm_meta_stdlib, only: init_stdlib
use fpm_meta_minpack, only: init_minpack
use fpm_meta_mpi, only: init_mpi
use fpm_meta_hdf5, only: init_hdf5
use fpm_meta_netcdf, only: init_netcdf
use fpm_meta_blas, only: init_blas
use fpm_manifest_metapackages, only: metapackage_request_t, metapackage_config_t
use shlex_module, only: shlex_split => split
use regex_module, only: regex
use iso_fortran_env, only: stdout => output_unit
implicit none
private
public :: resolve_metapackages
interface resolve_metapackages
module procedure resolve_metapackage_model
end interface resolve_metapackages
contains
!> Initialize a metapackage from the given name
subroutine init_from_request(this,request,compiler,all_meta,error)
class(metapackage_t), intent(inout) :: this
type(metapackage_request_t), intent(in) :: request
type(compiler_t), intent(in) :: compiler
!> Pass a list of all metapackage requests so dependencies can be sorted out
type(metapackage_request_t), intent(in) :: all_meta(:)
type(error_t), allocatable, intent(out) :: error
!> Initialize metapackage by name
select case(request%name)
case("openmp"); call init_openmp (this,compiler,all_meta,error)
case("stdlib"); call init_stdlib (this,compiler,all_meta,error)
case("minpack"); call init_minpack(this,compiler,all_meta,error)
case("mpi"); call init_mpi (this,compiler,all_meta,error)
case("hdf5"); call init_hdf5 (this,compiler,all_meta,error)
case("netcdf"); call init_netcdf (this,compiler,all_meta,error)
case("blas"); call init_blas (this,compiler,all_meta,error)
case default
call syntax_error(error, "Package "//request%name//" is not supported in [metapackages]")
return
end select
end subroutine init_from_request
!> Add named metapackage dependency to the model
subroutine add_metapackage_model(model,package,settings,meta,error)
type(fpm_model_t), intent(inout) :: model
type(package_config_t), intent(inout) :: package
class(fpm_cmd_settings), intent(inout) :: settings
type(metapackage_t), intent(inout) :: meta
type(error_t), allocatable, intent(out) :: error
!> Add it into the model
call meta%resolve(model,error)
if (allocated(error)) return
!> Add it into the package
call meta%resolve(package,error)
if (allocated(error)) return
!> Add it into the settings
call meta%resolve(settings,error)
if (allocated(error)) return
! If we need to run executables, there should be an MPI runner
if (meta%name=="mpi") then
select type (settings)
class is (fpm_run_settings) ! run, test
if (.not.meta%has_run_command) &
call fatal_error(error,"cannot find a valid mpi runner on the local host")
end select
endif
end subroutine add_metapackage_model
!> Resolve all metapackages into the package config
subroutine resolve_metapackage_model(model,package,settings,error)
type(fpm_model_t), intent(inout) :: model
type(package_config_t), intent(inout) :: package
class(fpm_build_settings), intent(inout) :: settings
type(error_t), allocatable, intent(out) :: error
integer :: i
type(metapackage_t) :: meta
type(metapackage_request_t), allocatable :: requested(:)
type(metapackage_config_t) :: all_meta
type(package_config_t) :: dep_pkg
character(len=:), allocatable :: manifest_path
! Dependencies are added to the package config, so they're properly resolved
! into the dependency tree later.
! Flags are added to the model (whose compiler needs to be already initialized)
if (model%compiler%is_unknown()) &
write(stdout,'(a)') ' compiler not initialized: metapackages may not be available'
! Build merged metapackage config from main package and all dependencies
! Start with the main package's metapackage requests
all_meta = package%meta
! Merge metapackage requests from all dependencies (if dependency tree exists)
! Skip index 1 (the main package itself)
if (allocated(model%deps%dep)) then
do i = 2, model%deps%ndep
if (.not. allocated(model%deps%dep(i)%proj_dir)) cycle
manifest_path = join_path(model%deps%dep(i)%proj_dir, "fpm.toml")
call get_package_data(dep_pkg, manifest_path, error)
if (allocated(error)) return
call all_meta%merge(dep_pkg%meta)
end do
end if
! Get all requested metapackages (including those from dependencies)
requested = all_meta%get_requests()
if (size(requested) < 1) return
do i = 1, size(requested)
call init_from_request(meta, requested(i), model%compiler, requested, error)
if (allocated(error)) return
call add_metapackage_model(model, package, settings, meta, error)
if (allocated(error)) return
end do
end subroutine resolve_metapackage_model
end module fpm_meta
fortran-lang-fpm-90bb83a/src/fpm_compile_commands.F90 0000664 0001750 0001750 00000040605 15145116760 022717 0 ustar alastair alastair !># Store compiler commands in a `compile_commands.json` table
module fpm_compile_commands
use fpm_toml, only: serializable_t, set_string, set_list, get_value, get_list, add_table, &
toml_array, add_array, toml_stat, len
use tomlf, only: toml_table
use jonquil, only: json_serialize, json_ser_config
use fpm_strings, only: string_t, operator(==)
use fpm_error, only: error_t, syntax_error, fatal_error
use fpm_os, only: get_current_directory
use fpm_environment, only: get_os_type, OS_WINDOWS
use shlex_module, only: sh_split => split, ms_split
implicit none
!> Definition of a build command
type, extends(serializable_t) :: compile_command_t
type(string_t) :: directory
type(string_t), allocatable :: arguments(:)
type(string_t) :: file
contains
!> Operation
procedure :: destroy => compile_command_destroy
!> Serialization interface
procedure :: serializable_is_same => compile_command_is_same
procedure :: dump_to_toml => compile_command_dump_toml
procedure :: load_from_toml => compile_command_load_toml
end type compile_command_t
type, extends(serializable_t) :: compile_command_table_t
type(compile_command_t), allocatable :: command(:)
contains
!> Operation
procedure :: destroy => cct_destroy
procedure :: write => cct_write
procedure, private :: cct_register
procedure, private :: cct_register_object
generic :: register => cct_register, &
cct_register_object
!> Serialization interface
procedure :: serializable_is_same => cct_is_same
procedure :: dump_to_toml => cct_dump_toml
procedure :: load_from_toml => cct_load_toml
end type compile_command_table_t
interface compile_command_t
module procedure cct_new
end interface compile_command_t
!> Add compile commands to array (gcc-15 bug workaround)
interface add_compile_command
module procedure add_compile_command_one
module procedure add_compile_command_many
end interface add_compile_command
contains
!> Override default initializer (GCC 15 bug)
type(compile_command_t) function cct_new(directory,arguments,file) result(cct)
character(len=*), intent(in) :: directory,file
character(len=*), optional, intent(in) :: arguments(:)
integer :: i,n
cct%directory = string_t(trim(directory))
cct%file = string_t(trim(file))
if (present(arguments)) then
n = size(arguments)
else
n = 0
endif
allocate(cct%arguments(n))
do i=1,n
cct%arguments(i) = string_t(trim(arguments(i)))
end do
end function cct_new
!> Cleanup compile command
elemental subroutine compile_command_destroy(self)
!> Instance of the serializable object
class(compile_command_t), intent(inout) :: self
if (allocated(self%directory%s))deallocate(self%directory%s)
if (allocated(self%arguments))deallocate(self%arguments)
if (allocated(self%file%s))deallocate(self%file%s)
end subroutine compile_command_destroy
!> Dump compile_command_t to toml table
subroutine compile_command_dump_toml(self, table, error)
!> Instance of the serializable object
class(compile_command_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call set_list(table, "arguments", self%arguments, error)
if (allocated(error)) return
call set_string(table, "directory", self%directory, error, 'compile_command_t')
if (allocated(error)) return
call set_string(table, "file", self%file, error, 'compile_command_t')
if (allocated(error)) return
end subroutine compile_command_dump_toml
!> Read compile_command_t from toml table (no checks made at this stage)
subroutine compile_command_load_toml(self, table, error)
!> Instance of the serializable object
class(compile_command_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call self%destroy()
call get_list(table, "arguments", self%arguments, error)
if (allocated(error)) return
! Return unallocated value if not present
call get_value(table, "directory", self%directory%s)
call get_value(table, "file", self%file%s)
end subroutine compile_command_load_toml
!> Check that two compile_command_t objects are equal
logical function compile_command_is_same(this,that)
class(compile_command_t), intent(in) :: this
class(serializable_t), intent(in) :: that
compile_command_is_same = .false.
select type (other=>that)
type is (compile_command_t)
if (.not.this%directory==other%directory) return
if (.not.this%arguments==other%arguments) return
if (.not.this%file==other%file) return
class default
! Not the same type
return
end select
!> All checks passed!
compile_command_is_same = .true.
end function compile_command_is_same
!> Dump compile_command_table_t to a toml array
subroutine cct_dump_array(self, array, error)
!> Instance of the serializable object
class(compile_command_table_t), intent(inout) :: self
!> Data structure
type(toml_array), intent(inout) :: array
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: ii, stat
type(toml_table), pointer :: item
if (.not.allocated(self%command)) return
do ii = 1, size(self%command)
associate (cmd => self%command(ii))
! Set node for this command
call add_table(array, item, stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Cannot store entry in compile_command_table_t array")
return
end if
call cmd%dump_to_toml(item, error)
if (allocated(error)) return
endassociate
end do
end subroutine cct_dump_array
!> Write compile_commands.json file. Because Jonquil does not support non-named arrays,
!> create a custom json here.
subroutine cct_write(self, filename, error)
!> Instance of the serializable object
class(compile_command_table_t), intent(inout) :: self
!> The file name
character(*), intent(in) :: filename
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_array) :: array
type(json_ser_config) :: cfg
integer :: stat, lun
! Init array
array = toml_array()
! Dump information to the array
call cct_dump_array(self, array, error)
if (allocated(error)) return
! Open file and write to it
open(newunit=lun,file=filename,form='formatted',action='write',status='replace',iostat=stat)
if (stat/=0) then
call fatal_error(error, 'cannot open file '//filename//' for writing')
return
end if
! Ensure the array has no key
if (allocated(array%key)) deallocate(array%key)
cfg%indent = repeat(' ',3)
write (lun, '(A)', iostat=stat, err=1) json_serialize(array, cfg)
close(lun,iostat=stat)
1 if (stat/=0) then
call fatal_error(error, 'cannot close file '//filename//' after writing')
return
end if
end subroutine cct_write
!> Cleanup a compile command table
elemental subroutine cct_destroy(self)
!> Instance of the serializable object
class(compile_command_table_t), intent(inout) :: self
if (allocated(self%command)) deallocate(self%command)
end subroutine cct_destroy
!> Register a new compile command
subroutine cct_register(self, command, target_os, error)
!> Instance of the serializable object
class(compile_command_table_t), intent(inout) :: self
!> Data structure
character(len=*), intent(in) :: command
!> The target OS of the compile_commands.json (may be cross-compiling)
integer, intent(in) :: target_os
!> Error handling
type(error_t), allocatable, intent(out) :: error
! Local variables
type(compile_command_t) :: cmd
character(len=:), allocatable :: args(:), cwd, source_file
logical :: sh_success
integer :: i,n
! Early check
if (len_trim(command) <= 0) then
call syntax_error(error, "compile_command_table_t trying to register an empty command")
return
end if
! Tokenize the input command into args(:)
if (target_os==OS_WINDOWS) then
args = ms_split(command, ucrt=.true., success=sh_success)
else
args = sh_split(command, join_spaced=.false., keep_quotes=.true., success=sh_success)
end if
n = size(args)
if (n==0 .or. .not.sh_success) then
call syntax_error(error, "compile_command_table_t failed tokenizing: <"//command//">")
return
end if
! Get current working directory
call get_current_directory(cwd, error)
if (allocated(error)) return
! Try to find the source file
allocate(character(len=0) :: source_file)
find_source_file: do i = 1, n-1
if (args(i) == "-c") then
source_file = trim(args(i+1))
exit find_source_file
end if
end do find_source_file
! Fallback: use last argument if not found
if (len_trim(source_file)==0) source_file = trim(args(n))
! Fill in the compile_command_t.
! Use non-default initializer due to gcc 15 bug
cmd = compile_command_t(cwd, args, source_file)
! Add it to the structure
!$omp critical (command_update)
call cct_register_object(self, cmd, error)
!$omp end critical (command_update)
end subroutine cct_register
pure subroutine cct_register_object(self, command, error)
!> Instance of the serializable object
class(compile_command_table_t), intent(inout) :: self
!> Data structure
type(compile_command_t), intent(in) :: command
!> Error handling
type(error_t), allocatable, intent(out) :: error
if (allocated(self%command)) then
call add_compile_command(self%command, command)
else
allocate(self%command(1), source=command)
end if
end subroutine cct_register_object
!> Dump compile_command_table_t to toml table
subroutine cct_dump_toml(self, table, error)
!> Instance of the serializable object
class(compile_command_table_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: stat, ii
type(toml_array), pointer :: array
! Create array
call add_array(table, 'compile_commands', array, stat=stat)
if (stat/=toml_stat%success .or. .not.associated(array)) then
call fatal_error(error,"compile_command_table_t cannot create entry")
return
end if
! Dump to it
call cct_dump_array(self, array, error)
end subroutine cct_dump_toml
!> Read compile_command_table_t from toml table (no checks made at this stage)
subroutine cct_load_toml(self, table, error)
!> Instance of the serializable object
class(compile_command_table_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: stat, i, n
type(toml_array), pointer :: array
type(toml_table), pointer :: elem
call self%destroy()
call get_value(table, key='compile_commands', ptr=array, requested=.true.,stat=stat)
if (stat/=toml_stat%success .or. .not.associated(array)) then
call fatal_error(error, "TOML table has no 'compile_commands' key")
return
else
n = len(array)
if (n<=0) return
allocate(self%command(n))
do i = 1, n
call get_value(array, pos=i, ptr=elem, stat=stat)
if (stat /= toml_stat%success .or. .not.associated(elem)) then
call fatal_error(error, "Entry in 'compile_commands' field cannot be read")
return
end if
call self%command(i)%load(elem, error)
if (allocated(error)) return
end do
end if
end subroutine cct_load_toml
!> Check that two compile_command_table_t objects are equal
logical function cct_is_same(this,that)
class(compile_command_table_t), intent(in) :: this
class(serializable_t), intent(in) :: that
integer :: i
cct_is_same = .false.
select type (other=>that)
type is (compile_command_table_t)
if (allocated(this%command).neqv.allocated(other%command)) return
if (allocated(this%command)) then
if (.not.(size (this%command) ==size (other%command))) return
if (.not.(ubound(this%command,1)==ubound(other%command,1))) return
if (.not.(lbound(this%command,1)==lbound(other%command,1))) return
do i=lbound(this%command,1),ubound(this%command,1)
if (.not.this%command(i)==other%command(i)) return
end do
end if
class default
! Not the same type
return
end select
!> All checks passed!
cct_is_same = .true.
end function cct_is_same
!> Add one compile command to array with a loop (gcc-15 bug on array initializer)
pure subroutine add_compile_command_one(list,new)
type(compile_command_t), allocatable, intent(inout) :: list(:)
type(compile_command_t), intent(in) :: new
integer :: i,n
type(compile_command_t), allocatable :: tmp(:)
if (allocated(list)) then
n = size(list)
else
n = 0
end if
allocate(tmp(n+1))
do i=1,n
tmp(i) = list(i)
end do
tmp(n+1) = new
call move_alloc(from=tmp,to=list)
end subroutine add_compile_command_one
!> Add multiple compile commands to array with a loop (gcc-15 bug on array initializer)
pure subroutine add_compile_command_many(list,new)
type(compile_command_t), allocatable, intent(inout) :: list(:)
type(compile_command_t), intent(in) :: new(:)
integer :: i,n,add
type(compile_command_t), allocatable :: tmp(:)
if (allocated(list)) then
n = size(list)
else
n = 0
end if
add = size(new)
if (add == 0) return
allocate(tmp(n+add))
do i=1,n
tmp(i) = list(i)
end do
do i=1,add
tmp(n+i) = new(i)
end do
call move_alloc(from=tmp,to=list)
end subroutine add_compile_command_many
end module fpm_compile_commands
fortran-lang-fpm-90bb83a/src/filesystem_utilities.c 0000664 0001750 0001750 00000001202 15145116760 022675 0 ustar alastair alastair #include
#include
#if defined(__APPLE__) && !defined(__aarch64__) && !defined(__ppc__) && !defined(__i386__)
DIR * opendir$INODE64( const char * dirName );
struct dirent * readdir$INODE64( DIR * dir );
#define opendir opendir$INODE64
#define readdir readdir$INODE64
#endif
int c_is_dir(const char *path)
{
struct stat m;
int r = stat(path, &m);
return r == 0 && S_ISDIR(m.st_mode);
}
const char *get_d_name(struct dirent *d)
{
return (const char *) d->d_name;
}
DIR *c_opendir(const char *dirname)
{
return opendir(dirname);
}
struct dirent *c_readdir(DIR *dirp)
{
return readdir(dirp);
}
fortran-lang-fpm-90bb83a/src/fpm_filesystem.F90 0000664 0001750 0001750 00000110657 15145116760 021577 0 ustar alastair alastair !> 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,intrinsic :: iso_c_binding, only: c_new_line
use fpm_environment, only: get_os_type, &
OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, &
OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD
use fpm_environment, only: separator, get_env, os_is_unix
use fpm_strings, only: f_string, replace, string_t, split, split_lines_first_last, dilate, add_strings, &
str_begins_with_str
use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer
use fpm_error, only : fpm_stop, error_t, fatal_error
implicit none
private
public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, list_files, get_local_prefix, &
mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, fileopen, fileclose, &
filewrite, warnwrite, parent_dir, is_hidden_file, read_lines, read_lines_expanded, which, run, &
os_delete_dir, is_absolute_path, get_home, execute_and_read_output, get_dos_path
#ifndef FPM_BOOTSTRAP
interface
function c_opendir(dir) result(r) bind(c, name="c_opendir")
import c_char, c_ptr
character(kind=c_char), intent(in) :: dir(*)
type(c_ptr) :: r
end function c_opendir
function c_readdir(dir) result(r) bind(c, name="c_readdir")
import c_ptr
type(c_ptr), intent(in), value :: dir
type(c_ptr) :: r
end function c_readdir
function c_closedir(dir) result(r) bind(c, name="closedir")
import c_ptr, c_int
type(c_ptr), intent(in), value :: dir
integer(kind=c_int) :: r
end function c_closedir
function c_get_d_name(dir) result(r) bind(c, name="get_d_name")
import c_ptr
type(c_ptr), intent(in), value :: dir
type(c_ptr) :: r
end function c_get_d_name
function c_is_dir(path) result(r) bind(c, name="c_is_dir")
import c_char, c_int
character(kind=c_char), intent(in) :: path(*)
integer(kind=c_int) :: r
end function c_is_dir
end interface
#endif
contains
!> 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
call split(path,file_parts,delimiters='\/')
if(size(file_parts)>0)then
base = trim(file_parts(size(file_parts)))
else
base = ''
endif
if(.not.with_suffix)then
call split(base,file_parts,delimiters='.')
if(size(file_parts)>=2)then
base = trim(file_parts(size(file_parts)-1))
endif
endif
end function basename
!> 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 :: istart, iend, 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
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
!> Extract dirname from path
function parent_dir(path) result (dir)
character(*), intent(in) :: path
character(:), allocatable :: dir
dir = path(1:scan(path,'/\',back=.true.)-1)
end function parent_dir
!> 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, OS_OPENBSD)
call run( "test -d " // dir , &
& exitstat=stat,echo=.false.,verbose=.false.)
case (OS_WINDOWS)
call run('cmd /c "if not exist ' // windows_path(dir) // '\ exit /B 1"', &
& exitstat=stat,echo=.false.,verbose=.false.)
end select
is_dir = (stat == 0)
end function is_dir
!> test if a file is hidden
logical function is_hidden_file(file_basename) result(r)
character(*), intent(in) :: file_basename
if (len(file_basename) <= 2) then
r = .false.
else
r = str_begins_with_str(file_basename, '.')
end if
end function is_hidden_file
!> 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
logical, save :: has_cache = .false.
character(len=1), save :: cache = '/'
!$omp threadprivate(has_cache, cache)
if (has_cache) then
filesep = cache
else
select case (get_os_type())
case default
filesep = '/'
case (OS_WINDOWS)
filesep = '\'
end select
cache = filesep
has_cache = .true.
end if
if (a1 == "") then
path = a2
else
path = a1 // filesep // a2
end if
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
rewind(s)
nrows = 0
do
read(s, *, iostat=ios)
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 expanding tabs
function read_lines_expanded(filename) result(lines)
character(len=*), intent(in) :: filename
type(string_t), allocatable :: lines(:)
integer :: i
character(len=:), allocatable :: content
integer, allocatable :: first(:), last(:)
content = read_text_file(filename)
if (len(content) == 0) then
allocate (lines(0))
return
end if
call split_lines_first_last(content, first, last)
! allocate lines from file content string
allocate (lines(size(first)))
do i = 1, size(first)
allocate(lines(i)%s, source=dilate(content(first(i):last(i))))
end do
end function read_lines_expanded
!> read lines into an array of TYPE(STRING_T) variables
function read_lines(filename) result(lines)
character(len=*), intent(in) :: filename
type(string_t), allocatable :: lines(:)
integer :: i
character(len=:), allocatable :: content
integer, allocatable :: first(:), last(:)
content = read_text_file(filename)
if (len(content) == 0) then
allocate (lines(0))
return
end if
call split_lines_first_last(content, first, last)
! allocate lines from file content string
allocate (lines(size(first)))
do i = 1, size(first)
allocate(lines(i)%s, source=content(first(i):last(i)))
end do
end function read_lines
!> read text file into a string
function read_text_file(filename) result(string)
character(len=*), intent(in) :: filename
character(len=:), allocatable :: string
integer :: fh, length
open (newunit=fh, file=filename, status='old', action='read', &
access='stream', form='unformatted')
inquire (fh, size=length)
allocate (character(len=length) :: string)
if (length == 0) return
read (fh) string
close (fh)
end function read_text_file
!> Create a directory. Create subdirectories as needed
subroutine mkdir(dir, echo)
character(len=*), intent(in) :: dir
logical, intent(in), optional :: echo
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, OS_OPENBSD)
call run('mkdir -p ' // dir, exitstat=stat,echo=echo,verbose=.false.)
case (OS_WINDOWS)
call run("mkdir " // windows_path(dir), &
& echo=echo, exitstat=stat,verbose=.false.)
end select
if (stat /= 0) then
call fpm_stop(1, '*mkdir*:directory creation failed')
end if
end subroutine mkdir
#ifndef FPM_BOOTSTRAP
!> Get file & directory names in directory `dir` using iso_c_binding.
!!
!! - 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 :: i
type(string_t), allocatable :: dir_files(:)
type(string_t), allocatable :: sub_dir_files(:)
type(c_ptr) :: dir_handle
type(c_ptr) :: dir_entry_c
character(len=:,kind=c_char), allocatable :: fortran_name
character(len=:), allocatable :: string_fortran
integer, parameter :: N_MAX = 256
type(string_t) :: files_tmp(N_MAX)
integer(kind=c_int) :: r
if (c_is_dir(dir(1:len_trim(dir))//c_null_char) == 0) then
allocate (files(0))
return
end if
dir_handle = c_opendir(dir(1:len_trim(dir))//c_null_char)
if (.not. c_associated(dir_handle)) then
print *, 'c_opendir() failed'
error stop
end if
i = 0
allocate(files(0))
do
dir_entry_c = c_readdir(dir_handle)
if (.not. c_associated(dir_entry_c)) then
exit
else
string_fortran = f_string(c_get_d_name(dir_entry_c))
if ((string_fortran == '.' .or. string_fortran == '..')) then
cycle
end if
i = i + 1
if (i > N_MAX) then
call add_strings(files, files_tmp)
i = 1
end if
files_tmp(i)%s = join_path(dir, string_fortran)
end if
end do
r = c_closedir(dir_handle)
if (r /= 0) then
print *, 'c_closedir() failed'
error stop
end if
if (i > 0) then
call add_strings(files, files_tmp(1:i))
end if
if (present(recurse)) then
if (recurse) then
allocate(sub_dir_files(0))
do i=1,size(files)
if (c_is_dir(files(i)%s//c_null_char) /= 0) then
call list_files(files(i)%s, dir_files, recurse=.true.)
call add_strings(sub_dir_files, dir_files)
end if
end do
call add_strings(files, sub_dir_files)
end if
end if
end subroutine list_files
#else
!> 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, OS_OPENBSD)
call run('ls -A ' // dir , &
& redirect=temp_file, exitstat=stat,echo=.false.,verbose=.false.)
case (OS_WINDOWS)
call run('dir /b ' // windows_path(dir), &
& redirect=temp_file, exitstat=stat,echo=.false.,verbose=.false.)
end select
if (stat /= 0) then
call fpm_stop(2,'*list_files*:directory listing failed')
end if
files = read_lines(temp_file)
call delete_file(temp_file)
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.)
call add_strings(sub_dir_files, dir_files)
end if
end do
call add_strings(files, sub_dir_files)
end if
end if
end subroutine list_files
#endif
!> test if pathname already exists
logical function exists(filename) result(r)
character(len=*), intent(in) :: filename
inquire(file=filename, exist=r)
!> Directories are not files for the Intel compilers. If so, also use this compiler-dependent extension
#if defined(__INTEL_COMPILER)
if (.not.r) inquire(directory=filename, exist=r)
#endif
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
integer, parameter :: MAX_FILENAME_LENGTH = 32768
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,[MAX_FILENAME_LENGTH])
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
!>AUTHOR: fpm(1) contributors
!!LICENSE: MIT
!>
!!##NAME
!! getline(3f) - [M_io:READ] read a line of arbintrary length from specified
!! LUN into allocatable string (up to system line length limit)
!! (LICENSE:PD)
!!
!!##SYNTAX
!! subroutine getline(unit,line,iostat,iomsg)
!!
!! integer,intent(in) :: unit
!! character(len=:),allocatable,intent(out) :: line
!! integer,intent(out) :: iostat
!! character(len=:), allocatable, optional :: iomsg
!!
!!##DESCRIPTION
!! Read a line of any length up to programming environment maximum
!! line length. Requires Fortran 2003+.
!!
!! It is primarily expected to be used when reading input which will
!! then be parsed or echoed.
!!
!! The input file must have a PAD attribute of YES for the function
!! to work properly, which is typically true.
!!
!! The simple use of a loop that repeatedly re-allocates a character
!! variable in addition to reading the input file one buffer at a
!! time could (depending on the programming environment used) be
!! inefficient, as it could reallocate and allocate memory used for
!! the output string with each buffer read.
!!
!!##OPTIONS
!! LINE The line read when IOSTAT returns as zero.
!! LUN LUN (Fortran logical I/O unit) number of file open and ready
!! to read.
!! IOSTAT status returned by READ(IOSTAT=IOS). If not zero, an error
!! occurred or an end-of-file or end-of-record was encountered.
!! IOMSG error message returned by system when IOSTAT is not zero.
!!
!!##EXAMPLE
!!
!! Sample program:
!!
!! program demo_getline
!! use,intrinsic :: iso_fortran_env, only : stdin=>input_unit
!! use,intrinsic :: iso_fortran_env, only : iostat_end
!! use FPM_filesystem, only : getline
!! implicit none
!! integer :: iostat
!! character(len=:),allocatable :: line, iomsg
!! open(unit=stdin,pad='yes')
!! INFINITE: do
!! call getline(stdin,line,iostat,iomsg)
!! if(iostat /= 0) exit INFINITE
!! write(*,'(a)')'['//line//']'
!! enddo INFINITE
!! if(iostat /= iostat_end)then
!! write(*,*)'error reading input:',iomsg
!! endif
!! end program demo_getline
!!
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
integer, parameter :: BUFFER_SIZE = 1024
character(len=BUFFER_SIZE) :: buffer
character(len=256) :: 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/=' ')then
open(file=filename, &
& newunit=lun, &
& form='formatted', & ! FORM = FORMATTED | UNFORMATTED
& access='sequential', & ! ACCESS = SEQUENTIAL| DIRECT | STREAM
& action='write', & ! ACTION = READ|WRITE| READWRITE
& position='rewind', & ! POSITION= ASIS | REWIND | APPEND
& status='new', & ! STATUS = NEW| REPLACE| OLD| SCRATCH| UNKNOWN
& iostat=ios, &
& iomsg=message)
else
lun=stdout
ios=0
endif
if(ios/=0)then
lun=-1
if(present(ier))then
ier=ios
else
call fpm_stop(3,'*fileopen*:'//filename//':'//trim(message))
endif
endif
end subroutine fileopen
!> simple close of a LUN. On error show message and stop (by default)
subroutine fileclose(lun,ier)
integer,intent(in) :: lun
integer,intent(out),optional :: ier
character(len=256) :: message
integer :: ios
if(lun/=-1)then
close(unit=lun,iostat=ios,iomsg=message)
if(ios/=0)then
if(present(ier))then
ier=ios
else
call fpm_stop(4,'*fileclose*:'//trim(message))
endif
endif
endif
end subroutine fileclose
!> procedure to write filedata to file filename
subroutine filewrite(filename,filedata)
character(len=*),intent(in) :: filename
character(len=*),intent(in) :: filedata(:)
integer :: lun, i, ios
character(len=256) :: message
call fileopen(filename,lun)
if(lun/=-1)then ! program currently stops on error on open, but might
! want it to continue so -1 (unallowed LUN) indicates error
! write file
do i=1,size(filedata)
write(lun,'(a)',iostat=ios,iomsg=message)trim(filedata(i))
if(ios/=0)then
call fpm_stop(5,'*filewrite*:'//filename//':'//trim(message))
endif
enddo
endif
! close file
call fileclose(lun)
end subroutine filewrite
!>AUTHOR: John S. Urban
!!LICENSE: Public Domain
!>
!!##Name
!! which(3f) - [M_io:ENVIRONMENT] given a command name find the pathname by searching
!! the directories in the environment variable $PATH
!! (LICENSE:PD)
!!
!!##Syntax
!! function which(command) result(pathname)
!!
!! character(len=*),intent(in) :: command
!! character(len=:),allocatable :: pathname
!!
!!##Description
!! Given a command name find the first file with that name in the directories
!! specified by the environment variable $PATH.
!!
!!##options
!! COMMAND the command to search for
!!
!!##Returns
!! PATHNAME the first pathname found in the current user path. Returns blank
!! if the command is not found.
!!
!!##Example
!!
!! Sample program:
!!
!! Checking the error message and counting lines:
!!
!! program demo_which
!! use M_io, only : which
!! implicit none
!! write(*,*)'ls is ',which('ls')
!! write(*,*)'dir is ',which('dir')
!! write(*,*)'install is ',which('install')
!! end program demo_which
!!
function which(command) result(pathname)
character(len=*),intent(in) :: command
character(len=:),allocatable :: pathname, checkon, paths(:), exts(:)
integer :: i, j
pathname=''
call split(get_env('PATH'),paths,delimiters=merge(';',':',separator()=='\'))
SEARCH: do i=1,size(paths)
checkon=trim(join_path(trim(paths(i)),command))
select case(separator())
case('/')
if(exists(checkon))then
pathname=checkon
exit SEARCH
endif
case('\')
if(exists(checkon))then
pathname=checkon
exit SEARCH
endif
if(exists(checkon//'.bat'))then
pathname=checkon//'.bat'
exit SEARCH
endif
if(exists(checkon//'.exe'))then
pathname=checkon//'.exe'
exit SEARCH
endif
call split(get_env('PATHEXT'),exts,delimiters=';')
do j=1,size(exts)
if(exists(checkon//'.'//trim(exts(j))))then
pathname=checkon//'.'//trim(exts(j))
exit SEARCH
endif
enddo
end select
enddo SEARCH
end function which
!>AUTHOR: fpm(1) contributors
!!LICENSE: MIT
!>
!!##Name
!! run(3f) - execute specified system command and selectively echo
!! command and output to a file and/or stdout.
!! (LICENSE:MIT)
!!
!!##Syntax
!! subroutine run(cmd,echo,exitstat,verbose,redirect)
!!
!! character(len=*), intent(in) :: cmd
!! logical,intent(in),optional :: echo
!! integer, intent(out),optional :: exitstat
!! logical, intent(in), optional :: verbose
!! character(*), intent(in), optional :: redirect
!!
!!##Description
!! Execute the specified system command. Optionally
!!
!! + echo the command before execution
!! + return the system exit status of the command.
!! + redirect the output of the command to a file.
!! + echo command output to stdout
!!
!! Calling run(3f) is preferred to direct calls to
!! execute_command_line(3f) in the fpm(1) source to provide a standard
!! interface where output modes can be specified.
!!
!!##Options
!! CMD System command to execute
!! ECHO Whether to echo the command being executed or not
!! Defaults to .TRUE. .
!! VERBOSE Whether to redirect the command output to a null device or not
!! Defaults to .TRUE. .
!! REDIRECT Filename to redirect stdout and stderr of the command into.
!! If generated it is closed before run(3f) returns.
!! EXITSTAT The system exit status of the command when supported by
!! the system. If not present and a non-zero status is
!! generated program termination occurs.
!!
!!##Example
!!
!! Sample program:
!!
!! Checking the error message and counting lines:
!!
!! program demo_run
!! use fpm_filesystem, only : run
!! implicit none
!! logical,parameter :: T=.true., F=.false.
!! integer :: exitstat
!! character(len=:),allocatable :: cmd
!! cmd='ls -ltrasd *.md'
!! call run(cmd)
!! call run(cmd,exitstat=exitstat)
!! call run(cmd,echo=F)
!! call run(cmd,verbose=F)
!! end program demo_run
!!
subroutine run(cmd,echo,exitstat,verbose,redirect)
character(len=*), intent(in) :: cmd
logical,intent(in),optional :: echo
integer, intent(out),optional :: exitstat
logical, intent(in), optional :: verbose
character(*), intent(in), optional :: redirect
integer :: cmdstat
character(len=256) :: cmdmsg, iomsg
logical :: echo_local, verbose_local
character(:), allocatable :: redirect_str
character(:), allocatable :: line
integer :: stat, fh, iostat
if(present(echo))then
echo_local=echo
else
echo_local=.true.
end if
if(present(verbose))then
verbose_local=verbose
else
verbose_local=.true.
end if
if (present(redirect)) then
if(redirect /= '')then
redirect_str = ">"//redirect//" 2>&1"
else
redirect_str = ""
endif
else
if(verbose_local)then
! No redirection but verbose output
redirect_str = ""
else
! No redirection and non-verbose output
if (os_is_unix()) then
redirect_str = " >/dev/null 2>&1"
else
redirect_str = " >NUL 2>&1"
end if
end if
end if
if(echo_local) print *, '+ ', cmd !//redirect_str
call execute_command_line(cmd//redirect_str, exitstat=stat,cmdstat=cmdstat,cmdmsg=cmdmsg)
if(cmdstat /= 0)then
write(*,'(a)')':failed command '//cmd//redirect_str
call fpm_stop(1,'*run*:'//trim(cmdmsg))
endif
if (verbose_local.and.present(redirect)) then
open(newunit=fh,file=redirect,status='old',iostat=iostat,iomsg=iomsg)
if(iostat == 0)then
do
call getline(fh, line, iostat)
if (iostat /= 0) exit
write(*,'(A)') trim(line)
end do
else
write(*,'(A)') trim(iomsg)
endif
close(fh)
end if
if (present(exitstat)) then
exitstat = stat
elseif (stat /= 0) then
call fpm_stop(stat,'*run*: Command '//cmd//redirect_str//' returned a non-zero status code')
end if
end subroutine run
!> Delete directory using system OS remove directory commands
subroutine os_delete_dir(is_unix, dir, echo)
logical, intent(in) :: is_unix
character(len=*), intent(in) :: dir
logical, intent(in), optional :: echo
if (is_unix) then
call run('rm -rf ' // dir, echo=echo,verbose=.false.)
else
call run('rmdir /s/q ' // dir, echo=echo,verbose=.false.)
end if
end subroutine os_delete_dir
!> Determine the path prefix to the local folder. Used for installation, registry etc.
function get_local_prefix(os) result(prefix)
!> Installation prefix
character(len=:), allocatable :: prefix
!> Platform identifier
integer, intent(in), optional :: os
!> Default installation prefix on Unix platforms
character(len=*), parameter :: default_prefix_unix = "/usr/local"
!> Default installation prefix on Windows platforms
character(len=*), parameter :: default_prefix_win = "C:\"
character(len=:), allocatable :: home
if (os_is_unix(os)) then
home=get_env('HOME','')
if (home /= '' ) then
prefix = join_path(home, ".local")
else
prefix = default_prefix_unix
end if
else
home=get_env('APPDATA','')
if (home /= '' ) then
prefix = join_path(home, "local")
else
prefix = default_prefix_win
end if
end if
end function get_local_prefix
!> Returns .true. if provided path is absolute.
!>
!> `~` not treated as absolute.
logical function is_absolute_path(path, is_unix)
character(len=*), intent(in) :: path
logical, optional, intent(in):: is_unix
character(len=*), parameter :: letters = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
logical :: is_unix_os
if (present(is_unix)) then
is_unix_os = is_unix
else
is_unix_os = os_is_unix()
end if
if (is_unix_os) then
is_absolute_path = path(1:1) == '/'
else
if (len(path) < 2) then
is_absolute_path = .false.
return
end if
is_absolute_path = index(letters, path(1:1)) /= 0 .and. path(2:2) == ':'
end if
end function is_absolute_path
!> Get the HOME directory on Unix and the %USERPROFILE% directory on Windows.
subroutine get_home(home, error)
character(len=:), allocatable, intent(out) :: home
type(error_t), allocatable, intent(out) :: error
if (os_is_unix()) then
home=get_env('HOME','')
if ( home == '' ) then
call fatal_error(error, "Couldn't retrieve 'HOME' variable")
return
end if
else
home=get_env('USERPROFILE','')
if ( home == '' ) then
call fatal_error(error, "Couldn't retrieve '%USERPROFILE%' variable")
return
end if
end if
end subroutine get_home
!> Execute command line and return output as a string.
subroutine execute_and_read_output(cmd, output, error, verbose)
!> Command to execute.
character(len=*), intent(in) :: cmd
!> Command line output.
character(len=:), allocatable, intent(out) :: output
!> Error to handle.
type(error_t), allocatable, intent(out) :: error
!> Print additional information if true.
logical, intent(in), optional :: verbose
integer :: exitstat, unit, stat
character(len=:), allocatable :: cmdmsg, tmp_file, output_line
logical :: is_verbose
if (present(verbose)) then
is_verbose = verbose
else
is_verbose = .false.
end if
tmp_file = get_temp_filename()
call run(cmd//' > '//tmp_file, exitstat=exitstat, echo=is_verbose)
if (exitstat /= 0) call fatal_error(error, '*run*: '//"Command failed: '"//cmd//"'. Message: '"//trim(cmdmsg)//"'.")
open(newunit=unit, file=tmp_file, action='read', status='old')
output = ''
do
call getline(unit, output_line, stat)
if (stat /= 0) exit
output = output//output_line//' '
end do
if (is_verbose) print *, output
close(unit, status='delete')
end
!> Ensure a windows path is converted to an 8.3 DOS path if it contains spaces
function get_dos_path(path,error)
character(len=*), intent(in) :: path
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: get_dos_path
character(:), allocatable :: redirect,screen_output,line
integer :: stat,cmdstat,iunit,last
! Non-Windows OS
if (get_os_type()/=OS_WINDOWS) then
get_dos_path = path
return
end if
! Trim path first
get_dos_path = trim(path)
!> No need to convert if there are no spaces
has_spaces: if (scan(get_dos_path,' ')>0) then
redirect = get_temp_filename()
call execute_command_line('cmd /c for %A in ("'//path//'") do @echo %~sA >'//redirect//' 2>&1',&
exitstat=stat,cmdstat=cmdstat)
!> Read screen output
command_OK: if (cmdstat==0 .and. stat==0) then
allocate(character(len=0) :: screen_output)
open(newunit=iunit,file=redirect,status='old',iostat=stat)
if (stat == 0)then
do
call getline(iunit, line, stat)
if (stat /= 0) exit
screen_output = screen_output//line//' '
end do
! Close and delete file
close(iunit,status='delete')
else
call fatal_error(error,'cannot read temporary file from successful DOS path evaluation')
return
endif
else command_OK
call fatal_error(error,'unsuccessful Windows->DOS path command')
return
end if command_OK
get_dos_path = trim(adjustl(screen_output))
endif has_spaces
!> Ensure there are no trailing slashes
last = len_trim(get_dos_path)
if (last>1 .and. get_dos_path(last:last)=='/' .or. get_dos_path(last:last)=='\') get_dos_path = get_dos_path(1:last-1)
end function get_dos_path
end module fpm_filesystem
fortran-lang-fpm-90bb83a/src/fpm_model.f90 0000664 0001750 0001750 00000124655 15145116760 020556 0 ustar alastair alastair !># 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
!>
!> The logical order of precedence for assigning `unit_type` is as follows:
!>
!>```
!> if source-file contains program then
!> unit_type = FPM_UNIT_PROGRAM
!> else if source-file contains non-module subroutine/function then
!> unit_type = FPM_UNIT_SUBPROGRAM
!> else if source-file contains submodule then
!> unit_type = FPM_UNIT_SUBMODULE
!> else if source-file contains module then
!> unit_type = FPM_UNIT_MODULE
!> end if
!>```
!>
!> @note A source file is only designated `FPM_UNIT_MODULE` if it **only** contains modules - no non-module subprograms.
!> (This allows tree-shaking/pruning of build targets based on unused module dependencies.)
!>
!> __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_compiler, only: compiler_t, archiver_t, debug
use fpm_dependency, only: dependency_tree_t
use fpm_versioning, only: version_t, new_version
use fpm_strings, only: string_t, str, len_trim, upper, operator(==)
use tomlf, only: toml_table, toml_stat
use fpm_toml, only: serializable_t, set_value, set_list, get_value, &
& get_list, add_table, toml_key, add_array, set_string
use fpm_error, only: error_t, fatal_error
use fpm_environment, only: OS_WINDOWS,OS_MACOS, get_os_type, OS_UNKNOWN, OS_LINUX, OS_CYGWIN, &
OS_SOLARIS, OS_FREEBSD, OS_OPENBSD, OS_ALL, validate_os_name, OS_NAME, &
match_os_type
use fpm_manifest_preprocess, only: preprocess_config_t
use fpm_manifest_fortran, only: fortran_config_t
use fpm_manifest_platform, only: platform_config_t
implicit none
private
public :: fpm_model_t, srcfile_t, show_model, fortran_config_t, package_t
public :: FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, &
FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, &
FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, &
FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST, &
FPM_UNIT_CPPSOURCE, FPM_SCOPE_NAME, FPM_UNIT_NAME
!> Source type unknown
integer, parameter :: FPM_UNIT_UNKNOWN = -1
!> Source contains a fortran program
integer, parameter :: FPM_UNIT_PROGRAM = 1
!> Source **only** contains one or more fortran modules
integer, parameter :: FPM_UNIT_MODULE = 2
!> Source contains one or more fortran submodules
integer, parameter :: FPM_UNIT_SUBMODULE = 3
!> Source contains one or more fortran subprogram not within modules
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
!> Souce type is c++ source file.
integer, parameter :: FPM_UNIT_CPPSOURCE = 7
!> 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, extends(serializable_t) :: 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
!> Parent modules (submodules only)
type(string_t), allocatable :: parent_modules(:)
!> 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
contains
!> Serialization interface
procedure :: serializable_is_same => srcfile_is_same
procedure :: dump_to_toml => srcfile_dump_to_toml
procedure :: load_from_toml => srcfile_load_from_toml
end type srcfile_t
!> Type for describing a single package
type, extends(serializable_t) :: package_t
!> Name of package
character(:), allocatable :: name
!> Array of sources
type(srcfile_t), allocatable :: sources(:)
!> List of macros.
type(preprocess_config_t) :: preprocess
!> Package version number.
type(version_t), allocatable :: version
!> Module naming conventions
logical :: enforce_module_names = .false.
!> Prefix for all module names
type(string_t) :: module_prefix
!> Language features
type(fortran_config_t) :: features
contains
!> Check if a package will create a library
procedure :: has_library => package_has_library
!> Serialization interface
procedure :: serializable_is_same => package_is_same
procedure :: dump_to_toml => package_dump_to_toml
procedure :: load_from_toml => package_load_from_toml
end type package_t
!> Type describing everything required to build
!> the root package and its dependencies.
type, extends(serializable_t) :: fpm_model_t
!> Name of root package
character(:), allocatable :: package_name
!> Array of packages (including the root package)
type(package_t), allocatable :: packages(:)
!> Compiler object
type(compiler_t) :: compiler
!> Archiver object
type(archiver_t) :: archiver
!> Command line flags passed to fortran for compilation
character(:), allocatable :: fortran_compile_flags
!> Command line flags passed to C for compilation
character(:), allocatable :: c_compile_flags
!> Command line flags passed to C++ for compilation
character(:), allocatable :: cxx_compile_flags
!> Command line flags passed to the linker
character(:), allocatable :: link_flags
!> Base directory for build
character(:), allocatable :: build_prefix
!> Build directory
character(:), allocatable :: build_dir
!> Include directories
type(string_t), allocatable :: include_dirs(:)
!> Native libraries to link against
type(string_t), allocatable :: link_libraries(:)
!> External modules used
type(string_t), allocatable :: external_modules(:)
!> Project dependencies
type(dependency_tree_t) :: deps
!> Whether tests should be added to the build list
logical :: include_tests = .true.
!> Whether module names should be prefixed with the package name
logical :: enforce_module_names = .false.
!> Prefix for all module names
type(string_t) :: module_prefix
!> Target operating system
integer :: target_os = OS_ALL
contains
!> Get target link flags
procedure :: get_package_libraries_link
!> Get target platform configuration
procedure :: target_platform
!> Serialization interface
procedure :: serializable_is_same => model_is_same
procedure :: dump_to_toml => model_dump_to_toml
procedure :: load_from_toml => model_load_from_toml
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 // "]"
! Print module naming convention
s = s // ', enforce_module_names="' // merge('T','F',p%enforce_module_names) // '"'
! Print custom prefix
if (p%enforce_module_names .and. len_trim(p%module_prefix)>0) &
s = s // ', custom_prefix="' // p%module_prefix%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="' // FPM_SCOPE_NAME(source%unit_scope) // '"'
! 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 // "]"
s = s // ", parent_modules=["
do i = 1, size(source%parent_modules)
s = s // '"' // source%parent_modules(i)%s // '"'
if (i < size(source%parent_modules)) s = s // ", "
end do
s = s // "]"
! integer :: unit_type = FPM_UNIT_UNKNOWN
s = s // ', unit_type="' // FPM_UNIT_NAME(source%unit_type) // '"'
! 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
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 // "]"
s = s // ', compiler=(' // debug(model%compiler) // ')'
s = s // ', archiver=(' // debug(model%archiver) // ')'
! character(:), allocatable :: fortran_compile_flags
s = s // ', fortran_compile_flags="' // model%fortran_compile_flags // '"'
s = s // ', c_compile_flags="' // model%c_compile_flags // '"'
s = s // ', cxx_compile_flags="' // model%cxx_compile_flags // '"'
s = s // ', link_flags="' // model%link_flags // '"'
s = s // ', build_prefix="' // model%build_prefix // '"'
s = s // ', build_dir="' // model%build_dir // '"'
! 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(string_t), allocatable :: external_modules(:)
s = s // ", external_modules=["
do i = 1, size(model%external_modules)
s = s // '"' // model%external_modules(i)%s // '"'
if (i < size(model%external_modules)) s = s // ", "
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(...)"
! Print module naming convention
s = s // ', enforce_module_names="' // merge('T','F',model%enforce_module_names) // '"'
! Print custom prefix
if (model%enforce_module_names .and. len_trim(model%module_prefix)>0) &
s = s // ', custom_prefix="' // model%module_prefix%s // '"'
!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
!> Return the character name of a scope flag
function FPM_SCOPE_NAME(flag) result(name)
integer, intent(in) :: flag
character(len=:), allocatable :: name
select case (flag)
case (FPM_SCOPE_UNKNOWN); name = "FPM_SCOPE_UNKNOWN"
case (FPM_SCOPE_LIB); name = "FPM_SCOPE_LIB"
case (FPM_SCOPE_DEP); name = "FPM_SCOPE_DEP"
case (FPM_SCOPE_APP); name = "FPM_SCOPE_APP"
case (FPM_SCOPE_TEST); name = "FPM_SCOPE_TEST"
case (FPM_SCOPE_EXAMPLE); name = "FPM_SCOPE_EXAMPLE"
case default; name = "INVALID"
end select
end function FPM_SCOPE_NAME
!> Parse git FPM_SCOPE identifier from a string
integer function parse_scope(name) result(scope)
character(len=*), intent(in) :: name
character(len=len(name)) :: uppercase
!> Make it Case insensitive
uppercase = upper(name)
select case (trim(uppercase))
case ("FPM_SCOPE_UNKNOWN"); scope = FPM_SCOPE_UNKNOWN
case ("FPM_SCOPE_LIB"); scope = FPM_SCOPE_LIB
case ("FPM_SCOPE_DEP"); scope = FPM_SCOPE_DEP
case ("FPM_SCOPE_APP"); scope = FPM_SCOPE_APP
case ("FPM_SCOPE_TEST"); scope = FPM_SCOPE_TEST
case ("FPM_SCOPE_EXAMPLE"); scope = FPM_SCOPE_EXAMPLE
case default; scope = -9999
end select
end function parse_scope
!> Return the character name of a unit flag
function FPM_UNIT_NAME(flag) result(name)
integer, intent(in) :: flag
character(len=:), allocatable :: name
select case (flag)
case (FPM_UNIT_UNKNOWN); name = "FPM_UNIT_UNKNOWN"
case (FPM_UNIT_PROGRAM); name = "FPM_UNIT_PROGRAM"
case (FPM_UNIT_MODULE); name = "FPM_UNIT_MODULE"
case (FPM_UNIT_SUBMODULE); name = "FPM_UNIT_SUBMODULE"
case (FPM_UNIT_SUBPROGRAM); name = "FPM_UNIT_SUBPROGRAM"
case (FPM_UNIT_CSOURCE); name = "FPM_UNIT_CSOURCE"
case (FPM_UNIT_CPPSOURCE); name = "FPM_UNIT_CPPSOURCE"
case (FPM_UNIT_CHEADER); name = "FPM_UNIT_CHEADER"
case default; name = "INVALID"
end select
end function FPM_UNIT_NAME
!> Parse git FPM_UNIT identifier from a string
integer function parse_unit(name) result(unit)
character(len=*), intent(in) :: name
character(len=len(name)) :: uppercase
!> Make it Case insensitive
uppercase = upper(name)
select case (trim(uppercase))
case ("FPM_UNIT_UNKNOWN"); unit = FPM_UNIT_UNKNOWN
case ("FPM_UNIT_PROGRAM"); unit = FPM_UNIT_PROGRAM
case ("FPM_UNIT_MODULE"); unit = FPM_UNIT_MODULE
case ("FPM_UNIT_SUBMODULE"); unit = FPM_UNIT_SUBMODULE
case ("FPM_UNIT_SUBPROGRAM"); unit = FPM_UNIT_SUBPROGRAM
case ("FPM_UNIT_CSOURCE"); unit = FPM_UNIT_CSOURCE
case ("FPM_UNIT_CPPSOURCE"); unit = FPM_UNIT_CPPSOURCE
case ("FPM_UNIT_CHEADER"); unit = FPM_UNIT_CHEADER
case default; unit = -9999
end select
end function parse_unit
!> Check that two source files are equal
logical function srcfile_is_same(this,that)
class(srcfile_t), intent(in) :: this
class(serializable_t), intent(in) :: that
srcfile_is_same = .false.
select type (other=>that)
type is (srcfile_t)
if (allocated(this%file_name).neqv.allocated(other%file_name)) return
if (allocated(this%file_name)) then
if (.not.(this%file_name==other%file_name)) return
end if
if (allocated(this%exe_name).neqv.allocated(other%exe_name)) return
if (allocated(this%exe_name)) then
if (.not.(this%exe_name==other%exe_name)) return
end if
if (.not.(this%unit_scope==other%unit_scope)) return
if (allocated(this%modules_provided).neqv.allocated(other%modules_provided)) return
if (allocated(this%modules_provided)) then
if (.not.(this%modules_provided==other%modules_provided)) return
end if
if (.not.(this%unit_type==other%unit_type)) return
if (allocated(this%parent_modules).neqv.allocated(other%parent_modules)) return
if (allocated(this%parent_modules)) then
if (.not.(this%parent_modules==other%parent_modules)) return
end if
if (allocated(this%modules_used).neqv.allocated(other%modules_used)) return
if (allocated(this%modules_used)) then
if (.not.(this%modules_used==other%modules_used)) return
end if
if (allocated(this%include_dependencies).neqv.allocated(other%include_dependencies)) return
if (allocated(this%include_dependencies)) then
if (.not.(this%include_dependencies==other%include_dependencies)) return
end if
if (allocated(this%link_libraries).neqv.allocated(other%link_libraries)) return
if (allocated(this%link_libraries)) then
if (.not.(this%link_libraries==other%link_libraries)) return
end if
if (.not.(this%digest==other%digest)) return
class default
! Not the same type
return
end select
!> All checks passed!
srcfile_is_same = .true.
end function srcfile_is_same
!> Dump dependency to toml table
subroutine srcfile_dump_to_toml(self, table, error)
!> Instance of the serializable object
class(srcfile_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: ierr
call set_string(table, "file-name", self%file_name, error, 'srcfile_t')
if (allocated(error)) return
call set_string(table, "exe-name", self%exe_name, error, 'srcfile_t')
if (allocated(error)) return
call set_value(table, "digest", self%digest, error, 'srcfile_t')
if (allocated(error)) return
! unit_scope and unit_type are saved as strings so the output is independent
! of the internal representation
call set_string(table,"unit-scope",FPM_SCOPE_NAME(self%unit_scope), error, 'srcfile_t')
if (allocated(error)) return
call set_string(table,"unit-type",FPM_UNIT_NAME(self%unit_type), error, 'srcfile_t')
if (allocated(error)) return
call set_list(table, "modules-provided",self%modules_provided, error)
if (allocated(error)) return
call set_list(table, "parent-modules",self%parent_modules, error)
if (allocated(error)) return
call set_list(table, "modules-used",self%modules_used, error)
if (allocated(error)) return
call set_list(table, "include-dependencies",self%include_dependencies, error)
if (allocated(error)) return
call set_list(table, "link-libraries",self%link_libraries, error)
if (allocated(error)) return
end subroutine srcfile_dump_to_toml
!> Read dependency from toml table (no checks made at this stage)
subroutine srcfile_load_from_toml(self, table, error)
!> Instance of the serializable object
class(srcfile_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: flag
integer :: ierr
call get_value(table, "file-name", self%file_name)
call get_value(table, "exe-name", self%exe_name)
call get_value(table, "digest", self%digest, error, 'srcfile_t')
if (allocated(error)) return
! unit_scope and unit_type are saved as strings so the output is independent
! of the internal representation
call get_value(table, "unit-scope", flag)
if (allocated(flag)) self%unit_scope = parse_scope(flag)
call get_value(table, "unit-type", flag)
if (allocated(flag)) self%unit_type = parse_unit(flag)
call get_list(table,"modules-provided",self%modules_provided, error)
if (allocated(error)) return
call get_list(table,"parent-modules",self%parent_modules, error)
if (allocated(error)) return
call get_list(table,"modules-used",self%modules_used, error)
if (allocated(error)) return
call get_list(table,"include-dependencies",self%include_dependencies, error)
if (allocated(error)) return
call get_list(table,"link-libraries",self%link_libraries, error)
if (allocated(error)) return
end subroutine srcfile_load_from_toml
!> Check that two package objects are equal
logical function package_is_same(this,that)
class(package_t), intent(in) :: this
class(serializable_t), intent(in) :: that
integer :: ii
package_is_same = .false.
select type (other=>that)
type is (package_t)
if (allocated(this%name).neqv.allocated(other%name)) return
if (allocated(this%name)) then
if (.not.(this%name==other%name)) return
end if
if (allocated(this%sources).neqv.allocated(other%sources)) return
if (allocated(this%sources)) then
if (.not.(size(this%sources)==size(other%sources))) return
do ii = 1, size(this%sources)
if (.not.(this%sources(ii)==other%sources(ii))) return
end do
end if
if (.not.(this%preprocess==other%preprocess)) return
if (allocated(this%version).neqv.allocated(other%version)) return
if (allocated(this%version)) then
if (.not.(this%version==other%version)) return
end if
!> Module naming
if (.not.(this%enforce_module_names.eqv.other%enforce_module_names)) return
if (.not.(this%module_prefix==other%module_prefix)) return
!> Fortran features
if (.not.(this%features==other%features)) return
class default
! Not the same type
return
end select
!> All checks passed!
package_is_same = .true.
end function package_is_same
!> Dump dependency to toml table
subroutine package_dump_to_toml(self, table, error)
!> Instance of the serializable object
class(package_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: ierr, ii
type(toml_table), pointer :: ptr,this_source
character(16) :: src_name
call set_string(table, "name", self%name, error, 'package_t')
if (allocated(error)) return
if (allocated(self%version)) then
call set_value(table, "version", self%version%s())
end if
if (allocated(error)) return
call set_value(table, "module-naming", self%enforce_module_names, error, 'package_t')
if (allocated(error)) return
call set_string(table, "module-prefix", self%module_prefix, error, 'package_t')
if (allocated(error)) return
!> Create a preprocessor table
call add_table(table, "preprocess", ptr, error, 'package_t')
if (allocated(error)) return
call self%preprocess%dump_to_toml(ptr, error)
if (allocated(error)) return
!> Create a fortran table
call add_table(table, "fortran", ptr, error, 'package_t')
if (allocated(error)) return
call self%features%dump_to_toml(ptr, error)
if (allocated(error)) return
!> Create a sources table
if (allocated(self%sources)) then
call add_table(table, "sources", ptr, error, 'package_t')
if (allocated(error)) return
do ii = 1, size(self%sources)
write(src_name,1) ii
call add_table(ptr, trim(src_name), this_source, error, 'package_t[source]')
if (allocated(error)) return
call self%sources(ii)%dump_to_toml(this_source,error)
if (allocated(error)) return
end do
end if
1 format('src_',i0)
end subroutine package_dump_to_toml
!> Read dependency from toml table (no checks made at this stage)
subroutine package_load_from_toml(self, table, error)
!> Instance of the serializable object
class(package_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: ierr,ii,jj
type(toml_key), allocatable :: keys(:),src_keys(:)
type(toml_table), pointer :: ptr_sources,ptr,ptr_fortran,ptr_preprocess
type(error_t), allocatable :: new_error
character(len=:), allocatable :: version
call get_value(table, "name", self%name)
call get_value(table, "version", version)
if (allocated(version)) then
if (.not.allocated(self%version)) allocate(self%version)
call new_version(self%version, version, error)
if (allocated(error)) then
error%message = 'package_t: version error from TOML table - '//error%message
return
endif
end if
call get_value(table, "module-naming", self%enforce_module_names, error, 'package_t')
if (allocated(error)) return
! Return unallocated value if not present
call get_value(table, "module-prefix", self%module_prefix%s)
! Sources
call table%get_keys(keys)
find_others: do ii = 1, size(keys)
select case (keys(ii)%key)
case ("fortran")
call get_value(table, keys(ii), ptr_fortran)
if (.not.associated(ptr_fortran)) then
call fatal_error(error,'package_t: error retrieving fortran table from TOML table')
return
end if
call self%features%load_from_toml(ptr_fortran,error)
if (allocated(error)) return
case ("preprocess")
call get_value(table, keys(ii), ptr_preprocess)
if (.not.associated(ptr_preprocess)) then
call fatal_error(error,'package_t: error retrieving preprocess table from TOML table')
return
end if
call self%preprocess%load_from_toml(ptr_preprocess,error)
if (allocated(error)) return
case ("sources")
call get_value(table, keys(ii), ptr_sources)
if (.not.associated(ptr_sources)) then
call fatal_error(error,'package_t: error retrieving sources table from TOML table')
return
end if
!> Read all dependencies
call ptr_sources%get_keys(src_keys)
allocate(self%sources(size(src_keys)))
do jj = 1, size(src_keys)
call get_value(ptr_sources, src_keys(jj), ptr)
call self%sources(jj)%load_from_toml(ptr, error)
if (allocated(error)) return
end do
case default
cycle find_others
end select
end do find_others
end subroutine package_load_from_toml
!> Check that two model objects are equal
logical function model_is_same(this,that)
class(fpm_model_t), intent(in) :: this
class(serializable_t), intent(in) :: that
type(fpm_model_t), pointer :: other
integer :: ii
model_is_same = .false.
select type (other=>that)
type is (fpm_model_t)
if ((allocated(this%package_name).neqv.allocated(other%package_name))) return
if (allocated(this%package_name)) then
if (.not.(this%package_name==other%package_name)) return
end if
if (.not.(allocated(this%packages).eqv.allocated(other%packages))) return
if (allocated(this%packages)) then
if (.not.(size(this%packages)==size(other%packages))) return
do ii = 1, size(this%packages)
if (.not.(this%packages(ii)==other%packages(ii))) return
end do
end if
if (.not.(this%compiler==other%compiler)) return
if (.not.(this%archiver==other%archiver)) return
if (allocated(this%fortran_compile_flags).neqv.allocated(other%fortran_compile_flags)) return
if (allocated(this%fortran_compile_flags)) then
if (.not.(this%fortran_compile_flags==other%fortran_compile_flags)) return
end if
if (allocated(this%c_compile_flags).neqv.allocated(other%c_compile_flags)) return
if (allocated(this%c_compile_flags)) then
if (.not.(this%c_compile_flags==other%c_compile_flags)) return
end if
if (allocated(this%cxx_compile_flags).neqv.allocated(other%cxx_compile_flags)) return
if (allocated(this%cxx_compile_flags)) then
if (.not.(this%cxx_compile_flags==other%cxx_compile_flags)) return
end if
if (allocated(this%link_flags).neqv.allocated(other%link_flags)) return
if (allocated(this%link_flags)) then
if (.not.(this%link_flags==other%link_flags)) return
end if
if (allocated(this%build_prefix).neqv.allocated(other%build_prefix)) return
if (allocated(this%build_prefix)) then
if (.not.(this%build_prefix==other%build_prefix)) return
end if
if (allocated(this%build_dir).neqv.allocated(other%build_dir)) return
if (allocated(this%build_dir)) then
if (.not.(this%build_dir==other%build_dir)) return
end if
if (allocated(this%include_dirs).neqv.allocated(other%include_dirs)) return
if (allocated(this%include_dirs)) then
if (.not.(this%include_dirs==other%include_dirs)) return
end if
if (allocated(this%link_libraries).neqv.allocated(other%link_libraries)) return
if (allocated(this%link_libraries)) then
if (.not.(this%link_libraries==other%link_libraries)) return
end if
if (allocated(this%external_modules).neqv.allocated(other%external_modules)) return
if (allocated(this%external_modules)) then
if (.not.(this%external_modules==other%external_modules)) return
end if
if (.not.(this%deps==other%deps)) return
if (.not.(this%include_tests.eqv.other%include_tests)) return
if (.not.(this%enforce_module_names.eqv.other%enforce_module_names)) return
if (.not.(this%module_prefix==other%module_prefix)) return
if (.not.(this%target_os==other%target_os)) return
class default
! Not the same type
return
end select
!> All checks passed!
model_is_same = .true.
end function model_is_same
!> Dump dependency to toml table
subroutine model_dump_to_toml(self, table, error)
!> Instance of the serializable object
class(fpm_model_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: ierr, ii
type(toml_table), pointer :: ptr,ptr_pkg
character(27) :: unnamed
call set_string(table, "package-name", self%package_name, error, 'fpm_model_t')
if (allocated(error)) return
call add_table(table, "compiler", ptr, error, 'fpm_model_t')
if (allocated(error)) return
call self%compiler%dump_to_toml(ptr, error)
if (allocated(error)) return
call add_table(table, "archiver", ptr, error, 'fpm_model_t')
if (allocated(error)) return
call self%archiver%dump_to_toml(ptr, error)
if (allocated(error)) return
call set_string(table, "fortran-flags", self%fortran_compile_flags, error, 'fpm_model_t')
if (allocated(error)) return
call set_string(table, "c-flags", self%c_compile_flags, error, 'fpm_model_t')
if (allocated(error)) return
call set_string(table, "cxx-flags", self%cxx_compile_flags, error, 'fpm_model_t')
if (allocated(error)) return
call set_string(table, "link-flags", self%link_flags, error, 'fpm_model_t')
if (allocated(error)) return
call set_string(table, "build-prefix", self%build_prefix, error, 'fpm_model_t')
if (allocated(error)) return
call set_string(table, "build-dir", self%build_dir, error, 'fpm_model_t')
if (allocated(error)) return
call set_list(table, "include-dirs", self%include_dirs, error)
if (allocated(error)) return
call set_list(table, "link-libraries", self%link_libraries, error)
if (allocated(error)) return
call set_list(table, "external-modules", self%external_modules, error)
if (allocated(error)) return
call set_value(table, "include-tests", self%include_tests, error, 'fpm_model_t')
if (allocated(error)) return
call set_value(table, "module-naming", self%enforce_module_names, error, 'fpm_model_t')
if (allocated(error)) return
call set_string(table, "module-prefix", self%module_prefix, error, 'fpm_model_t')
if (allocated(error)) return
! Serialize target OS as string
call set_string(table, "target-os", OS_NAME(self%target_os), error, 'fpm_model_t')
if (allocated(error)) return
call add_table(table, "deps", ptr, error, 'fpm_model_t')
if (allocated(error)) return
call self%deps%dump_to_toml(ptr, error)
if (allocated(error)) return
!> Array of packages (including the root package)
if (allocated(self%packages)) then
! Create packages table
call add_table(table, "packages", ptr_pkg)
if (.not. associated(ptr_pkg)) then
call fatal_error(error, "fpm_model_t cannot create dependency table ")
return
end if
do ii = 1, size(self%packages)
associate (pkg => self%packages(ii))
!> Because dependencies are named, fallback if this has no name
!> So, serialization will work regardless of size(self%dep) == self%ndep
if (len_trim(pkg%name)==0) then
write(unnamed,1) ii
call add_table(ptr_pkg, trim(unnamed), ptr, error, 'fpm_model_t[package]')
else
call add_table(ptr_pkg, pkg%name, ptr, error, 'fpm_model_t[package]')
end if
if (allocated(error)) return
call pkg%dump_to_toml(ptr, error)
if (allocated(error)) return
end associate
end do
end if
1 format('UNNAMED_PACKAGE_',i0)
end subroutine model_dump_to_toml
!> Read dependency from toml table (no checks made at this stage)
subroutine model_load_from_toml(self, table, error)
!> Instance of the serializable object
class(fpm_model_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_key), allocatable :: keys(:),pkg_keys(:)
integer :: ierr, ii, jj
type(toml_table), pointer :: ptr,ptr_pkg
character(:), allocatable :: os_string
logical :: is_valid
call table%get_keys(keys)
call get_value(table, "package-name", self%package_name)
call get_value(table, "fortran-flags", self%fortran_compile_flags)
call get_value(table, "c-flags", self%c_compile_flags)
call get_value(table, "cxx-flags", self%cxx_compile_flags)
call get_value(table, "link-flags", self%link_flags)
call get_value(table, "build-prefix", self%build_prefix)
call get_value(table, "build-dir", self%build_dir)
if (allocated(self%packages)) deallocate(self%packages)
sub_deps: do ii = 1, size(keys)
select case (keys(ii)%key)
case ("compiler")
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,'fpm_model_t: error retrieving compiler table')
return
end if
call self%compiler%load_from_toml(ptr, error)
if (allocated(error)) return
case ("archiver")
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,'fpm_model_t: error retrieving archiver table')
return
end if
call self%archiver%load_from_toml(ptr, error)
if (allocated(error)) return
case ("deps")
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,'fpm_model_t: error retrieving dependency tree table')
return
end if
call self%deps%load_from_toml(ptr, error)
if (allocated(error)) return
case ("packages")
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,'fpm_model_t: error retrieving packages table')
return
end if
!> Read all packages
call ptr%get_keys(pkg_keys)
allocate(self%packages(size(pkg_keys)))
do jj = 1, size(pkg_keys)
call get_value(ptr, pkg_keys(jj), ptr_pkg)
call self%packages(jj)%load_from_toml(ptr_pkg, error)
if (allocated(error)) return
end do
case default
cycle sub_deps
end select
end do sub_deps
call get_list(table, "include-dirs", self%include_dirs, error)
if (allocated(error)) return
call get_list(table, "link-libraries", self%link_libraries, error)
if (allocated(error)) return
call get_list(table, "external-modules", self%external_modules, error)
if (allocated(error)) return
call get_value(table, "include-tests", self%include_tests, error, 'fpm_model_t')
if (allocated(error)) return
call get_value(table, "module-naming", self%enforce_module_names, error, 'fpm_model_t')
if (allocated(error)) return
call get_value(table, "module-prefix", self%module_prefix%s)
! Load target OS from string and validate
call get_value(table, "target-os", os_string)
if (allocated(os_string)) then
! Validate and convert OS string to integer
call validate_os_name(os_string, is_valid)
if (.not. is_valid) then
call fatal_error(error, "Invalid target OS: " // os_string)
return
end if
self%target_os = match_os_type(os_string)
else
! Default to ALL OS if not specified
self%target_os = OS_ALL
end if
end subroutine model_load_from_toml
!> Get target platform configuration for the current model
function target_platform(self) result(target)
class(fpm_model_t), intent(in) :: self
type(platform_config_t) :: target
! Initialize platform with compiler and target OS
target = platform_config_t(self%compiler%id, self%target_os)
end function target_platform
function get_package_libraries_link(model, package_name, prefix, exclude_self, dep_IDs, error) result(r)
class(fpm_model_t), intent(in) :: model
character(*), intent(in) :: package_name
type(error_t), allocatable, intent(out) :: error
character(*), intent(in) :: prefix
!> Option to exclude linking to the given package (needed building it as a library)
logical, optional, intent(in) :: exclude_self
!> Optionally export the list of dependency IDs
integer, allocatable, optional, intent(out) :: dep_IDs(:)
character(len=:), allocatable :: r
integer :: id,ndep,i
logical :: no_root
integer, allocatable :: sorted_package_IDs(:)
logical, allocatable :: has_lib(:)
type(string_t), allocatable :: package_deps(:)
! Get dependency ID of this target
id = model%deps%find(package_name)
if (id<=0) then
call fatal_error(error, "Internal error: shared library "//package_name// &
" does not correspond to a package")
return
end if
! Get ordered IDs of the shared libraries that should be linked against
call model%deps%local_link_order(id, sorted_package_IDs, error)
if (allocated(error)) return
! Get names of the package dependencies
ndep = size(sorted_package_IDs)
if (ndep<=0) then
r = prefix
if (present(dep_IDs)) allocate(dep_IDs(0))
return
end if
! Optional exclusion of self (top-level) package
no_root = .false.
if (present(exclude_self)) no_root = exclude_self
if (no_root) then
sorted_package_IDs = pack(sorted_package_IDs, sorted_package_IDs /= id)
ndep = size(sorted_package_IDs)
endif
! Exclusion of package IDs marked "empty" (i.e. they contain no sources)
has_lib = model%packages%has_library()
if (any(.not.has_lib)) then
sorted_package_IDs = pack(sorted_package_IDs, has_lib(sorted_package_IDs))
ndep = size(sorted_package_IDs)
end if
allocate(package_deps(ndep))
do i=1,ndep
package_deps(i) = string_t(model%deps%dep(sorted_package_IDs(i))%name)
end do
r = model%compiler%enumerate_libraries(prefix, package_deps)
! If requested, export the list of dependency IDs
if (present(dep_IDs)) call move_alloc(from=sorted_package_IDs,to=dep_IDs)
end function get_package_libraries_link
!> Check whether a package has an object library
elemental logical function package_has_library(self) result(has_library)
class(package_t), intent(in) :: self
if (allocated(self%sources)) then
has_library = any(self%sources%unit_scope==FPM_SCOPE_LIB)
else
has_library = .false.
end if
end function package_has_library
end module fpm_model
fortran-lang-fpm-90bb83a/src/fpm_command_line.f90 0000664 0001750 0001750 00000274632 15145116760 022104 0 ustar alastair alastair !># 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, OS_OPENBSD, OS_NAME
use M_CLI2, only : set_args, lget, sget, unnamed, remaining, specified
use M_CLI2, only : get_subcommand, CLI_RESPONSE_FILE
use fpm_strings, only : lower, split, to_fortran_name, is_fortran_name, remove_characters_in_set, &
string_t, glob, is_valid_feature_name
use fpm_filesystem, only : basename, canon_path, which, run
use fpm_environment, only : get_command_arguments_quoted
use fpm_error, only : fpm_stop, error_t
use fpm_os, only : get_current_directory
use fpm_release, only : fpm_version, version_t
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_export_settings, &
fpm_new_settings, &
fpm_run_settings, &
fpm_test_settings, &
fpm_update_settings, &
fpm_clean_settings, &
fpm_publish_settings, &
get_command_line_settings, &
get_fpm_env
type, abstract :: fpm_cmd_settings
character(len=:), allocatable :: working_dir
character(len=:), allocatable :: path_to_config
logical :: verbose=.true.
end type
integer,parameter :: ibug=4096
type, extends(fpm_cmd_settings) :: fpm_new_settings
character(len=:),allocatable :: name
logical :: with_executable=.false.
logical :: with_test=.false.
logical :: with_lib=.true.
logical :: with_example=.false.
logical :: with_full=.false.
logical :: with_bare=.false.
logical :: backfill=.true.
end type
type, extends(fpm_cmd_settings) :: fpm_build_settings
logical :: list=.false.
logical :: show_model=.false.
logical :: build_tests=.false.
logical :: prune=.true.
character(len=:),allocatable :: dump
character(len=:),allocatable :: compiler
character(len=:),allocatable :: c_compiler
character(len=:),allocatable :: cxx_compiler
character(len=:),allocatable :: archiver
character(len=:),allocatable :: profile
type(string_t), allocatable :: features(:)
character(len=:),allocatable :: flag
character(len=:),allocatable :: cflag
character(len=:),allocatable :: cxxflag
character(len=:),allocatable :: ldflag
character(len=:),allocatable :: build_dir
end type
type, extends(fpm_build_settings) :: fpm_run_settings
character(len=ibug),allocatable :: name(:)
character(len=:),allocatable :: args ! passed to the app
character(len=:),allocatable :: runner
character(len=:),allocatable :: runner_args ! passed to the runner
logical :: example
contains
procedure :: runner_command
procedure :: name_ID
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 :: testdir
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(:)
character(len=:),allocatable :: dump
logical :: fetch_only
logical :: clean
end type
!> Settings for exporting model data
type, extends(fpm_build_settings) :: fpm_export_settings
character(len=:),allocatable :: dump_manifest
character(len=:),allocatable :: dump_dependencies
character(len=:),allocatable :: dump_model
end type
type, extends(fpm_build_settings) :: fpm_clean_settings
logical :: clean_skip = .false.
logical :: clean_all = .false.
logical :: clean_test = .false.
logical :: clean_apps = .false.
logical :: clean_examples = .false.
logical :: registry_cache = .false.
end type
type, extends(fpm_build_settings) :: fpm_publish_settings
logical :: show_package_version = .false.
logical :: show_upload_data = .false.
logical :: is_dry_run = .false.
character(len=:), allocatable :: token
end type
character(len=:),allocatable :: name
character(len=:),allocatable :: os_type
character(len=ibug),allocatable :: names(:)
character(len=:),allocatable :: tnames(:)
character(len=:), allocatable :: version_text(:)
character(len=:), allocatable :: help_new(:), help_fpm(:), help_run(:), &
& help_test(:), help_build(:), help_usage(:), help_runner(:), &
& help_text(:), help_install(:), help_help(:), help_update(:), &
& help_list(:), help_list_dash(:), help_list_nodash(:), &
& help_clean(:), help_publish(:)
character(len=20),parameter :: manual(*)=[ character(len=20) ::&
& ' ', 'fpm', 'new', 'build', 'run', 'clean', &
& 'test', 'runner', 'install', 'update', 'list', 'help', 'version', 'publish' ]
character(len=:), allocatable :: val_runner,val_runner_args,val_dump
! '12345678901234567890123456789012345678901234567890123456789012345678901234567890',&
character(len=80), parameter :: help_text_build_common(*) = [character(len=80) :: &
' --profile PROF Selects either a compilation profile ("release", "debug") or ',&
' a feature profile defined in fpm.toml. Feature profiles ',&
' group multiple features together. Cannot be used with ',&
' --features. If --flag is not specified the "debug" flags ',&
' default. ',&
' --features LIST Comma-separated list of features to enable (defined in ',&
' fpm.toml). Cannot be used with --profile. ',&
' Example: `fpm build --features mpi,openmp,hdf5 ` ',&
' --no-prune Disable tree-shaking/pruning of unused module dependencies ',&
' --build-dir DIR Specify the build directory. Default is "build" unless set ',&
' by the environment variable FPM_BUILD_DIR. '&
]
! '12345678901234567890123456789012345678901234567890123456789012345678901234567890',&
character(len=80), parameter :: help_text_compiler(*) = [character(len=80) :: &
' --compiler NAME Specify a compiler name. The default is "gfortran" ',&
' unless set by the environment variable FPM_FC. ',&
' --c-compiler NAME Specify the C compiler name. Automatically determined by ',&
' default unless set by the environment variable FPM_CC. ',&
' --cxx-compiler NAME Specify the C++ compiler name. Automatically determined by',&
' default unless set by the environment variable FPM_CXX. ',&
' --archiver NAME Specify the archiver name. Automatically determined by ',&
' default unless set by the environment variable FPM_AR. '&
]
! '12345678901234567890123456789012345678901234567890123456789012345678901234567890',&
character(len=80), parameter :: help_text_flag(*) = [character(len=80) :: &
' --flag FFLAGS selects compile arguments for the build, the default value is',&
' set by the FPM_FFLAGS environment variable. These are added ',&
' to the profile options if --profile is specified, else these ',&
' are added to the defaults. To override the defaults, use the ',&
' keyword [fortran] in the manifest. Note object and .mod ',&
' directory locations are always built in. ',&
' --c-flag CFLAGS selects compile arguments specific for C source in the build.',&
' The default value is set by the FPM_CFLAGS environment ',&
' variable. ',&
' --cxx-flag CFLAGS selects compile arguments specific for C++ source in the ',&
' build. The default value is set by the FPM_CXXFLAGS ',&
' environment variable. ',&
' --link-flag LDFLAGS select arguments passed to the linker for the build. The ',&
' default value is set by the FPM_LDFLAGS environment variable.'&
]
character(len=80), parameter :: help_text_environment(*) = [character(len=80) :: &
'ENVIRONMENT VARIABLES',&
' FPM_FC sets the path to the Fortran compiler used for the build,', &
' will be overwritten by --compiler command line option', &
'', &
' FPM_FFLAGS sets the arguments for the Fortran compiler', &
' will be overwritten by --flag command line option', &
'', &
' FPM_CC sets the path to the C compiler used for the build,', &
' will be overwritten by --c-compiler command line option', &
'', &
' FPM_CFLAGS sets the arguments for the C compiler', &
' will be overwritten by --c-flag command line option', &
'', &
' FPM_CXX sets the path to the C++ compiler used for the build,', &
' will be overwritten by --cxx-compiler command line option', &
'', &
' FPM_CXXFLAGS sets the arguments for the C++ compiler', &
' will be overwritten by --cxx-flag command line option', &
'', &
' FPM_AR sets the path to the archiver used for the build,', &
' will be overwritten by --archiver command line option', &
'', &
' FPM_LDFLAGS sets additional link arguments for creating executables', &
' will be overwritten by --link-flag command line option', &
'', &
' FPM_BUILD_DIR sets the build directory for compilation output', &
' will be overwritten by --build-dir command line option' &
]
contains
subroutine get_command_line_settings(cmd_settings)
class(fpm_cmd_settings), allocatable, intent(out) :: cmd_settings
integer, parameter :: widest = 256
character(len=4096) :: cmdarg
integer :: i
integer :: os
type(fpm_install_settings), allocatable :: install_settings
type(fpm_export_settings) , allocatable :: export_settings
type(version_t) :: version
character(len=:), allocatable :: common_args, compiler_args, run_args, working_dir, &
& c_compiler, cxx_compiler, archiver, version_s, token_s, config_file
character(len=*), parameter :: fc_env = "FC", cc_env = "CC", ar_env = "AR", &
& fflags_env = "FFLAGS", cflags_env = "CFLAGS", cxxflags_env = "CXXFLAGS", &
& ldflags_env = "LDFLAGS", fc_default = "gfortran", cc_default = " ", ar_default = " ", &
& flags_default = " ", cxx_env = "CXX", cxx_default = " ", build_dir_env = "BUILD_DIR", &
& build_dir_default = "build"
type(error_t), allocatable :: error
call set_help()
os = get_os_type()
! text for --version switch,
select case (os)
case (OS_LINUX); os_type = "OS Type: Linux"
case (OS_MACOS); os_type = "OS Type: macOS"
case (OS_WINDOWS); os_type = "OS Type: Windows"
case (OS_CYGWIN); os_type = "OS Type: Cygwin"
case (OS_SOLARIS); os_type = "OS Type: Solaris"
case (OS_FREEBSD); os_type = "OS Type: FreeBSD"
case (OS_OPENBSD); os_type = "OS Type: OpenBSD"
case (OS_UNKNOWN); os_type = "OS Type: Unknown"
case default ; os_type = "OS Type: UNKNOWN"
end select
! Get current release version
version = fpm_version()
version_s = version%s()
version_text = [character(len=80) :: &
& 'Version: '//trim(version_s)//', alpha', &
& 'Program: fpm(1)', &
& 'Description: A Fortran package manager and build system', &
& 'Home Page: https://github.com/fortran-lang/fpm', &
& 'License: MIT', &
& os_type]
! find the subcommand name by looking for first word on command
! not starting with dash
CLI_RESPONSE_FILE=.true.
cmdarg = get_subcommand()
common_args = &
' --directory:C " "' // &
' --verbose F'
run_args = &
' --target " "' // &
' --list F' // &
' --runner " "' // &
' --runner-args " "'
compiler_args = &
' --profile " "' // &
' --features " "' // &
' --no-prune F' // &
' --compiler "'//get_fpm_env(fc_env, fc_default)//'"' // &
' --c-compiler "'//get_fpm_env(cc_env, cc_default)//'"' // &
' --cxx-compiler "'//get_fpm_env(cxx_env, cxx_default)//'"' // &
' --archiver "'//get_fpm_env(ar_env, ar_default)//'"' // &
' --flag:: "'//get_fpm_env(fflags_env, flags_default)//'"' // &
' --c-flag:: "'//get_fpm_env(cflags_env, flags_default)//'"' // &
' --cxx-flag:: "'//get_fpm_env(cxxflags_env, flags_default)//'"' // &
' --link-flag:: "'//get_fpm_env(ldflags_env, flags_default)//'"' // &
' --build-dir "'//get_fpm_env(build_dir_env, build_dir_default)//'"'
! now set subcommand-specific help text and process commandline
! arguments. Then call subcommand routine
select case(trim(cmdarg))
case('run')
call set_args(common_args // compiler_args // run_args //'&
& --all F &
& --example F &
& --config-file " " &
& --',help_run,version_text)
! Collect target names
if( size(unnamed) > 1 )then
names=unnamed(2:)
else
names=[character(len=len(names)) :: ]
endif
if(specified('target') )then
call split(sget('target'),tnames,delimiters=' ,:')
names=[character(len=max(len(names),len(tnames))) :: names,tnames]
endif
! convert --all to '*'
if(lget('all'))then
names=[character(len=max(len(names),1)) :: names,'*' ]
endif
! convert special string '..' to equivalent (shorter) '*'
! to allow for a string that does not require shift-key and quoting
do i=1,size(names)
if(names(i)=='..')names(i)='*'
enddo
! If there are additional command-line arguments, remove the additional
! double quotes which have been added by M_CLI2
val_runner_args=sget('runner-args')
call remove_characters_in_set(val_runner_args,set='"')
! Allocate and populate (parent build settings via helper)
allocate(fpm_run_settings :: cmd_settings)
select type (cmd => cmd_settings)
type is (fpm_run_settings)
call build_settings(cmd, list=lget('list'), build_tests=.false., &
config_file=sget('config-file'))
! Runner defaults/overrides
val_runner = sget('runner')
if (specified('runner') .and. val_runner == '') val_runner = 'echo'
! Run-specific fields
if (allocated(remaining)) cmd%args = remaining
cmd%example = lget('example')
cmd%name = names
cmd%runner = val_runner
cmd%runner_args = val_runner_args
end select
case('build')
call set_args(common_args // compiler_args //'&
& --list F &
& --show-model F &
& --dump " " &
& --tests F &
& --config-file " " &
& --',help_build,version_text)
! Create and populate a base fpm_build_settings from CLI/env
allocate( fpm_build_settings :: cmd_settings )
select type (cmd => cmd_settings)
class is (fpm_build_settings)
call build_settings(cmd, list=lget('list'), &
show_model=lget('show-model'), &
build_tests=lget('tests'), &
config_file=sget('config-file') )
end select
case('new')
call set_args(common_args // '&
& --src F &
& --lib F &
& --app F &
& --test F &
& --example F &
& --backfill F &
& --full F &
& --bare F &
&', help_new, version_text)
select case(size(unnamed))
case(1)
if(lget('backfill'))then
name='.'
else
write(stderr,'(*(7x,g0,/))') &
& ' fpm new NAME [[--lib|--src] [--app] [--test] '//&
& ' [--example]]|[--full|--bare] [--backfill]'
call fpm_stop(1,'directory name required')
endif
case(2)
name=trim(unnamed(2))
case default
write(stderr,'(7x,g0)') &
& ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]] '//&
& '| [--full|--bare] [--backfill]'
call fpm_stop(2,'only one directory name allowed')
end select
!*! canon_path is not converting ".", etc.
if(name=='.')then
call get_current_directory(name, error)
if (allocated(error)) then
write(stderr, '("[Error]", 1x, a)') error%message
stop 1
endif
endif
name=canon_path(name)
if( .not.is_fortran_name(to_fortran_name(basename(name))) )then
write(stderr,'(g0)') [ character(len=72) :: &
& ' the fpm project name must be made of up to 63 ASCII letters,', &
& ' numbers, underscores, or hyphens, and start with a letter.']
call fpm_stop(4,' ')
endif
allocate(fpm_new_settings :: cmd_settings)
if (any( specified([character(len=10) :: 'src','lib','app','test','example','bare'])) &
& .and.lget('full') )then
write(stderr,'(*(a))')&
&' --full and any of [--src|--lib,--app,--test,--example,--bare]', &
&' are mutually exclusive.'
call fpm_stop(5,' ')
elseif (any( specified([character(len=10) :: 'src','lib','app','test','example','full'])) &
& .and.lget('bare') )then
write(stderr,'(*(a))')&
&' --bare and any of [--src|--lib,--app,--test,--example,--full]', &
&' are mutually exclusive.'
call fpm_stop(3,' ')
elseif (any( specified([character(len=10) :: 'src','lib','app','test','example']) ) )then
cmd_settings=fpm_new_settings(&
& backfill=lget('backfill'), &
& name=name, &
& with_executable=lget('app'), &
& with_lib=any([lget('lib'),lget('src')]), &
& with_test=lget('test'), &
& with_example=lget('example'), &
& verbose=lget('verbose') )
else ! default if no specific directories are requested
cmd_settings=fpm_new_settings(&
& backfill=lget('backfill') , &
& name=name, &
& with_executable=.true., &
& with_lib=.true., &
& with_test=.true., &
& with_example=lget('full'), &
& with_full=lget('full'), &
& with_bare=lget('bare'), &
& verbose=lget('verbose') )
endif
case('help', 'manual')
call set_args(common_args, help_help,version_text)
if(size(unnamed)<2)then
if(unnamed(1)=='help')then
unnamed=[' ', 'fpm']
else
unnamed=manual
endif
elseif(unnamed(2)=='manual')then
unnamed=manual
endif
allocate(character(len=widest) :: help_text(0))
do i=2,size(unnamed)
select case(unnamed(i))
case(' ' )
case('fpm ' )
help_text=[character(len=widest) :: help_text, help_fpm]
case('new ' )
help_text=[character(len=widest) :: help_text, help_new]
case('build ' )
help_text=[character(len=widest) :: help_text, help_build]
case('install' )
help_text=[character(len=widest) :: help_text, help_install]
case('run ' )
help_text=[character(len=widest) :: help_text, help_run]
case('test ' )
help_text=[character(len=widest) :: help_text, help_test]
case('runner' )
help_text=[character(len=widest) :: help_text, help_runner]
case('list ' )
help_text=[character(len=widest) :: help_text, help_list]
case('update ' )
help_text=[character(len=widest) :: help_text, help_update]
case('help ' )
help_text=[character(len=widest) :: help_text, help_help]
case('version' )
help_text=[character(len=widest) :: help_text, version_text]
case('clean' )
help_text=[character(len=widest) :: help_text, help_clean]
case('publish')
help_text=[character(len=widest) :: help_text, help_publish]
case default
help_text=[character(len=widest) :: help_text, &
& ' unknown help topic "'//trim(unnamed(i))//'"']
!!& ' unknown help topic "'//trim(unnamed(i)).'not found in:',manual]
end select
enddo
call printhelp(help_text)
case('install')
call set_args(common_args // compiler_args // '&
& --no-rebuild F &
& --prefix " " &
& --list F &
& --test F &
& --libdir "lib" &
& --bindir "bin" &
& --testdir "test" &
& --includedir "include" &
& --config-file " " &
&', help_install, version_text)
config_file = sget('config-file')
allocate(install_settings)
call build_settings(install_settings, list=lget('list'), &
build_tests=lget('test'), config_file=config_file)
install_settings%no_rebuild = lget('no-rebuild')
call get_char_arg(install_settings%prefix, 'prefix')
call get_char_arg(install_settings%libdir, 'libdir')
call get_char_arg(install_settings%testdir, 'testdir')
call get_char_arg(install_settings%bindir, 'bindir')
call get_char_arg(install_settings%includedir, 'includedir')
call move_alloc(install_settings, cmd_settings)
case('list')
call set_args(common_args // '&
& --list F &
&', help_list, version_text)
if(lget('list'))then
help_text = [character(widest) :: help_list_nodash, help_list_dash]
else
help_text = help_list_nodash
endif
call printhelp(help_text)
case('test')
call set_args(common_args // compiler_args // run_args // '&
& --config-file " " &
& -- ', help_test,version_text)
if( size(unnamed) > 1 )then
names=unnamed(2:)
else
names=[character(len=len(names)) :: ]
endif
if(specified('target') )then
call split(sget('target'),tnames,delimiters=' ,:')
names=[character(len=max(len(names),len(tnames))) :: names,tnames]
endif
! convert special string '..' to equivalent (shorter) '*'
! to allow for a string that does not require shift-key and quoting
do i=1,size(names)
if(names(i)=='..')names(i)='*'
enddo
! If there are additional command-line arguments, remove the additional
! double quotes which have been added by M_CLI2
val_runner_args=sget('runner-args')
call remove_characters_in_set(val_runner_args,set='"')
allocate(fpm_test_settings :: cmd_settings)
val_runner=sget('runner')
if(specified('runner') .and. val_runner=='')val_runner='echo'
select type (cmd => cmd_settings)
type is (fpm_test_settings)
call build_settings(cmd, list=lget('list'), build_tests=.true., &
config_file=sget('config-file'))
if (allocated(remaining)) cmd%args = remaining
cmd%example = .false.
cmd%name = names
cmd%runner = val_runner
cmd%runner_args = val_runner_args
end select
case('update')
call set_args(common_args // '&
& --fetch-only F &
& --clean F &
& --dump " " &
& --config-file " " &
&', help_update, version_text)
if( size(unnamed) > 1 )then
names=unnamed(2:)
else
names=[character(len=len(names)) :: ]
endif
config_file = sget('config-file')
val_dump = sget('dump')
if (specified('dump') .and. val_dump=='')val_dump='fpm_dependencies.toml'
allocate(fpm_update_settings :: cmd_settings)
cmd_settings=fpm_update_settings(name=names, &
& fetch_only=lget('fetch-only'), &
& dump=val_dump, &
& verbose=lget('verbose'), &
& path_to_config=config_file, &
& clean=lget('clean'))
case('export')
call set_args(common_args // compiler_args // '&
& --manifest "filename" &
& --model "filename" &
& --dependencies "filename" ', &
help_build, version_text)
allocate(export_settings)
call build_settings(export_settings, show_model=.true.)
call get_char_arg(export_settings%dump_model, 'model')
call get_char_arg(export_settings%dump_manifest, 'manifest')
call get_char_arg(export_settings%dump_dependencies, 'dependencies')
call move_alloc(export_settings, cmd_settings)
case('clean')
call set_args(common_args // compiler_args // &
& ' --registry-cache' // &
& ' --skip' // &
& ' --all' // &
& ' --test' // &
& ' --apps' // &
& ' --examples' // &
& ' --config-file ""', help_clean, version_text)
block
logical :: skip, clean_all, clean_test, clean_apps, clean_examples
logical :: target_specific
skip = lget('skip')
clean_all = lget('all')
clean_test = lget('test')
clean_apps = lget('apps')
clean_examples = lget('examples')
config_file = sget('config-file')
target_specific = any([clean_test, clean_apps, clean_examples])
if (all([skip, clean_all])) then
call fpm_stop(6, 'Do not specify both --skip and --all options on the clean subcommand.')
end if
if (target_specific .and. any([skip, clean_all])) then
call fpm_stop(6, 'Cannot combine target-specific flags (--test, --apps, '//&
'--examples) with --skip or --all.')
end if
allocate(fpm_clean_settings :: cmd_settings)
select type (cln => cmd_settings)
type is (fpm_clean_settings)
call build_settings(cln, config_file=config_file)
cln%clean_skip = skip
cln%registry_cache = lget('registry-cache')
cln%clean_all = clean_all
cln%clean_test = clean_test
cln%clean_apps = clean_apps
cln%clean_examples = clean_examples
! Ensure tests will be modeled if they have to be cleaned
if (clean_test) cln%build_tests = .true.
end select
end block
case('publish')
call set_args(common_args // compiler_args //'&
& --show-package-version F &
& --show-upload-data F &
& --dry-run F &
& --token " " &
& --list F &
& --show-model F &
& --tests F &
& --config-file " " &
& --', help_publish, version_text)
config_file = sget('config-file')
token_s = sget('token')
allocate(fpm_publish_settings :: cmd_settings)
select type (pub => cmd_settings)
type is (fpm_publish_settings)
call build_settings(pub, list=lget('list'), show_model=lget('show-model'), &
build_tests=lget('tests'), config_file=config_file)
pub%show_package_version = lget('show-package-version')
pub%show_upload_data = lget('show-upload-data')
pub%is_dry_run = lget('dry-run')
pub%token = token_s
end select
case default
if(cmdarg.ne.''.and.which('fpm-'//cmdarg).ne.'')then
call run('fpm-'//trim(cmdarg)//' '// get_command_arguments_quoted(),.false.)
stop
else
call set_args('&
& --list F&
&', help_fpm, version_text)
! Note: will not get here if --version or --usage or --help
! is present on commandline
if(lget('list'))then
help_text = help_list_dash
elseif(len_trim(cmdarg)==0)then
write(stdout,'(*(a))')'Fortran Package Manager:'
write(stdout,'(*(a))')' '
help_text = [character(widest) :: help_list_nodash, help_usage]
else
write(stderr,'(*(a))')' unknown subcommand [', &
& trim(cmdarg), ']'
help_text = [character(widest) :: help_list_dash, help_usage]
endif
call printhelp(help_text)
endif
end select
if (allocated(cmd_settings)) then
working_dir = sget("directory")
call move_alloc(working_dir, cmd_settings%working_dir)
end if
end subroutine get_command_line_settings
!> Validate that build directory is not a reserved source directory name
subroutine validate_build_dir(build_dir)
character(len=*), intent(in) :: build_dir
character(len=*), parameter :: reserved_names(*) = [ &
"src ", "app ", "test ", "tests ", &
"example ", "examples", "include "]
character(len=:), allocatable :: normalized_build_dir, normalized_reserved
integer :: i
! Skip validation if build_dir is empty (will use default)
if (len_trim(build_dir) == 0) return
! Normalize the build directory path
normalized_build_dir = canon_path(build_dir)
! Check against reserved directory names
do i = 1, size(reserved_names)
normalized_reserved = canon_path(trim(reserved_names(i)))
if (normalized_build_dir == normalized_reserved) then
call fpm_stop(1, 'Error: Build directory "'//trim(build_dir) &
//'" conflicts with source directory "' &
//trim(reserved_names(i))//'".')
end if
end do
! Additional checks for problematic cases
if (trim(build_dir) == "." .or. trim(build_dir) == "..") then
call fpm_stop(1, 'Error: Build directory cannot be "'//trim(build_dir)// &
'" as it would overwrite the current or parent directory.')
end if
end subroutine validate_build_dir
!> Print help text and stop
subroutine printhelp(lines)
character(len=:),intent(in),allocatable :: lines(:)
integer :: iii,ii
if(allocated(lines))then
ii=size(lines)
if(ii > 0 .and. len(lines)> 0) then
write(stdout,'(g0)')(trim(lines(iii)), iii=1, ii)
else
write(stdout,'(a)')' *printhelp* output requested is empty'
endif
endif
stop
end subroutine printhelp
subroutine set_help()
help_list_nodash=[character(len=80) :: &
'USAGE: fpm [ SUBCOMMAND [SUBCOMMAND_OPTIONS] ]|[--list|--help|--version]', &
' where SUBCOMMAND is commonly new|build|run|test ', &
' ', &
' subcommand may be one of ', &
' ', &
' build Compile the package placing results in the "build" directory', &
' help Display help ', &
' list Display this list of subcommand descriptions ', &
' new Create a new Fortran package directory with sample files ', &
' run Run the local package application programs ', &
' test Run the test programs ', &
' update Update and manage project dependencies ', &
' install Install project ', &
' clean Delete the build ', &
' publish Publish package to the registry ', &
' ', &
' 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] [--features LIST] [--list] ', &
' [--flag FFLAGS] [--tests] [--no-prune] [--dump [FILENAME]] ', &
' [--config-file PATH] ', &
' help [NAME(s)] ', &
' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', &
' [--full|--bare][--backfill] ', &
' update [NAME(s)] [--fetch-only] [--clean] [--verbose] [--dump [FILENAME]] ', &
' list [--list] ', &
' run [[--target] NAME(s) [--example] [--profile PROF] [--features LIST] [--all]', &
' [--runner "CMD"] [--compiler COMPILER_NAME] [--list] [-- ARGS] ', &
' [--config-file PATH] [--flag FFLAGS] ', &
' test [[--target] NAME(s)] [--profile PROF] [--features LIST] [--flag FFLAGS] ', &
' [--runner "CMD"] [--list] [--compiler COMPILER_NAME] [--config-file PATH] ', &
' [-- ARGS] ', &
' install [--profile PROF] [--flag FFLAGS] [--no-rebuild] [--prefix PATH] ', &
' [--config-file PATH] [--registry-cache] [options] ', &
' clean [--skip|--all] [--test] [--apps] [--examples] [--config-file PATH] ', &
' [--registry-cache] ', &
' publish [--token TOKEN] [--show-package-version] [--show-upload-data] ', &
' [--dry-run] [--verbose] [--config-file PATH] ', &
' ']
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 ... --runner-args ARGS -- 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". ', &
' --runner-args "args" an additional option to pass command-line arguments ', &
' to the runner command, instead of to the fpm app. ', &
' -- SUFFIX_OPTIONS additional options to suffix the command CMD and executable ', &
' file names with. These options are passed as command-line ', &
' arguments to the app. ', &
'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 "mpiexec" --runner-args "-np 12" ', &
' fpm run --runner ldd ', &
' fpm run --runner strip ', &
' fpm run --runner ''cp -t /usr/local/bin'' ', &
' ', &
' # options after executable name can be specified after the -- option ', &
' fpm --runner cp run -- /usr/local/bin/ ', &
' # generates commands of the form "cp $FILENAME /usr/local/bin/" ', &
' ', &
' # bash(1) alias example: ', &
' alias fpm-install=\ ', &
' "fpm run --profile release --runner ''install -vbp -m 0711 -t ~/.local/bin''" ', &
' fpm-install ', &
'' ]
help_fpm=[character(len=80) :: &
'NAME ', &
' fpm(1) - A Fortran package manager and build system ', &
' ', &
'SYNOPSIS ', &
' fpm SUBCOMMAND [SUBCOMMAND_OPTIONS] ', &
' ', &
' fpm --help|--version|--list ', &
' ', &
'DESCRIPTION ', &
' fpm(1) is a package manager that helps you create Fortran projects ', &
' from source -- it automatically determines dependencies! ', &
' ', &
' Most significantly fpm(1) lets you draw upon other fpm(1) packages ', &
' in distributed git(1) repositories as if the packages were a basic ', &
' part of your default programming environment, as well as letting ', &
' you share your projects with others in a similar manner. ', &
' ', &
' All output goes into the directory "build/" which can generally be ', &
' removed and rebuilt if required. Note that if external packages are ', &
' being used you need network connectivity to rebuild from scratch. ', &
' ', &
'SUBCOMMANDS ', &
' Valid fpm(1) subcommands are: ', &
' ', &
' + build Compile the packages into the "build/" directory. ', &
' + new Create a new Fortran package directory with sample files. ', &
' + update Update the project dependencies. ', &
' + run Run the local package binaries. Defaults to all binaries ', &
' for that release. ', &
' + test Run the tests. ', &
' + help Alternate to the --help switch for displaying help text. ', &
' + list Display brief descriptions of all subcommands. ', &
' + install Install project. ', &
' + clean Delete directories in the "build/" directory, except ', &
' dependencies. Use --test/--apps/--examples for selective. ', &
' + publish Publish package to the registry. ', &
' ', &
' Their syntax is ', &
' ', &
' build [--profile PROF] [--flag FFLAGS] [--list] [--compiler COMPILER_NAME] ', &
' [--tests] [--no-prune] [--config-file PATH] ', &
' [--dump [FILENAME]] ', &
' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', &
' [--full|--bare][--backfill] ', &
' update [NAME(s)] [--fetch-only] [--clean] [--config-file PATH] [--dump [FILENAME]]', &
' run [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--list] [--all] ', &
' [--example] [--runner "CMD"] [--compiler COMPILER_NAME] ', &
' [--no-prune] [-- ARGS] [--config-file PATH] ', &
' test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--list] ', &
' [--runner "CMD"] [--compiler COMPILER_NAME] [--no-prune] [-- ARGS] ', &
' [--config-file PATH] ', &
' help [NAME(s)] ', &
' list [--list] ', &
' install [--profile PROF] [--flag FFLAGS] [--no-rebuild] [--prefix PATH] ', &
' [options] [--config-file PATH] [--registry-cache] ', &
' clean [--skip|--all] [--test] [--apps] [--examples] [--config-file PATH] ', &
' [--registry-cache] ', &
' publish [--token TOKEN] [--show-package-version] [--show-upload-data] ', &
' [--dry-run] [--verbose] [--config-file PATH] ', &
' ', &
'SUBCOMMAND OPTIONS ', &
' -C, --directory PATH', &
' Change working directory to PATH before running any command', &
help_text_build_common, &
help_text_compiler, &
help_text_flag, &
' --list List candidates instead of building or running them. On ', &
' the fpm(1) command this shows a brief list of subcommands.', &
' --runner CMD Provides a command to prefix program execution paths. ', &
' -- ARGS Arguments to pass to executables. ', &
' --skip Delete directories in the build/ directory without ', &
' prompting, but skip dependencies. Cannot be used together ', &
' with --all. ', &
' --all Delete directories in the build/ directory without ', &
' prompting, including dependencies. Cannot be used together', &
' with --skip. ', &
' --registry-cache Delete registry cache. ', &
' ', &
'VALID FOR ALL SUBCOMMANDS ', &
' --help Show help text and exit ', &
' --verbose Display additional information when available ', &
' --version Show version information and exit. ', &
' ', &
'@file ', &
' You may replace the default options for the fpm(1) command from a ', &
' file if your first options begin with @file. Initial options will ', &
' then be read from the "response file" "file.rsp" in the current ', &
' directory. ', &
' ', &
' If "file" does not exist or cannot be read, then an error occurs and', &
' the program stops. Each line of the file is prefixed with "options" ', &
' and interpreted as a separate argument. The file itself may not ', &
' contain @file arguments. That is, it is not processed recursively. ', &
' ', &
' For more information on response files see ', &
' ', &
' https://urbanjost.github.io/M_CLI2/set_args.3m_cli2.html ', &
' ', &
' The basic functionality described here will remain the same, but ', &
' other features described at the above reference may change. ', &
' ', &
' An example file: ', &
' ', &
' # my build options ', &
' options build ', &
' options --compiler gfortran ', &
' options --flag "-pg -static -pthread -Wunreachable-code -Wunused ', &
' -Wuninitialized -g -O -fbacktrace -fdump-core -fno-underscoring ', &
' -frecord-marker=4 -L/usr/X11R6/lib -L/usr/X11R6/lib64 -lX11" ', &
' ', &
' Note --flag would have to be on one line as response files do not ', &
' (currently) allow for continued lines or multiple specifications of ', &
' the same option. ', &
' ', &
help_text_environment, &
' ', &
'EXAMPLES ', &
' sample commands: ', &
' ', &
' fpm new mypackage --app --test ', &
' fpm build ', &
' fpm test ', &
' fpm run ', &
' fpm run --example ', &
' fpm new --help ', &
' fpm run myprogram --profile release -- -x 10 -y 20 --title "my title" ', &
' fpm install --prefix ~/.local ', &
' fpm clean --all ', &
' ', &
'SEE ALSO ', &
' ', &
' + The fpm(1) home page is at https://github.com/fortran-lang/fpm ', &
' + Registered fpm(1) packages are at https://fortran-lang.org/packages ', &
' + The fpm(1) TOML file format is described at ', &
' https://fpm.fortran-lang.org/spec/manifest.html ', &
'']
help_list=[character(len=80) :: &
'NAME ', &
' list(1) - list summary of fpm(1) subcommands ', &
' ', &
'SYNOPSIS ', &
' fpm 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] [--config-file PATH] [-- 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. ', &
' --config-file PATH Custom location of the global config file. ', &
help_text_build_common, &
help_text_compiler, &
help_text_flag, &
' --runner CMD A command to prefix the program execution paths with. ', &
' see "fpm help runner" for further details. ', &
' --list list basenames of candidates instead of running them. Note ', &
' out-of-date candidates will still be rebuilt before being ', &
' listed. ', &
' -- ARGS optional arguments to pass to the program(s). The same ', &
' arguments are passed to all program names specified. ', &
' ', &
help_text_environment, &
' ', &
'EXAMPLES ', &
' fpm(1) - run or display project applications: ', &
' ', &
' fpm run # run a target when only one exists or list targets ', &
' fpm run --list # list basename of all targets, running nothing. ', &
' fpm run "demo*" --list # list target basenames starting with "demo*".', &
' fpm run "psi*" --runner # list target pathnames starting with "psi*".', &
' fpm run --all # run all targets, no matter how many there are. ', &
' ', &
' # run default program built or to be built with the compiler command ', &
' # "f90". If more than one app exists a list displays and target names', &
' # are required. ', &
' fpm run --compiler f90 ', &
' ', &
' # run example programs instead of the application programs. ', &
' fpm run --example "*" ', &
' ', &
' # run a specific program and pass arguments to the command ', &
' fpm run myprog -- -x 10 -y 20 --title "my title line" ', &
' ', &
' # run production version of two applications ', &
' fpm run --target prg1,prg2 --profile release ', &
' ', &
' # install executables in directory (assuming install(1) exists) ', &
' fpm run --runner ''install -b -m 0711 -p -t /usr/local/bin'' ', &
'' ]
help_build=[character(len=80) :: &
'NAME ', &
' build(1) - the fpm(1) subcommand to build a project ', &
' ', &
'SYNOPSIS ', &
' fpm build [--profile PROF] [--features LIST] [--flag FFLAGS] ', &
' [--compiler COMPILER_NAME] [--build-dir DIR] [--list] ', &
' [--tests] [--config-file PATH] [--dump [FILENAME]] ', &
' ', &
' 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 (default: build/). ', &
' ', &
' Non-default pathnames and remote dependencies are used if ', &
' specified in the "fpm.toml" file. ', &
' ', &
'OPTIONS ', &
help_text_build_common,&
help_text_compiler, &
help_text_flag, &
' --list list candidates instead of building or running them. ', &
' all dependencies are downloaded, and the build sequence ', &
' is saved to `/compile_commands.json`. ', &
' --tests build all tests (otherwise only if needed) ', &
' --show-model show the model and exit (do not build) ', &
' --dump [FILENAME] save model representation to file. use JSON format ', &
' if file name is *.json; use TOML format otherwise ', &
' (default file name: model.toml) ', &
' --help print this help and exit ', &
' --version print program version information and exit ', &
' --config-file PATH custom location of the global config file ', &
' ', &
help_text_environment, &
' ', &
'EXAMPLES ', &
' Sample commands: ', &
' ', &
' fpm build # build with debug options ', &
' fpm build --profile release # build with high optimization ', &
' fpm build --features mpi,openmp # build with specific features ', &
' fpm build --profile development # use feature profile from fpm.toml', &
' fpm build --build-dir /tmp/my_build # build to custom directory ', &
'' ]
help_help=[character(len=80) :: &
'NAME ', &
' help(1) - the fpm(1) subcommand to display help ', &
' ', &
'SYNOPSIS ', &
' fpm help [fpm] [new] [build] [run] [test] [help] [version] [manual] ', &
' [runner] ', &
' ', &
'DESCRIPTION ', &
' The "fpm help" command is an alternative to the --help parameter ', &
' on the fpm(1) command and its subcommands. ', &
' ', &
'OPTIONS ', &
' NAME(s) A list of topic names to display. All the subcommands ', &
' have their own page (new, build, run, test, ...). ', &
' ', &
' The special name "manual" displays all the fpm(1) ', &
' built-in documentation. ', &
' ', &
' The default is to display help for the fpm(1) command ', &
' itself. ', &
' ', &
'EXAMPLES ', &
' Sample usage: ', &
' ', &
' fpm help # general fpm(1) command help ', &
' fpm help version # show program version ', &
' fpm help new # display help for "new" subcommand ', &
' fpm help manual # All fpm(1) built-in documentation ', &
' ', &
'' ]
help_new=[character(len=80) :: &
'NAME ', &
' new(1) - the fpm(1) subcommand to initialize a new project ', &
' ', &
'SYNOPSIS ', &
' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]| ', &
' [--full|--bare][--backfill] ', &
' fpm new --help|--version ', &
' ', &
'DESCRIPTION ', &
' "fpm new" creates and populates a new programming project directory. ', &
' ', &
' It ', &
' o creates a directory with the specified name ', &
' o runs the command "git init" in that directory ', &
' o populates the directory with the default project directories ', &
' o adds sample Fortran source files ', &
' ', &
' The default file structure (that will be automatically scanned) is ', &
' ', &
' NAME/ ', &
' fpm.toml ', &
' src/ ', &
' NAME.f90 ', &
' app/ ', &
' main.f90 ', &
' test/ ', &
' check.f90 ', &
' example/ ', &
' demo.f90 ', &
' ', &
' Using this file structure is highly encouraged, particularly for ', &
' small packages primarily intended to be used as dependencies. ', &
' ', &
' If you find this restrictive and need to customize the package ', &
' structure you will find using the --full switch creates a ', &
' heavily annotated manifest file with references to documentation ', &
' to aid in constructing complex package structures. ', &
' ', &
' Remember to update the information in the sample "fpm.toml" ', &
' file with your name and e-mail address. ', &
' ', &
'OPTIONS ', &
' NAME the name of the project directory to create. The name ', &
' must be made of up to 63 ASCII letters, digits, underscores, ', &
' or hyphens, and start with a letter. ', &
' ', &
' The default is to create the src/, app/, and test/ directories. ', &
' If any of the following options are specified then only the ', &
' selected subdirectories are generated: ', &
' ', &
' --lib,--src create directory src/ and a placeholder module ', &
' named "NAME.f90" for use with subcommand "build". ', &
' --app create directory app/ and a placeholder main ', &
' program for use with subcommand "run". ', &
' --test create directory test/ and a placeholder program ', &
' for use with the subcommand "test". Note that sans ', &
' "--lib" it really does not have anything to test. ', &
' --example create directory example/ and a placeholder program ', &
' for use with the subcommand "run --example". ', &
' It is only created by default if "--full is" specified. ', &
' ', &
' So the default is equivalent to ',&
' ', &
' fpm NAME --lib --app --test ', &
' ', &
' --backfill By default the directory must not exist. If this ', &
' option is present the directory may pre-exist and ', &
' only subdirectories and files that do not ', &
' already exist will be created. For example, if you ', &
' previously entered "fpm new myname --lib" entering ', &
' "fpm new myname -full --backfill" will create any missing', &
' app/, example/, and test/ directories and programs. ', &
' ', &
' --full By default a minimal manifest file ("fpm.toml") is ', &
' created that depends on auto-discovery. With this ', &
' option a much more extensive manifest sample is written ', &
' and the example/ directory is created and populated. ', &
' It is designed to facilitate creating projects that ', &
' depend extensively on non-default build options. ', &
' ', &
' --bare A minimal manifest file ("fpm.toml") is created and ', &
' "README.md" file is created but no directories or ', &
' sample Fortran are generated. ', &
' ', &
' --help print this help and exit ', &
' --version print program version information and exit ', &
' ', &
'EXAMPLES ', &
' Sample use ', &
' ', &
' fpm new myproject # create new project directory and seed it ', &
' cd myproject # Enter the new directory ', &
' # and run commands such as ', &
' fpm build ', &
' fpm run # run lone example application program ', &
' fpm test # run example test program(s) ', &
' fpm run --example # run lone example program ', &
' ', &
' fpm new A --full # create example/ and an annotated fpm.toml as well', &
' fpm new A --bare # create no directories ', &
' create any missing files in current directory ', &
' fpm new --full --backfill ', &
'' ]
help_test=[character(len=80) :: &
'NAME ', &
' test(1) - the fpm(1) subcommand to run project tests ', &
' ', &
'SYNOPSIS ', &
' fpm test [[--target] NAME(s)] [--profile PROF] [--features LIST] ', &
' [--flag FFLAGS] [--compiler COMPILER_NAME] [--runner "CMD"] ', &
' [--list] [-- ARGS] [--config-file PATH] ', &
' ', &
' fpm test --help|--version ', &
' ', &
'DESCRIPTION ', &
' Run applications you have built to test your project. ', &
' ', &
'OPTIONS ', &
' --target NAME(s) optional list of specific test names to execute. ', &
' The default is to run all the tests in test/ ', &
' or the tests listed in the "fpm.toml" file. ', &
' ', &
' Basic "globbing" is supported where "?" represents ', &
' any single character and "*" represents any string. ', &
' Note The glob string normally needs quoted to ', &
' protect the special characters from shell expansion.', &
help_text_build_common,&
help_text_compiler, &
help_text_flag, &
' --runner CMD A command to prefix the program execution paths with. ', &
' see "fpm help runner" for further details. ', &
' --list list candidate basenames instead of running them. Note they', &
' will still be built if not currently up to date. ', &
' --config-file PATH Custom location of the global config file. ', &
' -- ARGS optional arguments to pass to the test program(s). ', &
' The same arguments are passed to all test names ', &
' specified. ', &
' ', &
help_text_environment, &
' ', &
'EXAMPLES ', &
'run tests ', &
' ', &
' # run default tests in /test or as specified in "fpm.toml" ', &
' fpm test ', &
' ', &
' # run using compiler command "f90" ', &
' fpm test --compiler f90 ', &
' ', &
' # run a specific test and pass arguments to the command ', &
' fpm test mytest -- -x 10 -y 20 --title "my title line" ', &
' ', &
' fpm test tst1 tst2 --profile release # run release version of tests ', &
' fpm test --features debug,mpi # run tests with specific features ', &
'' ]
help_update=[character(len=80) :: &
'NAME', &
' update(1) - manage project dependencies', &
'', &
'SYNOPSIS', &
' fpm update [--fetch-only] [--clean] [--verbose] [--dump [FILENAME]] [NAME(s)]', &
' [--config-file PATH] ', &
'', &
'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', &
' --config-file PATH Custom location of the global config file', &
' --verbose Show additional printout', &
' --dump [FILENAME] Dump updated dependency tree to file. use JSON format ', &
' if file name is *.json; use TOML format otherwise ', &
' (default file name: fpm_dependencies.toml) ', &
'', &
'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] [--config-file PATH]', &
'', &
'DESCRIPTION', &
' Subcommand to install fpm projects. Running install will export the', &
' current project to the selected prefix, this will by default install all', &
' executables (tests and examples are excluded) which are part of the projects.', &
' Libraries and module files are only installed for projects requiring the', &
' installation of those components in the package manifest.', &
'', &
'OPTIONS', &
' --list list all installable targets for this project,', &
' but do not install any of them', &
help_text_build_common,&
help_text_flag, &
' --no-rebuild do not rebuild project before installation', &
' --test also install test programs', &
' --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)', &
' --testdir DIR subdirectory to place test programs in (default: test)', &
' --config-file PATH custom location of the global config file', &
' --verbose print more information', &
'', &
help_text_environment, &
'', &
'EXAMPLES', &
' 1. Install release version of project:', &
'', &
' fpm install --profile release', &
'', &
' 2. Install the project without rebuilding the executables:', &
'', &
' fpm install --no-rebuild', &
'', &
' 3. Install executables to a custom prefix into the exe directory:', &
'', &
' fpm install --prefix $PWD --bindir exe', &
' 4. Install executables and test programs into the same "exe" directory:', &
'', &
' fpm install --prefix $PWD --test --bindir exe --testdir exe', &
'' ]
help_clean=[character(len=80) :: &
'NAME', &
' clean(1) - delete the build', &
'', &
'SYNOPSIS', &
' fpm clean [--skip|--all]', &
' fpm clean [--test] [--apps] [--examples]', &
'', &
'DESCRIPTION', &
' Prompts the user to confirm deletion of the build. If affirmative,', &
' directories in the build/ directory are deleted, except dependencies.', &
' Use the --registry-cache option to delete the registry cache.', &
' Use target-specific flags to delete only certain build artifacts.', &
'', &
'OPTIONS', &
' --skip Delete the build without prompting but skip dependencies.', &
' --all Delete the build without prompting including dependencies.', &
' --test Delete only test executables.', &
' --apps Delete only application executables.', &
' --examples Delete only example executables.', &
' --config-file PATH Custom location of the global config file.', &
' --registry-cache Delete registry cache.', &
'' ]
help_publish=[character(len=80) :: &
'NAME', &
' publish(1) - publish package to the registry', &
'', &
'SYNOPSIS', &
' fpm publish [--token TOKEN] [--show-package-version] [--show-upload-data]', &
' [--dry-run] [--verbose] [--config-file PATH]', &
'', &
' fpm publish --help|--version', &
'', &
'DESCRIPTION', &
' Follow the steps to create a tarball and upload a package to the registry:', &
'', &
' 1. Register on the website (https://registry-phi.vercel.app/).', &
' 2. Create a namespace. Uploaded packages must be assigned to a unique', &
' namespace to avoid conflicts among packages with similar names. A', &
' namespace can accommodate multiple packages.', &
' 3. Create a token for that namespace. A token is linked to your username', &
' and is used to authenticate you during the upload process. Do not share', &
' the token with others.', &
' 4. Run fpm publish --token TOKEN to upload the package to the registry.', &
' But be aware that the upload is permanent. An uploaded package cannot be', &
' deleted.', &
'', &
' See documentation for more information regarding package upload and usage:', &
'', &
' Package upload:', &
' https://fpm.fortran-lang.org/spec/publish.html', &
'', &
' Package usage:', &
' https://fpm.fortran-lang.org/spec/manifest.html#dependencies-from-a-registry', &
'', &
'OPTIONS', &
' --show-package-version show package version without publishing', &
' --show-upload-data show upload data without publishing', &
' --dry-run perform dry run without publishing', &
' --help print this help and exit', &
' --version print program version information and exit', &
' --config-file PATH custom location of the global config file', &
' --verbose print more information', &
'', &
'EXAMPLES', &
'', &
' fpm publish --show-package-version # show package version without publishing', &
' fpm publish --show-upload-data # show upload data without publishing', &
' fpm publish --token TOKEN --dry-run # perform dry run without publishing', &
' fpm publish --token TOKEN # upload package to the registry', &
'' ]
end subroutine set_help
subroutine get_char_arg(var, arg)
character(len=:), allocatable, intent(out) :: var
character(len=*), intent(in) :: arg
var = sget(arg)
if (len_trim(var) == 0) deallocate(var)
end subroutine get_char_arg
!> Get an environment variable for fpm, this routine ensures that every variable
!> used by fpm is prefixed with FPM_.
function get_fpm_env(env, default) result(val)
character(len=*), intent(in) :: env
character(len=*), intent(in) :: default
character(len=:), allocatable :: val
character(len=*), parameter :: fpm_prefix = "FPM_"
val = get_env(fpm_prefix//env, default)
end function get_fpm_env
!> Build a full runner command (executable + command-line arguments)
function runner_command(cmd) result(run_cmd)
class(fpm_run_settings), intent(in) :: cmd
character(len=:), allocatable :: run_cmd
!> Get executable
if (len_trim(cmd%runner)>0) then
run_cmd = trim(cmd%runner)
else
run_cmd = ''
end if
!> Append command-line arguments
if (len_trim(cmd%runner_args)>0) run_cmd = run_cmd//' '//trim(cmd%runner_args)
end function runner_command
!> Check name in list ID. return 0 if not found
integer function name_ID(cmd,name)
class(fpm_run_settings), intent(in) :: cmd
character(*), intent(in) :: name
integer :: j
!> Default: not found
name_ID = 0
if (.not.allocated(cmd%name)) return
do j=1,size(cmd%name)
if (glob(trim(name),trim(cmd%name(j)))) then
name_ID = j
return
end if
end do
end function name_ID
! Populate build settings from the current CLI/environment
! (after set_args has been called).
subroutine build_settings(self, list, show_model, build_tests, config_file)
class(fpm_build_settings), intent(inout) :: self
logical, intent(in), optional :: list, show_model, build_tests
character(len=*), intent(in), optional :: config_file
character(len=:), allocatable :: comp, ccomp, cxcomp, arch
character(len=:), allocatable :: fflags, cflags, cxxflags, ldflags
character(len=:), allocatable :: prof, cfg, dump, dir
character(len=:), allocatable :: feats
! Read CLI/env values (sget returns what set_args registered, including defaults)
! This is equivalent to check_build_vals
comp = sget('compiler'); if (comp == '') comp = 'gfortran'
fflags = ' ' // sget('flag')
cflags = ' ' // sget('c-flag')
cxxflags = ' ' // sget('cxx-flag')
ldflags = ' ' // sget('link-flag')
prof = sget('profile')
feats = sget('features')
! Set and validate build directory
dir = sget('build-dir')
call validate_build_dir(dir)
ccomp = sget('c-compiler')
cxcomp = sget('cxx-compiler')
arch = sget('archiver')
! Handle --dump default (empty value means use 'fpm_model.toml')
if (specified('dump')) then
dump = sget('dump')
if (dump=='') dump='fpm_model.toml'
else
dump = ''
endif
if (present(config_file)) then
if (len_trim(config_file) > 0) then
cfg = config_file
else
cfg = sget('config-file')
end if
else
cfg = sget('config-file')
end if
! Validate mutually exclusive options
if (specified('profile') .and. specified('features')) then
call fpm_stop(1, 'Error: --profile and --features cannot be used together')
end if
! Parse comma-separated features and profiles
if (specified('features') .and. len_trim(feats) > 0) then
call parse_features(feats, self%features)
else
if (allocated(self%features)) deallocate(self%features)
end if
if (specified('profile') .and. len_trim(prof) > 0) then
self%profile = prof
else
if (allocated(self%profile)) deallocate(self%profile)
end if
! Assign into this (polymorphic) object; allocatable chars auto-allocate
self%prune = .not. lget('no-prune')
self%compiler = comp
self%c_compiler = ccomp
self%cxx_compiler = cxcomp
self%build_dir = dir
self%archiver = arch
self%path_to_config= cfg
self%flag = fflags
self%cflag = cflags
self%cxxflag = cxxflags
self%ldflag = ldflags
self%verbose = lget('verbose')
self%dump = dump
! Optional overrides from caller
if (present(list)) self%list = list
if (present(show_model)) self%show_model = show_model
if (present(build_tests)) self%build_tests = build_tests
end subroutine build_settings
!> Parse comma-separated features string into string_t array
subroutine parse_features(features_str, features_array)
character(len=*), intent(in) :: features_str
type(string_t), allocatable, intent(out) :: features_array(:)
character(len=:), allocatable :: trimmed_features(:)
integer :: i
! Split by comma
call split(features_str, trimmed_features, delimiters=',')
! Validate and clean feature names
if (size(trimmed_features) == 0) then
call fpm_stop(1, 'Error: Empty features list provided')
end if
allocate(features_array(size(trimmed_features)))
do i = 1, size(trimmed_features)
! Trim whitespace
trimmed_features(i) = trim(adjustl(trimmed_features(i)))
! Validate feature name
if (len_trim(trimmed_features(i)) == 0) then
call fpm_stop(1, 'Error: Empty feature name in features list')
end if
! Check for valid feature name (similar to Fortran identifier rules)
if (.not. is_valid_feature_name(trimmed_features(i))) then
call fpm_stop(1, 'Error: Invalid feature name "'//trimmed_features(i)//'"')
end if
features_array(i)%s = trimmed_features(i)
end do
end subroutine parse_features
end module fpm_command_line
fortran-lang-fpm-90bb83a/src/fpm_os.c 0000664 0001750 0001750 00000000743 15145116760 017712 0 ustar alastair alastair #include
#include
/// @brief Determine the absolute, canonicalized path for a given path.
/// @param path
/// @param resolved_path
/// @param maxLength
/// @return
char* c_realpath(char* path, char* resolved_path, int maxLength) {
// Checking macro in C because it doesn't work with gfortran on Windows, even
// when exported manually.
#ifndef _WIN32
return realpath(path, resolved_path);
#else
return _fullpath(resolved_path, path, maxLength);
#endif
}
fortran-lang-fpm-90bb83a/src/fpm.f90 0000664 0001750 0001750 00000120436 15145116760 017367 0 ustar alastair alastair module fpm
use fpm_strings, only: string_t, operator(.in.), glob, join, string_cat, &
lower, str_ends_with, is_fortran_name, str_begins_with_str, &
is_valid_module_name, len_trim
use fpm_backend, only: build_package
use fpm_command_line, only: fpm_build_settings, fpm_new_settings, &
fpm_run_settings, fpm_install_settings, fpm_test_settings, &
fpm_clean_settings
use fpm_dependency, only : new_dependency_tree
use fpm_filesystem, only: is_dir, join_path, list_files, exists, &
basename, filewrite, mkdir, run, os_delete_dir, delete_file
use fpm_model, only: fpm_model_t, srcfile_t, show_model, &
FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, FPM_SCOPE_DEP, &
FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST
use fpm_compiler, only: new_compiler, new_archiver, set_cpp_preprocessor_flags, &
id_intel_classic_nix,id_intel_classic_mac,id_intel_llvm_nix, &
id_intel_llvm_unknown
use fpm_sources, only: add_executable_sources, add_sources_from_dir
use fpm_targets, only: targets_from_sources, build_target_t, build_target_ptr, &
FPM_TARGET_EXECUTABLE, get_library_dirs, filter_executable_targets
use fpm_manifest, only : get_package_data, package_config_t
use fpm_manifest_platform, only: platform_config_t
use fpm_meta, only : resolve_metapackages
use fpm_error, only : error_t, fatal_error, fpm_stop
use fpm_toml, only: name_is_json
use, intrinsic :: iso_fortran_env, only : stdin => input_unit, &
& stdout => output_unit, &
& stderr => error_unit
use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer
use fpm_environment, only: os_is_unix, get_os_type, OS_WINDOWS, OS_MACOS, get_env, set_env, delete_env
use fpm_settings, only: fpm_global_settings, get_global_settings
implicit none
private
public :: cmd_build, cmd_run, cmd_clean
public :: build_model, check_modules_for_duplicates, new_compiler_flags
contains
!> Constructs a valid fpm model from command line settings and the toml manifest.
subroutine build_model(model, settings, package_config, error)
type(fpm_model_t), intent(out) :: model
class(fpm_build_settings), intent(inout) :: settings
type(package_config_t), intent(inout), target :: package_config
type(error_t), allocatable, intent(out) :: error
integer :: i, j
type(package_config_t), allocatable, target :: package, dependency_config, dependency
type(package_config_t), pointer :: manifest
type(platform_config_t), allocatable, target :: target_platform
character(len=:), allocatable :: file_name, lib_dir
logical :: has_cpp
logical :: duplicates_found, auto_exe, auto_example, auto_test
type(string_t) :: include_dir
! Large variables -> safer on heap
allocate(package,dependency_config,dependency,target_platform)
model%package_name = package_config%name
! Set target OS to current OS (may be extended for cross-compilation in the future)
model%target_os = get_os_type()
allocate(model%include_dirs(0))
allocate(model%link_libraries(0))
allocate(model%external_modules(0))
call new_compiler(model%compiler, settings%compiler, settings%c_compiler, &
& settings%cxx_compiler, echo=settings%verbose, verbose=settings%verbose)
call new_archiver(model%archiver, settings%archiver, &
& echo=settings%verbose, verbose=settings%verbose)
if (model%compiler%is_unknown()) then
write(*, '(*(a:,1x))') &
"", "Unknown compiler", model%compiler%fc, "requested!", &
"Defaults for this compiler might be incorrect"
end if
! Extract the target platform for this build
target_platform = model%target_platform()
model%build_dir = settings%build_dir
model%build_prefix = join_path(settings%build_dir, basename(model%compiler%fc))
model%include_tests = settings%build_tests
! Extract the current package configuration request
package = package_config%export_config(target_platform,settings%features,settings%profile, &
settings%verbose,error)
if (allocated(error)) return
! Print enabled features/profile in verbose mode
if (settings%verbose) then
if (allocated(settings%features)) then
if (size(settings%features)>0) print *, '+ features: [', string_cat(settings%features,','),']'
end if
if (allocated(settings%profile)) then
print *, '+ profile: ', settings%profile
end if
end if
! Initialize compiler flags using the feature-enabled package configuration
call new_compiler_flags(model, settings, package)
! Resolve meta-dependencies into the package and the model
! This must happen BEFORE the dependency tree is built, because metapackages
! add dependencies (e.g., stdlib adds stdlib and test-drive as dev-dependencies)
call resolve_metapackages(model,package,settings,error)
if (allocated(error)) return
if (allocated(package%build)) then
model%enforce_module_names = package%build%module_naming
model%module_prefix = package%build%module_prefix
endif
! Create dependencies
call new_dependency_tree(model%deps, cache=join_path(settings%build_dir, "cache.toml"), &
& path_to_config=settings%path_to_config, build_dir=settings%build_dir)
! Build and resolve model dependencies
call model%deps%add(package, error)
if (allocated(error)) return
! Update dependencies where needed
call model%deps%update(error)
if (allocated(error)) return
! Resolve metapackages from dependencies (if any)
! This second call merges metapackage requests from all resolved dependencies
call resolve_metapackages(model,package,settings,error)
if (allocated(error)) return
! build directory should now exist
if (.not.exists(join_path(settings%build_dir, ".gitignore"))) then
call filewrite(join_path(settings%build_dir, ".gitignore"),["*"])
end if
allocate(model%packages(model%deps%ndep))
! The current configuration may not have preprocessing, but some of its features may.
! This means there will be directives that need to be considered even if not currently
! active. Turn preprocessing on even in this case
has_cpp = package_config%has_cpp() .or. package%has_cpp()
do i = 1, model%deps%ndep
associate(dep => model%deps%dep(i))
file_name = join_path(dep%proj_dir, "fpm.toml")
! The main package manifest should not be reloaded, because it may have been
! affected by model dependencies and metapackages
if (i==1) then
manifest => package
else
! Extract this dependency config
call get_package_data(dependency_config, file_name, error, apply_defaults=.true.)
if (allocated(error)) exit
! Adapt it to the current profile/platform
dependency = dependency_config%export_config(target_platform, &
dep%features,dep%profile,verbose=.false.,error=error)
if (allocated(error)) exit
manifest => dependency
end if
model%packages(i)%name = manifest%name
model%packages(i)%features = manifest%fortran
model%packages(i)%version = manifest%version
!> Add this dependency's manifest macros
if (allocated(manifest%preprocess)) then
do j = 1, size(manifest%preprocess)
call model%packages(i)%preprocess%add_config(manifest%preprocess(j))
end do
end if
!> Add this dependency's package-level macros
if (allocated(dep%preprocess)) then
do j = 1, size(dep%preprocess)
call model%packages(i)%preprocess%add_config(dep%preprocess(j))
end do
end if
if (model%packages(i)%preprocess%is_cpp()) has_cpp = .true.
if (.not.allocated(model%packages(i)%sources)) allocate(model%packages(i)%sources(0))
if (allocated(manifest%library)) then
if (allocated(manifest%library%source_dir)) then
lib_dir = join_path(dep%proj_dir, manifest%library%source_dir)
if (is_dir(lib_dir)) then
call add_sources_from_dir(model%packages(i)%sources, lib_dir, FPM_SCOPE_LIB, &
with_f_ext=model%packages(i)%preprocess%suffixes, error=error, &
preprocess=model%packages(i)%preprocess)
if (allocated(error)) exit
end if
end if
if (allocated(manifest%library%include_dir)) then
do j=1,size(manifest%library%include_dir)
include_dir%s = join_path(dep%proj_dir, manifest%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(manifest%build)) then
if (allocated(manifest%build%link)) then
model%link_libraries = [model%link_libraries, manifest%build%link]
end if
if (allocated(manifest%build%external_modules)) then
model%external_modules = [model%external_modules, manifest%build%external_modules]
end if
! Copy naming conventions from this dependency's manifest
model%packages(i)%enforce_module_names = manifest%build%module_naming
model%packages(i)%module_prefix = manifest%build%module_prefix
endif
end associate
end do
if (allocated(error)) return
! Add optional flags
if (has_cpp) call set_cpp_preprocessor_flags(model%compiler%id, model%fortran_compile_flags)
! Add sources from executable directories
if (allocated(package%build)) then
auto_exe = package%build%auto_executables
auto_example = package%build%auto_examples
auto_test = package%build%auto_tests
else
auto_exe = .true.
auto_example = .true.
auto_test = .true.
endif
if (is_dir('app') .and. auto_exe) then
call add_sources_from_dir(model%packages(1)%sources,'app', FPM_SCOPE_APP, &
with_executables=.true., with_f_ext=model%packages(1)%preprocess%suffixes,&
error=error,preprocess=model%packages(1)%preprocess)
if (allocated(error)) then
return
end if
end if
if (is_dir('example') .and. auto_example) then
call add_sources_from_dir(model%packages(1)%sources,'example', FPM_SCOPE_EXAMPLE, &
with_executables=.true., &
with_f_ext=model%packages(1)%preprocess%suffixes,error=error,&
preprocess=model%packages(1)%preprocess)
if (allocated(error)) then
return
end if
end if
if (is_dir('test') .and. auto_test) then
call add_sources_from_dir(model%packages(1)%sources,'test', FPM_SCOPE_TEST, &
with_executables=.true., &
with_f_ext=model%packages(1)%preprocess%suffixes,error=error,&
preprocess=model%packages(1)%preprocess)
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=auto_exe, &
with_f_ext=model%packages(1)%preprocess%suffixes, &
error=error,preprocess=model%packages(1)%preprocess)
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=auto_example, &
with_f_ext=model%packages(1)%preprocess%suffixes, &
error=error,preprocess=model%packages(1)%preprocess)
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=auto_test, &
with_f_ext=model%packages(1)%preprocess%suffixes, &
error=error,preprocess=model%packages(1)%preprocess)
if (allocated(error)) then
return
endif
endif
if (settings%verbose) then
write(*,*)' BUILD_NAME: ',model%build_prefix
write(*,*)' COMPILER: ',model%compiler%fc
write(*,*)' C COMPILER: ',model%compiler%cc
write(*,*)' CXX COMPILER: ',model%compiler%cxx
write(*,*)' COMPILER OPTIONS: ', model%fortran_compile_flags
write(*,*)' C COMPILER OPTIONS: ', model%c_compile_flags
write(*,*)' CXX COMPILER OPTIONS: ', model%cxx_compile_flags
write(*,*)' LINKER OPTIONS: ', model%link_flags
write(*,*)' INCLUDE DIRECTORIES: [', string_cat(model%include_dirs,','),']'
end if
! Check for invalid module names
call check_module_names(model, error)
if (allocated(error)) return
! Check for duplicate modules
duplicates_found = .false.
call check_modules_for_duplicates(model, duplicates_found)
if (duplicates_found) then
call fpm_stop(1,'*build_model*:Error: One or more duplicate module names found.')
end if
end subroutine build_model
!> Helper: safely get string from either CLI or package, with fallback
pure function assemble_flags(cli_flag, package_flag, fallback) result(flags)
character(len=*), optional, intent(in) :: cli_flag, package_flag, fallback
character(len=:), allocatable :: flags
allocate(character(len=0) :: flags)
if (present(cli_flag)) flags = flags // ' ' // trim(cli_flag)
if (present(package_flag)) flags = flags // ' ' // trim(package_flag)
if (present(fallback)) flags = flags // ' ' // trim(fallback)
end function assemble_flags
!> Initialize model compiler flags from CLI settings and package configuration
subroutine new_compiler_flags(model, settings, package)
type(fpm_model_t), intent(inout) :: model
type(fpm_build_settings), intent(in) :: settings
type(package_config_t), intent(in) :: package
logical :: release_request, debug_request, need_defaults
character(len=:), allocatable :: fallback
! Default: "debug" if not requested
release_request = .false.
debug_request = .not.allocated(settings%profile)
if (allocated(settings%profile)) release_request = settings%profile == "release"
if (allocated(settings%profile)) debug_request = settings%profile == "debug"
need_defaults = release_request .or. debug_request
! Backward-compatible: if debug/release requested, but a user-defined profile is not defined,
! apply fpm compiler defaults
if (need_defaults) then
need_defaults = (release_request .and. package%find_profile("release")<=0) &
.or. (debug_request .and. package%find_profile("debug")<=0)
end if
! Fix: Always include compiler default flags for Intel ifx -fPIC issue
if (need_defaults) then
fallback = model%compiler%get_default_flags(release_request)
elseif (any(model%compiler%id==[id_intel_classic_mac, &
id_intel_classic_nix, &
id_intel_llvm_nix, &
id_intel_llvm_unknown])) then
! Intel compilers need -fPIC for shared libraries (except Windows)
fallback = " -fPIC"
else
if (allocated(fallback)) deallocate(fallback) ! trigger .not.present
endif
model%fortran_compile_flags = assemble_flags(settings%flag, package%flags, fallback)
model%c_compile_flags = assemble_flags(settings%cflag, package%c_flags)
model%cxx_compile_flags = assemble_flags(settings%cxxflag, package%cxx_flags)
model%link_flags = assemble_flags(settings%ldflag, package%link_time_flags)
end subroutine new_compiler_flags
! 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(stderr, *) "Warning: Module ",model%packages(k)%sources(l)%modules_provided(m)%s, &
" in ",model%packages(k)%sources(l)%file_name," is a duplicate"
duplicates_found = .true.
else
modules(modi) = model%packages(k)%sources(l)%modules_provided(m)
modi = modi + 1
end if
end do
end if
end do
end do
end subroutine check_modules_for_duplicates
! Check names of all modules in this package and its dependencies
subroutine check_module_names(model, error)
type(fpm_model_t), intent(in) :: model
type(error_t), allocatable, intent(out) :: error
integer :: k,l,m
logical :: valid,errors_found,enforce_this_file
type(string_t) :: package_name,module_name,package_prefix
errors_found = .false.
! 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)
package_name = string_t(model%packages(k)%name)
! Custom prefix is taken from each dependency's manifest
if (model%packages(k)%enforce_module_names) then
package_prefix = model%packages(k)%module_prefix
else
package_prefix = string_t("")
end if
! Warn the user if some of the dependencies have loose naming
if (model%enforce_module_names .and. .not.model%packages(k)%enforce_module_names) then
write(stderr, *) "Warning: Dependency ",package_name%s // &
" does not enforce module naming, but project does. "
end if
do l=1,size(model%packages(k)%sources)
! Module naming is not enforced in test modules
enforce_this_file = model%enforce_module_names .and. &
model%packages(k)%sources(l)%unit_scope/=FPM_SCOPE_TEST
if (allocated(model%packages(k)%sources(l)%modules_provided)) then
do m=1,size(model%packages(k)%sources(l)%modules_provided)
module_name = model%packages(k)%sources(l)%modules_provided(m)
valid = is_valid_module_name(module_name, &
package_name, &
package_prefix, &
enforce_this_file)
if (.not.valid) then
if (enforce_this_file) then
if (len_trim(package_prefix)>0) then
write(stderr, *) "ERROR: Module ",module_name%s, &
" in ",model%packages(k)%sources(l)%file_name, &
" does not match its package name ("//package_name%s// &
") or custom prefix ("//package_prefix%s//")."
else
write(stderr, *) "ERROR: Module ",module_name%s, &
" in ",model%packages(k)%sources(l)%file_name, &
" does not match its package name ("//package_name%s//")."
endif
else
write(stderr, *) "ERROR: Module ",module_name%s, &
" in ",model%packages(k)%sources(l)%file_name, &
" has an invalid Fortran name. "
end if
errors_found = .true.
end if
end do
end if
end do
end do
if (errors_found) then
if (model%enforce_module_names) &
write(stderr, *) " Hint: Try disabling module naming in the manifest: [build] module-naming=false . "
call fatal_error(error,"The package contains invalid module names. "// &
"Naming conventions "//merge('are','not',model%enforce_module_names)// &
" being requested.")
end if
end subroutine check_module_names
subroutine cmd_build(settings)
type(fpm_build_settings), intent(inout) :: settings
type(package_config_t), allocatable :: package
type(fpm_model_t), allocatable :: model
type(build_target_ptr), allocatable :: targets(:)
type(error_t), allocatable :: error
integer :: i
! Large variables -> safer on heap
allocate(package, model)
call get_package_data(package, "fpm.toml", error, apply_defaults=.true.)
if (allocated(error)) then
call fpm_stop(1,'*cmd_build* Package error: '//error%message)
end if
call build_model(model, settings, package, error)
if (allocated(error)) then
call fpm_stop(1,'*cmd_build* Model error: '//error%message)
end if
call targets_from_sources(targets, model, settings%prune, package%library, error)
if (allocated(error)) then
call fpm_stop(1,'*cmd_build* Target error: '//error%message)
end if
!> Dump model to file
if (len_trim(settings%dump)>0) then
call model%dump(trim(settings%dump),error,json=name_is_json(trim(settings%dump)))
if (allocated(error)) call fpm_stop(1,'*cmd_build* Model dump error: '//error%message)
endif
if(settings%list)then
do i=1,size(targets)
write(stderr,*) targets(i)%ptr%output_file
enddo
endif
if (settings%show_model) then
call show_model(model)
else
call build_package(targets,model,verbose=settings%verbose,dry_run=settings%list)
endif
end subroutine cmd_build
subroutine cmd_run(settings,test)
class(fpm_run_settings), intent(inout) :: settings
logical, intent(in) :: test
integer :: i, j, col_width
logical :: found(size(settings%name))
type(error_t), allocatable :: error
type(package_config_t), allocatable :: package
type(fpm_model_t), allocatable :: 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,firsterror
integer, allocatable :: stat(:),target_ID(:)
character(len=:),allocatable :: line,run_cmd,library_path
! Large variables -> safer on heap
allocate(package,model)
call get_package_data(package, "fpm.toml", error, apply_defaults=.true.)
if (allocated(error)) then
call fpm_stop(1, '*cmd_run* Package error: '//error%message)
end if
call build_model(model, settings, package, error)
if (allocated(error)) then
call fpm_stop(1, '*cmd_run* Model error: '//error%message)
end if
call targets_from_sources(targets, model, settings%prune, package%library, error)
if (allocated(error)) then
call fpm_stop(1, '*cmd_run* Targets error: '//error%message)
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(size(targets)),target_ID(size(targets)))
enumerate: do i=1,size(targets)
exe_target => targets(i)%ptr
if (should_be_run(settings,run_scope,exe_target)) then
exe_source => exe_target%dependencies(1)%ptr%source
col_width = max(col_width,len(basename(exe_target%output_file))+2)
! Priority by name ID, or 0 if no name present (run first)
j = settings%name_ID(exe_source%exe_name)
target_ID(i) = j
if (j>0) found(j) = .true.
exe_cmd%s = exe_target%output_file
executables(i) = exe_cmd
else
target_ID(i) = huge(target_ID(i))
endif
end do enumerate
! sort executables by ascending name ID, resize
call sort_executables(target_ID,executables)
! Check if any apps/tests were found
if (col_width < 0) then
if (test) then
call fpm_stop(0,'No tests to run')
else
call fpm_stop(0,'No executables to run')
end if
end if
! Check all names are valid
! or no name and found more than one file
if ( any(.not.found) ) then
line=join(settings%name)
if(line/='.')then ! do not report these special strings
if(any(.not.found))then
write(stderr,'(A)',advance="no")'*cmd_run*:specified names '
do j=1,size(settings%name)
if (.not.found(j)) write(stderr,'(A)',advance="no") '"'//trim(settings%name(j))//'" '
end do
write(stderr,'(A)') 'not found.'
write(stderr,*)
else if(settings%verbose)then
write(stderr,'(A)',advance="yes")'when more than one executable is available'
write(stderr,'(A)',advance="yes")' program names must be specified.'
endif
endif
call compact_list_all()
if(line=='.' .or. line==' ')then ! do not report these special strings
call fpm_stop(0,'')
else
call fpm_stop(1,'')
endif
end if
call build_package(targets,model,verbose=settings%verbose,dry_run=settings%list)
if (settings%list) then
call compact_list()
else
! Save current library path and set a new one that includes the local
! dynamic library folders
library_path = save_library_path()
call set_library_path(model, targets, error)
if (allocated(error)) call fpm_stop(1, '*cmd_run* Run error: '//error%message)
allocate(stat(size(executables)))
do i=1,size(executables)
if (exists(executables(i)%s)) then
! Prepare command line
run_cmd = executables(i)%s
if (settings%runner/=' ') run_cmd = settings%runner_command()//' '//run_cmd
if (allocated(settings%args)) run_cmd = run_cmd//" "//settings%args
! System Integrity Protection will not propagate the .dylib environment variables
! to the child process: add paths manually
if (get_os_type()==OS_MACOS) run_cmd = "env DYLD_LIBRARY_PATH=" // &
get_env("DYLD_LIBRARY_PATH","") // &
" " // run_cmd
call run(run_cmd,echo=settings%verbose,exitstat=stat(i))
else
call fpm_stop(1,'*cmd_run*:'//executables(i)%s//' not found')
end if
end do
if (any(stat /= 0)) then
do i=1,size(stat)
if (stat(i) /= 0) then
write(stderr,'(*(g0:,1x))') ' Execution for object "',basename(executables(i)%s),&
'" returned exit code ',stat(i)
end if
end do
firsterror = findloc(stat/=0,value=.true.,dim=1)
call fpm_stop(stat(firsterror),'*cmd_run*:stopping due to failed executions')
end if
! Restore original library path
call restore_library_path(library_path, error)
if (allocated(error)) call fpm_stop(1, '*cmd_run* Environment error: '//error%message)
end if
contains
subroutine compact_list_all()
integer, parameter :: LINE_WIDTH = 80
integer :: ii, jj, nCol
jj = 1
nCol = LINE_WIDTH/col_width
write(stderr,*) 'Available names:'
do ii=1,size(targets)
exe_target => targets(ii)%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(jj,nCol)==0))) &
& [character(len=col_width) :: basename(exe_target%output_file, suffix=.false.)]
jj = jj + 1
end if
end if
end do
write(stderr,*)
end subroutine compact_list_all
subroutine compact_list()
integer, parameter :: LINE_WIDTH = 80
integer :: ii, jj, nCol
jj = 1
nCol = LINE_WIDTH/col_width
write(stderr,*) 'Matched names:'
do ii=1,size(executables)
write(stderr,'(A)',advance=(merge("yes","no ",modulo(jj,nCol)==0))) &
& [character(len=col_width) :: basename(executables(ii)%s, suffix=.false.)]
jj = jj + 1
end do
write(stderr,*)
end subroutine compact_list
end subroutine cmd_run
subroutine delete_skip(is_unix)
!> delete directories in the build folder, skipping dependencies
logical, intent(in) :: is_unix
character(len=:), allocatable :: dir
type(string_t), allocatable :: files(:)
integer :: i
call list_files('build', files, .false.)
do i = 1, size(files)
if (is_dir(files(i)%s)) then
dir = files(i)%s
if (.not.str_ends_with(dir,'dependencies')) call os_delete_dir(is_unix, dir)
end if
end do
end subroutine delete_skip
!> Delete targets of a specific scope with given description
subroutine delete_targets_by_scope(targets, scope, scope_name, deleted_any)
type(build_target_ptr), intent(in) :: targets(:)
integer, intent(in) :: scope
character(len=*), intent(in) :: scope_name
logical, intent(inout) :: deleted_any
type(string_t), allocatable :: scope_targets(:)
integer :: i
call filter_executable_targets(targets, scope, scope_targets)
if (size(scope_targets) > 0) then
do i = 1, size(scope_targets)
if (exists(scope_targets(i)%s)) then
write(stdout, '(A,A,A,A)') " Deleted ", scope_name, " target: ", basename(scope_targets(i)%s)
call delete_file(scope_targets(i)%s)
deleted_any = .true.
end if
end do
end if
end subroutine delete_targets_by_scope
!> Delete build artifacts for specific target types (test, apps, examples)
subroutine delete_targets(settings, error)
class(fpm_clean_settings), intent(inout) :: settings
type(error_t), allocatable, intent(out) :: error
type(package_config_t), allocatable :: package
type(fpm_model_t), allocatable :: model
type(build_target_ptr), allocatable :: targets(:)
logical :: deleted_any
! Large variables -> safer on heap
allocate(package,model)
! Get package configuration
call get_package_data(package, "fpm.toml", error, apply_defaults=.true.)
if (allocated(error)) return
! Build the model to understand targets
call build_model(model, settings, package, error)
if (allocated(error)) return
! Get the exact targets
call targets_from_sources(targets, model, settings%prune, package%library, error)
if (allocated(error)) return
deleted_any = .false.
! Delete targets by scope using the original approach
if (settings%clean_test) then
call delete_targets_by_scope(targets, FPM_SCOPE_TEST, "test", deleted_any)
end if
if (settings%clean_apps) then
call delete_targets_by_scope(targets, FPM_SCOPE_APP, "app", deleted_any)
end if
if (settings%clean_examples) then
call delete_targets_by_scope(targets, FPM_SCOPE_EXAMPLE, "example", deleted_any)
end if
if (.not. deleted_any) then
write(stdout, '(A)') "No matching build targets found to delete."
end if
end subroutine delete_targets
!> Delete the build directory including or excluding dependencies. Can be used
!> to clear the registry cache.
subroutine cmd_clean(settings)
!> Settings for the clean command.
class(fpm_clean_settings), intent(inout) :: settings
character :: user_response
type(fpm_global_settings) :: global_settings
type(error_t), allocatable :: error
! Clear registry cache
if (settings%registry_cache) then
call get_global_settings(global_settings, error)
if (allocated(error)) return
call os_delete_dir(os_is_unix(), global_settings%registry_settings%cache_path)
end if
! Handle target-specific cleaning
if (any([settings%clean_test, settings%clean_apps, settings%clean_examples])) then
if (.not. is_dir('build')) then
write (stdout, '(A)') "fpm: No build directory found."
return
end if
call delete_targets(settings, error)
if (allocated(error)) then
write(stderr, '(A)') 'Error: ' // error%message
return
end if
return
end if
if (is_dir('build')) then
! Remove the entire build directory
if (settings%clean_all) then
call os_delete_dir(os_is_unix(), 'build'); return
! Remove the build directory but skip dependencies
else if (settings%clean_skip) then
call delete_skip(os_is_unix()); return
end if
! Prompt to remove the build directory but skip dependencies
write(stdout, '(A)', advance='no') "Delete build, excluding dependencies (y/n)? "
read(stdin, '(A1)') user_response
if (lower(user_response) == 'y') call delete_skip(os_is_unix())
else
write (stdout, '(A)') "fpm: No build directory found."
end if
end subroutine cmd_clean
!> Sort executables by namelist ID, and trim unused values
pure subroutine sort_executables(target_ID,executables)
integer, allocatable, intent(inout) :: target_ID(:)
type(string_t), allocatable, intent(inout) :: executables(:)
integer :: i,j,n,used
n = size(target_ID)
used = 0
sort: do i=1,n
do j=i+1,n
if (target_ID(j)0 .and. used Check if an executable should be run
logical function should_be_run(settings,run_scope,exe_target)
class(fpm_run_settings), intent(in) :: settings
integer, intent(in) :: run_scope
type(build_target_t), intent(in) :: exe_target
if (exe_target%is_executable_target(run_scope)) then
associate(exe_source => exe_target%dependencies(1)%ptr%source)
if (exe_source%unit_scope/=run_scope) then
! Other scope
should_be_run = .false.
elseif (size(settings%name) == 0 .or. settings%list) then
! Run all or list all
should_be_run = .true.
else
! Is found in list
should_be_run = settings%name_ID(exe_source%exe_name)>0
end if
end associate
else
!> Invalid target
should_be_run = .false.
endif
end function should_be_run
!> Save the current runtime library path (e.g., PATH or LD_LIBRARY_PATH)
function save_library_path() result(path)
character(len=:), allocatable :: path
select case (get_os_type())
case (OS_WINDOWS)
path = get_env("PATH", default="")
case (OS_MACOS)
path = get_env("DYLD_LIBRARY_PATH", default="")
case default ! UNIX/Linux
path = get_env("LD_LIBRARY_PATH", default="")
end select
end function save_library_path
!> Set the runtime library path for the current process (used for subprocesses)
subroutine set_library_path(model, targets, error)
type(fpm_model_t), intent(in) :: model
type(build_target_ptr), intent(inout), target :: targets(:)
type(error_t), allocatable, intent(out) :: error
type(string_t), allocatable :: shared_lib_dirs(:)
character(len=:), allocatable :: new_path, sep, current
logical :: success
integer :: i
! Get library directories
call get_library_dirs(model, targets, shared_lib_dirs)
! Select platform-specific separator
select case (get_os_type())
case (OS_WINDOWS)
sep = ";"
case default
sep = ":"
end select
! Join the directories into a path string
new_path = ""
do i = 1, size(shared_lib_dirs)
if (i > 1) new_path = new_path // sep
new_path = new_path // shared_lib_dirs(i)%s
end do
! Get current library path
current = save_library_path()
! Set the appropriate environment variable
select case (get_os_type())
case (OS_WINDOWS)
success = set_env("PATH", new_path // sep // current)
case (OS_MACOS)
success = set_env("DYLD_LIBRARY_PATH", new_path // sep // current)
case default ! UNIX/Linux
success = set_env("LD_LIBRARY_PATH", new_path // sep // current)
end select
if (.not.success) call fatal_error(error,"Cannot set library path: "//new_path)
end subroutine set_library_path
!> Restore a previously saved runtime library path
subroutine restore_library_path(saved_path, error)
character(*), intent(in) :: saved_path
type(error_t), allocatable, intent(out) :: error
logical :: success
select case (get_os_type())
case (OS_WINDOWS)
success = set_env("PATH", saved_path)
case (OS_MACOS)
success = set_env("DYLD_LIBRARY_PATH", saved_path)
case default ! UNIX/Linux
success = set_env("LD_LIBRARY_PATH", saved_path)
end select
if (.not.success) call fatal_error(error, "Cannot restore library path: "//saved_path)
end subroutine restore_library_path
end module fpm
fortran-lang-fpm-90bb83a/src/fpm_backend_console.f90 0000664 0001750 0001750 00000006570 15145116760 022562 0 ustar alastair alastair !># Build Backend Console
!> This module provides a lightweight implementation for printing to the console
!> and updating previously-printed console lines. It used by `[[fpm_backend_output]]`
!> for pretty-printing build status and progress.
!>
!> @note The implementation for updating previous lines relies on no other output
!> going to `stdout`/`stderr` except through the `console_t` object provided.
!>
!> @note All write statements to `stdout` are enclosed within OpenMP `critical` regions
!>
module fpm_backend_console
use iso_fortran_env, only: stdout=>output_unit
implicit none
private
public :: console_t
public :: LINE_RESET
public :: COLOR_RED, COLOR_GREEN, COLOR_YELLOW, COLOR_RESET
character(len=*), parameter :: ESC = char(27)
!> Escape code for erasing current line
character(len=*), parameter :: LINE_RESET = ESC//"[2K"//ESC//"[1G"
!> Escape code for moving up one line
character(len=*), parameter :: LINE_UP = ESC//"[1A"
!> Escape code for moving down one line
character(len=*), parameter :: LINE_DOWN = ESC//"[1B"
!> Escape code for red foreground color
character(len=*), parameter :: COLOR_RED = ESC//"[31m"
!> Escape code for green foreground color
character(len=*), parameter :: COLOR_GREEN = ESC//"[32m"
!> Escape code for yellow foreground color
character(len=*), parameter :: COLOR_YELLOW = ESC//"[93m"
!> Escape code to reset foreground color
character(len=*), parameter :: COLOR_RESET = ESC//"[0m"
!> Console object
type console_t
!> Number of lines printed
integer :: n_line = 1
contains
!> Write a single line to the console
procedure :: write_line => console_write_line
!> Update a previously-written console line
procedure :: update_line => console_update_line
end type console_t
contains
!> Write a single line to the standard output
subroutine console_write_line(console,str,line,advance)
!> Console object
class(console_t), intent(inout) :: console
!> String to write
character(*), intent(in) :: str
!> Integer needed to later update console line
integer, intent(out), optional :: line
!> Advancing output (print newline?)
logical, intent(in), optional :: advance
character(3) :: adv
adv = "yes"
if (present(advance)) then
if (.not.advance) then
adv = "no"
end if
end if
!$omp critical
if (present(line)) then
line = console%n_line
end if
write(stdout,'(A)',advance=trim(adv)) LINE_RESET//str
if (adv=="yes") then
console%n_line = console%n_line + 1
end if
!$omp end critical
end subroutine console_write_line
!> Overwrite a previously-written line in standard output
subroutine console_update_line(console,line_no,str)
!> Console object
class(console_t), intent(in) :: console
!> Integer output from `[[console_write_line]]`
integer, intent(in) :: line_no
!> New string to overwrite line
character(*), intent(in) :: str
integer :: n
!$omp critical
n = console%n_line - line_no
! Step back to line
write(stdout,'(A)',advance="no") repeat(LINE_UP,n)//LINE_RESET
write(stdout,'(A)',advance="no") str
! Step forward to end
write(stdout,'(A)',advance="no") repeat(LINE_DOWN,n)//LINE_RESET
!$omp end critical
end subroutine console_update_line
end module fpm_backend_console fortran-lang-fpm-90bb83a/src/fpm_compiler.F90 0000664 0001750 0001750 00000210244 15145116760 021216 0 ustar alastair alastair !># 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-dir -I -fopenmp X
! AMD flang amdflang amdclang -module-dir -I -fopenmp X
! LFortran lfortran --- -J -I --openmp 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,intrinsic :: iso_fortran_env, only: stderr=>error_unit
use fpm_environment, only: &
get_os_type, &
OS_LINUX, &
OS_MACOS, &
OS_WINDOWS, &
OS_CYGWIN, &
OS_SOLARIS, &
OS_FREEBSD, &
OS_OPENBSD, &
OS_UNKNOWN, &
library_filename
use fpm_filesystem, only: join_path, basename, get_temp_filename, delete_file, unix_path, &
& getline, run
use fpm_strings, only: split, string_cat, string_t, str_ends_with, str_begins_with_str, &
& string_array_contains, lower, add_strings
use fpm_error, only: error_t, fatal_error, fpm_stop
use tomlf, only: toml_table
use fpm_toml, only: serializable_t, set_string, set_value, toml_stat, get_value
use fpm_compile_commands, only: compile_command_t, compile_command_table_t
use fpm_versioning, only: version_t
use shlex_module, only: sh_split => split, ms_split, quote => ms_quote
implicit none
public :: compiler_t, new_compiler, archiver_t, new_archiver, get_macros
public :: append_clean_flags, append_clean_flags_array
public :: debug
public :: id_gcc,id_all
public :: match_compiler_type, compiler_id_name, validate_compiler_name, is_cxx_gnu_based
enum, bind(C)
enumerator :: &
id_all = -1, &
id_unknown, &
id_gcc, &
id_f95, &
id_caf, &
id_intel_classic_nix, &
id_intel_classic_mac, &
id_intel_classic_windows, &
id_intel_llvm_nix, &
id_intel_llvm_windows, &
id_intel_llvm_unknown, &
id_pgi, &
id_nvhpc, &
id_nag, &
id_flang_classic, &
id_flang, &
id_amdflang, &
id_f18, &
id_ibmxl, &
id_cray, &
id_lahey, &
id_lfortran
end enum
integer, parameter :: compiler_enum = kind(id_unknown)
!> Definition of compiler object
type, extends(serializable_t) :: compiler_t
!> Identifier of the compiler
integer(compiler_enum) :: id = id_unknown
!> Path to the Fortran compiler
character(len=:), allocatable :: fc
!> Path to the C compiler
character(len=:), allocatable :: cc
!> Path to the C++ compiler
character(len=:), allocatable :: cxx
!> Print all commands
logical :: echo = .true.
!> Verbose output of command
logical :: verbose = .true.
contains
!> Get default compiler flags
procedure :: get_default_flags
!> Get flag for module output directories
procedure :: get_module_flag
!> Get flag for include directories
procedure :: get_include_flag
!> Get feature flag
procedure :: get_feature_flag
!> Get flags for the main linking command
procedure :: get_main_flags
!> Get library export flags
procedure :: get_export_flags
!> Get library install name flags
procedure :: get_install_name_flags
!> Generate header padding flags for macOS executables
procedure :: get_headerpad_flags
!> Compile a Fortran object
procedure :: compile_fortran
!> Compile a C object
procedure :: compile_c
!> Compile a CPP object
procedure :: compile_cpp
!> Link a shared library
procedure :: link_shared
!> Link executable
procedure :: link => link_executable
!> Check whether compiler is recognized
procedure :: is_unknown
!> Check whether this is an Intel compiler
procedure :: is_intel
!> Check whether this is a GNU compiler
procedure :: is_gnu
!> Enumerate libraries, based on compiler and platform
procedure :: enumerate_libraries
!> Serialization interface
procedure :: serializable_is_same => compiler_is_same
procedure :: dump_to_toml => compiler_dump
procedure :: load_from_toml => compiler_load
!> Fortran feature support
procedure :: check_fortran_source_runs
procedure :: check_flags_supported
procedure :: with_xdp
procedure :: with_qp
!> C feature support
procedure :: check_c_source_runs
procedure :: check_c_flags_supported
!> C++ feature support
procedure :: check_cxx_source_runs
procedure :: check_cxx_flags_supported
!> Return compiler name
procedure :: name => compiler_name
end type compiler_t
!> Definition of archiver object
type, extends(serializable_t) :: archiver_t
!> Path to archiver
character(len=:), allocatable :: ar
!> Use response files to pass arguments
logical :: use_response_file = .false.
!> Print all command
logical :: echo = .true.
!> Verbose output of command
logical :: verbose = .true.
contains
!> Create static archive
procedure :: make_archive
!> Serialization interface
procedure :: serializable_is_same => ar_is_same
procedure :: dump_to_toml
procedure :: load_from_toml
end type archiver_t
!> Create debug printout
interface debug
module procedure :: debug_compiler
module procedure :: debug_archiver
end interface debug
character(*), parameter :: &
flag_gnu_coarray = " -fcoarray=single", &
flag_gnu_backtrace = " -fbacktrace", &
flag_gnu_opt = " -O3 -funroll-loops", &
flag_gnu_debug = " -g", &
flag_gnu_pic = " -fPIC", &
flag_gnu_warn = " -Wall -Wextra -Wno-external-argument-mismatch", & ! do not check interfaces due to gcc 15.0-15.1 bug
flag_gnu_check = " -fcheck=bounds -fcheck=array-temps", &
flag_gnu_limit = " -fmax-errors=1", &
flag_gnu_external = " -Wimplicit-interface", &
flag_gnu_openmp = " -fopenmp", &
flag_gnu_no_implicit_typing = " -fimplicit-none", &
flag_gnu_no_implicit_external = " -Werror=implicit-interface", &
flag_gnu_free_form = " -ffree-form", &
flag_gnu_fixed_form = " -ffixed-form"
character(*), parameter :: &
flag_pgi_backslash = " -Mbackslash", &
flag_pgi_traceback = " -traceback", &
flag_pgi_debug = " -g", &
flag_pgi_check = " -Mbounds -Mchkptr -Mchkstk", &
flag_pgi_warn = " -Minform=inform", &
flag_pgi_openmp = " -mp", &
flag_pgi_free_form = " -Mfree", &
flag_pgi_fixed_form = " -Mfixed"
character(*), parameter :: &
flag_ibmxl_backslash = " -qnoescape"
character(*), parameter :: &
flag_intel_backtrace = " -traceback", &
flag_intel_warn = " -warn all", &
flag_intel_check = " -check all", &
flag_intel_debug = " -O0 -g", &
flag_intel_opt = " -O3", &
flag_intel_fp = " -fp-model precise -pc64", &
flag_intel_align = " -align all", &
flag_intel_limit = " -error-limit 1", &
flag_intel_pthread = " -reentrancy threaded", &
flag_intel_nogen = " -nogen-interfaces", &
flag_intel_byterecl = " -assume byterecl", &
flag_intel_openmp = " -qopenmp", &
flag_intel_free_form = " -free", &
flag_intel_fixed_form = " -fixed", &
flag_intel_standard_compliance = " -standard-semantics", &
flag_intel_unknown_cmd_err = " -diag-error 10006"
character(*), parameter :: &
flag_intel_llvm_check = " -check all,nouninit"
character(*), parameter :: &
flag_intel_backtrace_win = " /traceback", &
flag_intel_warn_win = " /warn:all", &
flag_intel_check_win = " /check:all", &
flag_intel_debug_win = " /Od /Z7", &
flag_intel_opt_win = " /O3", &
flag_intel_fp_win = " /fp:precise", &
flag_intel_align_win = " /align:all", &
flag_intel_limit_win = " /error-limit:1", &
flag_intel_pthread_win = " /reentrancy:threaded", &
flag_intel_nogen_win = " /nogen-interfaces", &
flag_intel_byterecl_win = " /assume:byterecl", &
flag_intel_openmp_win = " /Qopenmp", &
flag_intel_free_form_win = " /free", &
flag_intel_fixed_form_win = " /fixed", &
flag_intel_standard_compliance_win = " /standard-semantics", &
flag_intel_unknown_cmd_err_win = " /Qdiag-error:10006"
character(*), parameter :: &
flag_nag_coarray = " -coarray=single", &
flag_nag_pic = " -PIC", &
flag_nag_check = " -C", &
flag_nag_debug = " -g -O0", &
flag_nag_opt = " -O4", &
flag_nag_backtrace = " -gline", &
flag_nag_openmp = " -openmp", &
flag_nag_free_form = " -free", &
flag_nag_fixed_form = " -fixed", &
flag_nag_no_implicit_typing = " -u"
character(*), parameter :: &
flag_lfortran_opt = " --fast", &
flag_lfortran_openmp = " --openmp", &
flag_lfortran_implicit_typing = " --implicit-typing", &
flag_lfortran_implicit_external = " --implicit-interface", &
flag_lfortran_fixed_form = " --fixed-form"
character(*), parameter :: &
flag_cray_no_implicit_typing = " -dl", &
flag_cray_implicit_typing = " -el", &
flag_cray_fixed_form = " -ffixed", &
flag_cray_free_form = " -ffree"
character(*), parameter :: &
flag_flang_openmp = " -fopenmp", &
flag_flang_debug = " -g", &
flag_flang_opt = " -O3", &
flag_flang_pic = " -fPIC", &
flag_flang_free_form = " -ffree-form", &
flag_flang_fixed_form = " -ffixed-form", &
flag_flang_no_implicit_typing = " -fimplicit-none"
contains
function get_default_flags(self, release) result(flags)
class(compiler_t), intent(in) :: self
logical, intent(in) :: release
character(len=:), allocatable :: flags
character(len=:), allocatable :: pic_flag
if (release) then
call get_release_compile_flags(self%id, flags)
else
call get_debug_compile_flags(self%id, flags)
end if
! Append position-independent code (PIC) flag, that is necessary
! building shared libraries
select case (self%id)
case (id_gcc, id_f95, id_caf, id_flang_classic, id_amdflang, id_f18, id_lfortran, &
id_intel_classic_nix, id_intel_classic_mac, id_intel_llvm_nix, &
id_intel_llvm_unknown, id_pgi, id_nvhpc, id_nag, id_cray, id_ibmxl)
pic_flag = " -fPIC"
case (id_flang)
! LLVM Flang doesn't support -fPIC on Windows MSVC target
if (get_os_type() == OS_WINDOWS) then
pic_flag = ""
else
pic_flag = " -fPIC"
end if
case (id_intel_classic_windows, id_intel_llvm_windows)
pic_flag = "" ! Windows does not use -fPIC
case default
pic_flag = " -fPIC" ! Conservative fallback
end select
flags = flags // pic_flag
end function get_default_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 = &
flag_gnu_opt//&
flag_gnu_external//&
flag_gnu_limit
case(id_gcc)
flags = &
flag_gnu_opt//&
flag_gnu_external//&
flag_gnu_limit//&
flag_gnu_coarray
case(id_f95)
flags = &
flag_gnu_opt//&
flag_gnu_external//&
flag_gnu_limit
case(id_nvhpc)
flags = &
flag_pgi_backslash
case(id_ibmxl)
flags = &
flag_ibmxl_backslash
case(id_intel_classic_nix)
flags = &
flag_intel_opt//&
flag_intel_fp//&
flag_intel_align//&
flag_intel_limit//&
flag_intel_pthread//&
flag_intel_nogen//&
flag_intel_byterecl
case(id_intel_classic_mac)
flags = &
flag_intel_opt//&
flag_intel_fp//&
flag_intel_align//&
flag_intel_limit//&
flag_intel_pthread//&
flag_intel_nogen//&
flag_intel_byterecl
case(id_intel_classic_windows)
flags = &
flag_intel_opt_win//&
flag_intel_fp_win//&
flag_intel_align_win//&
flag_intel_limit_win//&
flag_intel_pthread_win//&
flag_intel_nogen_win//&
flag_intel_byterecl_win
case(id_intel_llvm_nix)
flags = &
flag_intel_opt//&
flag_intel_fp//&
flag_intel_align//&
flag_intel_limit//&
flag_intel_pthread//&
flag_intel_nogen//&
flag_intel_byterecl
case(id_intel_llvm_windows)
flags = &
flag_intel_opt_win//&
flag_intel_fp_win//&
flag_intel_align_win//&
flag_intel_limit_win//&
flag_intel_pthread_win//&
flag_intel_nogen_win//&
flag_intel_byterecl_win
case(id_nag)
flags = &
flag_nag_opt//&
flag_nag_coarray
case(id_lfortran)
flags = &
flag_lfortran_opt
case(id_flang)
flags = &
flag_flang_opt
case(id_amdflang)
flags = &
flag_flang_opt
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 = &
flag_gnu_warn//&
flag_gnu_limit//&
flag_gnu_debug//&
flag_gnu_check//&
flag_gnu_backtrace
case(id_gcc)
flags = &
flag_gnu_warn//&
flag_gnu_limit//&
flag_gnu_debug//&
flag_gnu_check//&
flag_gnu_backtrace//&
flag_gnu_coarray
case(id_f95)
flags = &
flag_gnu_warn//&
flag_gnu_limit//&
flag_gnu_debug//&
flag_gnu_check//&
' -Wno-maybe-uninitialized -Wno-uninitialized'//&
flag_gnu_backtrace
case(id_nvhpc)
flags = &
flag_pgi_warn//&
flag_pgi_backslash//&
flag_pgi_check//&
flag_pgi_traceback
case(id_ibmxl)
flags = &
flag_ibmxl_backslash
case(id_intel_classic_nix)
flags = &
flag_intel_warn//&
flag_intel_check//&
flag_intel_limit//&
flag_intel_debug//&
flag_intel_byterecl//&
flag_intel_backtrace
case(id_intel_classic_mac)
flags = &
flag_intel_warn//&
flag_intel_check//&
flag_intel_limit//&
flag_intel_debug//&
flag_intel_byterecl//&
flag_intel_backtrace
case(id_intel_classic_windows)
flags = &
flag_intel_warn_win//&
flag_intel_check_win//&
flag_intel_limit_win//&
flag_intel_debug_win//&
flag_intel_byterecl_win//&
flag_intel_backtrace_win
case(id_intel_llvm_nix)
flags = &
flag_intel_unknown_cmd_err//&
flag_intel_llvm_check//&
flag_intel_limit//&
flag_intel_debug//&
flag_intel_byterecl//&
flag_intel_backtrace
case(id_intel_llvm_windows)
flags = &
flag_intel_unknown_cmd_err_win//&
flag_intel_check_win//&
flag_intel_limit_win//&
flag_intel_debug_win//&
flag_intel_byterecl_win
case(id_nag)
flags = &
flag_nag_debug//&
flag_nag_check//&
flag_nag_backtrace//&
flag_nag_coarray
case(id_lfortran)
flags = ""
case(id_flang)
flags = &
flag_flang_debug
case(id_amdflang)
flags = &
flag_flang_debug
end select
end subroutine get_debug_compile_flags
pure subroutine set_cpp_preprocessor_flags(id, flags)
integer(compiler_enum), intent(in) :: id
character(len=:), allocatable, intent(inout) :: flags
character(len=:), allocatable :: flag_cpp_preprocessor
!> Modify the flag_cpp_preprocessor on the basis of the compiler.
select case(id)
case default
flag_cpp_preprocessor = ""
case(id_caf, id_gcc, id_f95, id_nvhpc, id_flang, id_amdflang)
flag_cpp_preprocessor = "-cpp"
case(id_intel_classic_windows, id_intel_llvm_windows)
flag_cpp_preprocessor = "/fpp"
case(id_intel_classic_nix, id_intel_classic_mac, id_intel_llvm_nix, id_nag)
flag_cpp_preprocessor = "-fpp"
case(id_lfortran)
flag_cpp_preprocessor = "--cpp"
end select
flags = flag_cpp_preprocessor// flags
end subroutine set_cpp_preprocessor_flags
!> This function will parse and read the macros list and
!> return them as defined flags.
function get_macros(id, macros_list, version) result(macros)
integer(compiler_enum), intent(in) :: id
type(version_t), optional, intent(in) :: version
type(string_t), allocatable, intent(in) :: macros_list(:)
character(len=:), allocatable :: macros
character(len=:), allocatable :: macro_definition_symbol
character(:), allocatable :: valued_macros(:)
integer :: i
if (.not.allocated(macros_list)) then
macros = ""
return
end if
!> Set macro defintion symbol on the basis of compiler used
select case(id)
case default
macro_definition_symbol = " -D"
case (id_intel_classic_windows, id_intel_llvm_windows)
macro_definition_symbol = " /D"
end select
!> Check if macros are not allocated.
if (.not.allocated(macros)) then
macros=""
end if
do i = 1, size(macros_list)
!> Split the macro name and value.
call split(macros_list(i)%s, valued_macros, delimiters="=")
!> Replace {version} placeholder with the actual version string
if (size(valued_macros) > 1) then
!> Check if the value of macro starts with '{' character.
if (str_begins_with_str(trim(valued_macros(size(valued_macros))), "{")) then
!> Check if the value of macro ends with '}' character.
if (str_ends_with(trim(valued_macros(size(valued_macros))), "}")) then
!> Check if the string contains "version" as substring.
if (index(valued_macros(size(valued_macros)), "version") /= 0) then
!> These conditions are placed in order to ensure proper spacing between the macros.
if (present(version)) then
macros = macros//macro_definition_symbol//trim(valued_macros(1))//'='//version%s()
cycle
else
call fpm_stop(1,'Internal error: cannot expand {version} macro in '//macros_list(i)%s)
endif
end if
end if
end if
end if
macros = macros//macro_definition_symbol//macros_list(i)%s
end do
end function get_macros
function get_include_flag(self, path) result(flags)
class(compiler_t), intent(in) :: self
character(len=*), intent(in) :: path
character(len=:), allocatable :: flags
select case(self%id)
case default
flags = "-I "//path
case(id_caf, id_gcc, id_f95, id_cray, id_nvhpc, id_pgi, &
& id_flang_classic, id_flang, id_amdflang, id_f18, &
& id_intel_classic_nix, id_intel_classic_mac, &
& id_intel_llvm_nix, id_lahey, id_nag, id_ibmxl, &
& id_lfortran)
flags = "-I "//path
case(id_intel_classic_windows, id_intel_llvm_windows)
flags = "/I"//path
end select
end function get_include_flag
function get_module_flag(self, path) result(flags)
class(compiler_t), intent(in) :: self
character(len=*), intent(in) :: path
character(len=:), allocatable :: flags
select case(self%id)
case default
flags = "-module "//path
case(id_caf, id_gcc, id_f95, id_cray, id_lfortran)
flags = "-J "//path
case(id_nvhpc, id_pgi, id_flang_classic)
flags = "-module "//path
case(id_flang, id_f18, id_amdflang)
flags = "-module-dir "//path
case(id_intel_classic_nix, id_intel_classic_mac, &
& id_intel_llvm_nix)
flags = "-module "//path
case(id_intel_classic_windows, id_intel_llvm_windows)
flags = "/module:"//path
case(id_lahey)
flags = "-M "//path
case(id_nag)
flags = "-mdir "//path
case(id_ibmxl)
flags = "-qmoddir "//path
end select
end function get_module_flag
function get_shared_flag(self) result(shared_flag)
class(compiler_t), intent(in) :: self
character(len=:), allocatable :: shared_flag
select case (self%id)
case default
shared_flag = "-shared"
case (id_gcc, id_f95, id_flang, id_amdflang, id_flang_classic, id_lfortran)
shared_flag = "-shared"
case (id_intel_classic_nix, id_intel_llvm_nix, id_pgi, id_nvhpc)
shared_flag = "-shared"
case (id_intel_classic_windows, id_intel_llvm_windows)
shared_flag = "/DLL"
case (id_nag)
shared_flag = "-Wl,-shared"
case (id_ibmxl)
shared_flag = "-qmkshrobj"
case (id_cray, id_lahey)
shared_flag = "" ! Needs special handling
end select
end function get_shared_flag
function get_feature_flag(self, feature) result(flags)
class(compiler_t), intent(in) :: self
character(len=*), intent(in) :: feature
character(len=:), allocatable :: flags
flags = ""
select case(feature)
case("no-implicit-typing")
select case(self%id)
case(id_caf, id_gcc, id_f95)
flags = flag_gnu_no_implicit_typing
case(id_nag)
flags = flag_nag_no_implicit_typing
case(id_cray)
flags = flag_cray_no_implicit_typing
case(id_flang)
flags = flag_flang_no_implicit_typing
case(id_amdflang)
flags = flag_flang_no_implicit_typing
end select
case("implicit-typing")
select case(self%id)
case(id_cray)
flags = flag_cray_implicit_typing
case(id_lfortran)
flags = flag_lfortran_implicit_typing
end select
case("no-implicit-external")
select case(self%id)
case(id_caf, id_gcc, id_f95)
flags = flag_gnu_no_implicit_external
end select
case("implicit-external")
select case(self%id)
case(id_lfortran)
flags = flag_lfortran_implicit_external
end select
case("free-form")
select case(self%id)
case(id_caf, id_gcc, id_f95)
flags = flag_gnu_free_form
case(id_pgi, id_nvhpc, id_flang_classic)
flags = flag_pgi_free_form
case(id_nag)
flags = flag_nag_free_form
case(id_intel_classic_nix, id_intel_classic_mac, id_intel_llvm_nix, &
& id_intel_llvm_unknown)
flags = flag_intel_free_form
case(id_intel_classic_windows, id_intel_llvm_windows)
flags = flag_intel_free_form_win
case(id_cray)
flags = flag_cray_free_form
case(id_flang)
flags = flag_flang_free_form
case(id_amdflang)
flags = flag_flang_free_form
end select
case("fixed-form")
select case(self%id)
case(id_caf, id_gcc, id_f95)
flags = flag_gnu_fixed_form
case(id_pgi, id_nvhpc, id_flang_classic)
flags = flag_pgi_fixed_form
case(id_nag)
flags = flag_nag_fixed_form
case(id_intel_classic_nix, id_intel_classic_mac, id_intel_llvm_nix, &
& id_intel_llvm_unknown)
flags = flag_intel_fixed_form
case(id_intel_classic_windows, id_intel_llvm_windows)
flags = flag_intel_fixed_form_win
case(id_cray)
flags = flag_cray_fixed_form
case(id_lfortran)
flags = flag_lfortran_fixed_form
case(id_flang)
flags = flag_flang_fixed_form
case(id_amdflang)
flags = flag_flang_fixed_form
end select
case("default-form")
continue
case default
error stop "Unknown feature '"//feature//"'"
end select
end function get_feature_flag
!> Get special flags for the main linker
subroutine get_main_flags(self, language, flags)
class(compiler_t), intent(in) :: self
character(len=*), intent(in) :: language
character(len=:), allocatable, intent(out) :: flags
flags = ""
select case(language)
case("fortran")
flags = ""
case("c")
! If the main program is on a C/C++ source, the Intel Fortran compiler requires option
! -nofor-main to avoid "duplicate main" errors.
! https://stackoverflow.com/questions/36221612/p3dfft-compilation-ifort-compiler-error-multiple-definiton-of-main
select case(self%id)
case(id_intel_classic_nix, id_intel_classic_mac, id_intel_llvm_nix)
flags = '-nofor-main'
case(id_intel_classic_windows,id_intel_llvm_windows)
flags = '/nofor-main'
case (id_pgi,id_nvhpc)
flags = '-Mnomain'
end select
case("c++","cpp","cxx")
select case(self%id)
case(id_intel_classic_nix, id_intel_classic_mac, id_intel_llvm_nix)
flags = '-nofor-main'
case(id_intel_classic_windows,id_intel_llvm_windows)
flags = '/nofor-main'
case (id_pgi,id_nvhpc)
flags = '-Mnomain'
end select
case default
error stop "Unknown language '"//language//'", try "fortran", "c", "c++"'
end select
end subroutine get_main_flags
subroutine get_default_c_compiler(f_compiler, c_compiler)
character(len=*), intent(in) :: f_compiler
character(len=:), allocatable, intent(out) :: c_compiler
integer(compiler_enum) :: id
id = get_compiler_id(f_compiler)
select case(id)
case(id_intel_classic_nix, id_intel_classic_mac, id_intel_classic_windows)
c_compiler = 'icc'
case(id_intel_llvm_nix,id_intel_llvm_windows)
c_compiler = 'icx'
case(id_flang_classic, id_flang, id_f18 )
c_compiler='clang'
case(id_ibmxl)
c_compiler='xlc'
case(id_lfortran)
c_compiler = 'cc'
case(id_gcc)
c_compiler = 'gcc'
case(id_amdflang)
c_compiler = 'amdclang'
case default
! Fall-back to using Fortran compiler
c_compiler = f_compiler
end select
end subroutine get_default_c_compiler
!> Get C++ Compiler.
subroutine get_default_cxx_compiler(f_compiler, cxx_compiler)
character(len=*), intent(in) :: f_compiler
character(len=:), allocatable, intent(out) :: cxx_compiler
integer(compiler_enum) :: id
id = get_compiler_id(f_compiler)
select case(id)
case(id_intel_classic_nix, id_intel_classic_mac, id_intel_classic_windows)
cxx_compiler = 'icpc'
case(id_intel_llvm_nix,id_intel_llvm_windows)
cxx_compiler = 'icpx'
case(id_flang_classic, id_flang, id_f18)
cxx_compiler='clang++'
case(id_amdflang)
cxx_compiler='amdclang++'
case(id_ibmxl)
cxx_compiler='xlc++'
case(id_lfortran)
cxx_compiler = 'cc'
case(id_gcc)
cxx_compiler = 'g++'
case default
! Fall-back to using Fortran compiler
cxx_compiler = f_compiler
end select
end subroutine get_default_cxx_compiler
!> Check if C++ compiler is GNU-based by checking its version output
function is_cxx_gnu_based(self) result(is_gnu)
class(compiler_t), intent(in) :: self
logical :: is_gnu
character(len=:), allocatable :: output_file, version_output
integer :: stat, io
is_gnu = .false.
if (.not.allocated(self%cxx)) return
if (len_trim(self%cxx)<=0) return
! Get temporary file for compiler version output
output_file = get_temp_filename()
! Run compiler with --version to get version info
call run(self%cxx//" --version > "//output_file//" 2>&1", &
echo=.false., exitstat=stat)
if (stat == 0) then
! Read the version output
open(file=output_file, newunit=io, iostat=stat)
if (stat == 0) then
call getline(io, version_output, stat)
close(io, iostat=stat)
! Check if output contains GNU indicators
if (allocated(version_output)) then
is_gnu = index(version_output, 'gcc') > 0 .or. &
index(version_output, 'GCC') > 0 .or. &
index(version_output, 'GNU') > 0 .or. &
index(version_output, 'Free Software Foundation') > 0
end if
end if
end if
! Clean up temporary file
call run("rm -f "//output_file, echo=.false., exitstat=stat)
end function is_cxx_gnu_based
function get_compiler_id(compiler) result(id)
character(len=*), intent(in) :: compiler
integer(kind=compiler_enum) :: id
character(len=:), allocatable :: full_command, full_command_parts(:), command, output
integer :: stat, io
! Check whether we are dealing with an MPI compiler wrapper first
if (check_compiler(compiler, "mpifort") &
& .or. check_compiler(compiler, "mpif90") &
& .or. check_compiler(compiler, "mpif77")) then
output = get_temp_filename()
call run(compiler//" -show > "//output//" 2>&1", &
& echo=.false., exitstat=stat)
if (stat == 0) then
open(file=output, newunit=io, iostat=stat)
if (stat == 0) call getline(io, full_command, stat)
close(io, iostat=stat)
! If we get a command from the wrapper, we will try to identify it
call split(full_command, full_command_parts, delimiters=' ')
if(size(full_command_parts) > 0)then
command = trim(full_command_parts(1))
endif
if (allocated(command)) then
id = match_compiler_type(command)
if (id /= id_unknown) return
end if
end if
end if
id = match_compiler_type(compiler)
end function get_compiler_id
function match_compiler_type(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
select case (get_os_type())
case default
id = id_intel_classic_nix
case (OS_MACOS)
id = id_intel_classic_mac
case (OS_WINDOWS, OS_CYGWIN)
id = id_intel_classic_windows
end select
return
end if
if (check_compiler(compiler, "ifx")) then
select case (get_os_type())
case default
id = id_intel_llvm_nix
case (OS_WINDOWS, OS_CYGWIN)
id = id_intel_llvm_windows
end select
return
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-classic")) then
id = id_flang_classic
return
end if
if (check_compiler(compiler, "flang-new") .or. check_compiler(compiler, "flang")) then
id = id_flang
return
end if
if (check_compiler(compiler, "amdflang")) then
id = id_amdflang
return
end if
if (check_compiler(compiler, "f18")) then
id = id_f18
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, "lfortran")) then
id = id_lfortran
return
end if
if (check_compiler(compiler, "all")) then
id = id_all
return
end if
id = id_unknown
end function match_compiler_type
!> Check if compiler name is a valid compiler name
pure elemental subroutine validate_compiler_name(compiler_name, is_valid)
!> Name of a compiler
character(len=*), intent(in) :: compiler_name
!> Boolean value of whether compiler_name is valid or not
logical, intent(out) :: is_valid
character(:), allocatable :: lname
lname = lower(compiler_name)
select case (lname)
case("gfortran", "ifort", "ifx", "pgfortran", &
"nvfortran", "flang", "amdflang", "caf", &
"f95", "lfortran", "lfc", "nagfor",&
"crayftn", "xlf90", "ftn95", "all")
is_valid = .true.
case default
is_valid = .false.
end select
end subroutine validate_compiler_name
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
pure function is_unknown(self)
class(compiler_t), intent(in) :: self
logical :: is_unknown
is_unknown = self%id == id_unknown
end function is_unknown
pure logical function is_intel(self)
class(compiler_t), intent(in) :: self
is_intel = any(self%id == [id_intel_classic_nix,id_intel_classic_mac,id_intel_classic_windows, &
id_intel_llvm_nix,id_intel_llvm_windows,id_intel_llvm_unknown])
end function is_intel
pure logical function is_gnu(self)
class(compiler_t), intent(in) :: self
is_gnu = any(self%id == [id_f95,id_gcc,id_caf])
end function is_gnu
!>
!> Enumerate libraries, based on compiler and platform
!>
function enumerate_libraries(self, prefix, libs) result(r)
class(compiler_t), intent(in) :: self
character(len=*), intent(in) :: prefix
type(string_t), intent(in) :: libs(:)
character(len=:), allocatable :: r
character(len=:), allocatable :: joined
if (size(libs) == 0) then
r = prefix
return
end if
select case (self%id)
case (id_intel_classic_windows, id_intel_llvm_windows)
! Windows Intel uses `.lib` files directly
joined = string_cat(libs, ".lib ") // ".lib"
r = trim(prefix) // " " // trim(joined)
case (id_nag, id_ibmxl)
! NAG and IBMXL need -Wl, wrapper around linker flags
joined = string_cat(libs, " -Wl,")
r = trim(prefix) // " -Wl," // trim(joined)
case default
! Generic Unix-style linker flags: use `-lfoo`
joined = string_cat(libs, " -l")
r = trim(prefix) // " -l" // trim(joined)
end select
end function enumerate_libraries
!>
!> Generate library export flags for a shared library build
!>
function get_export_flags(self, target_dir, target_name) result(export_flags)
!> Instance of the compiler
class(compiler_t), intent(in) :: self
!> Path and package name
character(len=*), intent(in) :: target_dir, target_name
character(len=:), allocatable :: export_flags
character(len=:), allocatable :: implib_path, def_path
! Only apply on Windows
if (get_os_type() /= OS_WINDOWS) then
export_flags = ""
return
end if
select case (self%id)
case (id_gcc, id_caf, id_f95)
! GNU-based: emit both import library and def file
implib_path = quote(join_path(target_dir, target_name // ".dll.a") , for_cmd=.true.)
def_path = quote(join_path(target_dir, target_name // ".def" ) , for_cmd=.true.)
export_flags = " -Wl,--out-implib," // implib_path // &
" -Wl,--output-def," // def_path
case (id_intel_classic_windows, id_intel_llvm_windows)
! Intel/MSVC-style
implib_path = quote(join_path(target_dir, target_name // ".lib") , for_cmd=.true.)
def_path = quote(join_path(target_dir, target_name // ".def") , for_cmd=.true.)
export_flags = " /IMPLIB:" // implib_path // &
" /DEF:" // def_path
case default
export_flags = "" ! Do nothing elsewhere
end select
end function get_export_flags
!>
!> Generate `install_name` flag for a shared library build on macOS
!>
function get_install_name_flags(self, target_dir, target_name) result(flags)
class(compiler_t), intent(in) :: self
character(len=*), intent(in) :: target_dir, target_name
character(len=:), allocatable :: flags
character(len=:), allocatable :: library_file
if (get_os_type() /= OS_MACOS) then
flags = ""
return
end if
! Shared library basename (e.g., libfoo.dylib)
if (str_ends_with(target_name, ".dylib")) then
library_file = target_name
else
library_file = library_filename(target_name,.true.,.false.,OS_MACOS)
end if
flags = " -Wl,-install_name,@rpath/" // library_file
end function get_install_name_flags
!>
!> Generate header padding flags for install_name_tool compatibility on macOS
!>
function get_headerpad_flags(self) result(flags)
class(compiler_t), intent(in) :: self
character(len=:), allocatable :: flags
if (get_os_type() /= OS_MACOS) then
flags = ""
return
end if
! Reserve enough space in the Mach-O header to safely add two install_name or rpath later
flags = " -Wl,-headerpad,0x200"
end function get_headerpad_flags
!> Create new compiler instance
subroutine new_compiler(self, fc, cc, cxx, echo, verbose)
!> New instance of the compiler
type(compiler_t), intent(out) :: self
!> Fortran compiler name or path
character(len=*), intent(in) :: fc
!> C compiler name or path
character(len=*), intent(in) :: cc
!> C++ Compiler name or path
character(len=*), intent(in) :: cxx
!> Echo compiler command
logical, intent(in) :: echo
!> Verbose mode: dump compiler output
logical, intent(in) :: verbose
self%id = get_compiler_id(fc)
self%echo = echo
self%verbose = verbose
self%fc = fc
if (len_trim(cc) > 0) then
self%cc = cc
else
call get_default_c_compiler(self%fc, self%cc)
end if
if (len_trim(cxx) > 0) then
self%cxx = cxx
else
call get_default_cxx_compiler(self%fc, self%cxx)
end if
end subroutine new_compiler
!> Create new archiver instance
subroutine new_archiver(self, ar, echo, verbose)
!> New instance of the archiver
type(archiver_t), intent(out) :: self
!> User provided archiver command
character(len=*), intent(in) :: ar
!> Echo compiler command
logical, intent(in) :: echo
!> Verbose mode: dump compiler output
logical, intent(in) :: verbose
integer :: estat, os_type
character(len=*), parameter :: arflags = " -rs ", libflags = " /OUT:"
if (len_trim(ar) > 0) then
! Check first for ar-like commands
if (check_compiler(ar, "ar")) then
self%ar = ar//arflags
end if
! Check for lib-like commands
if (check_compiler(ar, "lib")) then
self%ar = ar//libflags
end if
! Fallback and assume ar-like behaviour
self%ar = ar//arflags
else
os_type = get_os_type()
if (os_type /= OS_WINDOWS .and. os_type /= OS_UNKNOWN) then
self%ar = "ar"//arflags
else
! Attempt "ar"
call execute_command_line("ar --version > "//get_temp_filename()//" 2>&1", &
& exitstat=estat)
if (estat == 0) then
self%ar = "ar"//arflags
else
! Then "gcc-ar"
call execute_command_line("gcc-ar --version > "//get_temp_filename()//" 2>&1", &
& exitstat=estat)
if (estat /= 0) then
self%ar = "lib"//libflags
else
self%ar = "gcc-ar"//arflags
end if
endif
end if
end if
self%use_response_file = os_type == OS_WINDOWS
self%echo = echo
self%verbose = verbose
end subroutine new_archiver
!> Compile a Fortran object
subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry_run)
!> Instance of the compiler object
class(compiler_t), intent(in) :: self
!> Source file input
character(len=*), intent(in) :: input
!> Output file of object
character(len=*), intent(in) :: output
!> Arguments for compiler
character(len=*), intent(in) :: args
!> Compiler output log file
character(len=*), intent(in) :: log_file
!> Status flag
integer, intent(out) :: stat
!> Optional compile_commands table
type(compile_command_table_t), optional, intent(inout) :: table
!> Optional mocking
logical, optional, intent(in) :: dry_run
character(len=:), allocatable :: command
type(error_t), allocatable :: error
logical :: mock
! Check if we're actually building this file
mock = .false.
if (present(dry_run)) mock = dry_run
! Set command
command = self%fc // " -c " // input // " " // args // " -o " // output
! Execute command
if (.not.mock) then
call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat)
if (stat/=0) return
endif
! Optionally register compile command
if (present(table)) then
call table%register(command, get_os_type(), error)
stat = merge(-1,0,allocated(error))
endif
end subroutine compile_fortran
!> Compile a C object
subroutine compile_c(self, input, output, args, log_file, stat, table, dry_run)
!> Instance of the compiler object
class(compiler_t), intent(in) :: self
!> Source file input
character(len=*), intent(in) :: input
!> Output file of object
character(len=*), intent(in) :: output
!> Arguments for compiler
character(len=*), intent(in) :: args
!> Compiler output log file
character(len=*), intent(in) :: log_file
!> Status flag
integer, intent(out) :: stat
!> Optional compile_commands table
type(compile_command_table_t), optional, intent(inout) :: table
!> Optional mocking
logical, optional, intent(in) :: dry_run
character(len=:), allocatable :: command
type(error_t), allocatable :: error
logical :: mock
! Check if we're actually building this file
mock = .false.
if (present(dry_run)) mock = dry_run
! Set command
command = self%cc // " -c " // input // " " // args // " -o " // output
! Execute command
if (.not.mock) then
call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat)
if (stat/=0) return
endif
! Optionally register compile command
if (present(table)) then
call table%register(command, get_os_type(), error)
stat = merge(-1,0,allocated(error))
endif
end subroutine compile_c
!> Compile a CPP object
subroutine compile_cpp(self, input, output, args, log_file, stat, table, dry_run)
!> Instance of the compiler object
class(compiler_t), intent(in) :: self
!> Source file input
character(len=*), intent(in) :: input
!> Output file of object
character(len=*), intent(in) :: output
!> Arguments for compiler
character(len=*), intent(in) :: args
!> Compiler output log file
character(len=*), intent(in) :: log_file
!> Status flag
integer, intent(out) :: stat
!> Optional compile_commands table
type(compile_command_table_t), optional, intent(inout) :: table
!> Optional mocking
logical, optional, intent(in) :: dry_run
character(len=:), allocatable :: command
type(error_t), allocatable :: error
logical :: mock
! Check if we're actually building this file
mock = .false.
if (present(dry_run)) mock = dry_run
! Set command
command = self%cxx // " -c " // input // " " // args // " -o " // output
! Execute command
if (.not.mock) then
call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat)
if (stat/=0) return
endif
! Optionally register compile command
if (present(table)) then
call table%register(command, get_os_type(), error)
stat = merge(-1,0,allocated(error))
endif
end subroutine compile_cpp
!> Link an executable
subroutine link_executable(self, output, args, log_file, stat, dry_run)
!> Instance of the compiler object
class(compiler_t), intent(in) :: self
!> Output file of object
character(len=*), intent(in) :: output
!> Arguments for compiler
character(len=*), intent(in) :: args
!> Compiler output log file
character(len=*), intent(in) :: log_file
!> Status flag
integer, intent(out) :: stat
!> Optional mocking
logical, optional, intent(in) :: dry_run
character(len=:), allocatable :: command
logical :: mock
! Check if we're actually linking
mock = .false.
if (present(dry_run)) mock = dry_run
! Set command
command = self%fc // " " // args // " -o " // output
! Execute command
if (.not.mock) &
call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat)
end subroutine link_executable
!> Link a shared library
subroutine link_shared(self, output, args, log_file, stat, dry_run)
!> Instance of the compiler object
class(compiler_t), intent(in) :: self
!> Output file of shared library object
character(len=*), intent(in) :: output
!> Arguments for the compiler
character(len=*), intent(in) :: args
!> Compiler output log file
character(len=*), intent(in) :: log_file
!> Status flag
integer, intent(out) :: stat
!> Optional mocking
logical, optional, intent(in) :: dry_run
character(len=:), allocatable :: command
logical :: mock
character(len=:), allocatable :: shared_flag
mock = .false.
if (present(dry_run)) mock = dry_run
shared_flag = get_shared_flag(self)
command = self%fc // " " // shared_flag // " " // args // " -o " // output
if (.not.mock) &
call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat)
end subroutine link_shared
!> Create an archive
!> @todo For Windows OS, use the local `delete_file_win32` in stead of `delete_file`.
!> This may be related to a bug in Mingw64-openmp and is expected to be resolved in the future,
!> see issue #707, #708 and #808.
subroutine make_archive(self, output, args, log_file, stat, dry_run)
!> Instance of the archiver object
class(archiver_t), intent(in) :: self
!> Name of the archive to generate
character(len=*), intent(in) :: output
!> Object files to include into the archive
type(string_t), intent(in) :: args(:)
!> Compiler output log file
character(len=*), intent(in) :: log_file
!> Status flag
integer, intent(out) :: stat
!> Optional mocking
logical, optional, intent(in) :: dry_run
logical :: mock
! Check if we're actually linking
mock = .false.
if (present(dry_run)) mock = dry_run
if (mock) return
if (self%use_response_file) then
call write_response_file(output//".resp" , args)
call run(self%ar // output // " @" // output//".resp", echo=self%echo, &
& verbose=self%verbose, redirect=log_file, exitstat=stat)
call delete_file_win32(output//".resp")
else
call run(self%ar // output // " " // string_cat(args, " "), &
& echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat)
end if
contains
subroutine delete_file_win32(file)
character(len=*), intent(in) :: file
logical :: exist
integer :: unit, iostat
inquire(file=file, exist=exist)
if (exist) then
open(file=file, newunit=unit)
close(unit, status='delete', iostat=iostat)
end if
end subroutine delete_file_win32
end subroutine make_archive
!> Response files allow to read command line options from files.
!> Whitespace is used to separate the arguments, we will use newlines
!> as separator to create readable response files which can be inspected
!> in case of errors.
subroutine write_response_file(name, argv)
character(len=*), intent(in) :: name
type(string_t), intent(in) :: argv(:)
integer :: iarg, io
open(file=name, newunit=io, status='replace')
do iarg = 1, size(argv)
write(io, '(a)') unix_path(argv(iarg)%s)
end do
close(io)
end subroutine write_response_file
!> String representation of a compiler object
pure function debug_compiler(self) result(repr)
!> Instance of the compiler object
type(compiler_t), intent(in) :: self
!> Representation as string
character(len=:), allocatable :: repr
repr = 'fc="'//self%fc//'", cc="'//self%cc//'"'
end function debug_compiler
!> String representation of an archiver object
pure function debug_archiver(self) result(repr)
!> Instance of the archiver object
type(archiver_t), intent(in) :: self
!> Representation as string
character(len=:), allocatable :: repr
repr = 'ar="'//self%ar//'"'
end function debug_archiver
!> Check that two archiver_t objects are equal
logical function ar_is_same(this,that)
class(archiver_t), intent(in) :: this
class(serializable_t), intent(in) :: that
ar_is_same = .false.
select type (other=>that)
type is (archiver_t)
if (allocated(this%ar).neqv.allocated(other%ar)) return
if (allocated(this%ar)) then
if (.not.(this%ar==other%ar)) return
end if
if (.not.(this%use_response_file.eqv.other%use_response_file)) return
if (.not.(this%echo.eqv.other%echo)) return
if (.not.(this%verbose.eqv.other%verbose)) return
class default
! Not the same type
return
end select
!> All checks passed!
ar_is_same = .true.
end function ar_is_same
!> Dump dependency to toml table
subroutine dump_to_toml(self, table, error)
!> Instance of the serializable object
class(archiver_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Path to archiver
call set_string(table, "ar", self%ar, error, 'archiver_t')
if (allocated(error)) return
call set_value(table, "use-response-file", self%use_response_file, error, 'archiver_t')
if (allocated(error)) return
call set_value(table, "echo", self%echo, error, 'archiver_t')
if (allocated(error)) return
call set_value(table, "verbose", self%verbose, error, 'archiver_t')
if (allocated(error)) return
end subroutine dump_to_toml
!> Read dependency from toml table (no checks made at this stage)
subroutine load_from_toml(self, table, error)
!> Instance of the serializable object
class(archiver_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call get_value(table, "ar", self%ar)
call get_value(table, "use-response-file", self%use_response_file, error, 'archiver_t')
if (allocated(error)) return
call get_value(table, "echo", self%echo, error, 'archiver_t')
if (allocated(error)) return
call get_value(table, "verbose", self%verbose, error, 'archiver_t')
if (allocated(error)) return
end subroutine load_from_toml
!> Check that two compiler_t objects are equal
logical function compiler_is_same(this,that)
class(compiler_t), intent(in) :: this
class(serializable_t), intent(in) :: that
compiler_is_same = .false.
select type (other=>that)
type is (compiler_t)
if (.not.(this%id==other%id)) return
if (allocated(this%fc).neqv.allocated(other%fc)) return
if (allocated(this%fc)) then
if (.not.(this%fc==other%fc)) return
end if
if (allocated(this%cc).neqv.allocated(other%cc)) return
if (allocated(this%cc)) then
if (.not.(this%cc==other%cc)) return
end if
if (allocated(this%cxx).neqv.allocated(other%cxx)) return
if (allocated(this%cxx)) then
if (.not.(this%cxx==other%cxx)) return
end if
if (.not.(this%echo.eqv.other%echo)) return
if (.not.(this%verbose.eqv.other%verbose)) return
class default
! Not the same type
return
end select
!> All checks passed!
compiler_is_same = .true.
end function compiler_is_same
!> Dump dependency to toml table
subroutine compiler_dump(self, table, error)
!> Instance of the serializable object
class(compiler_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: ierr
call set_value(table, "id", self%id, error, 'compiler_t')
if (allocated(error)) return
call set_string(table, "fc", self%fc, error, 'compiler_t')
if (allocated(error)) return
call set_string(table, "cc", self%cc, error, 'compiler_t')
if (allocated(error)) return
call set_string(table, "cxx", self%cxx, error, 'compiler_t')
if (allocated(error)) return
call set_value(table, "echo", self%echo, error, 'compiler_t')
if (allocated(error)) return
call set_value(table, "verbose", self%verbose, error, 'compiler_t')
if (allocated(error)) return
end subroutine compiler_dump
!> Read dependency from toml table (no checks made at this stage)
subroutine compiler_load(self, table, error)
!> Instance of the serializable object
class(compiler_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call get_value(table, "id", self%id, error, 'compiler_t')
if (allocated(error)) return
call get_value(table, "fc", self%fc)
call get_value(table, "cc", self%cc)
call get_value(table, "cxx", self%cxx)
call get_value(table, "echo", self%echo, error, 'compiler_t')
if (allocated(error)) return
call get_value(table, "verbose", self%verbose, error, 'compiler_t')
if (allocated(error)) return
end subroutine compiler_load
!> Return a compiler name string
pure function compiler_name(self) result(name)
!> Instance of the compiler object
class(compiler_t), intent(in) :: self
!> Representation as string
character(len=:), allocatable :: name
name = compiler_id_name(self%id)
end function compiler_name
!> Convert compiler enum to name (reverse of match_compiler_type)
pure function compiler_id_name(id) result(name)
integer(compiler_enum), intent(in) :: id
character(len=:), allocatable :: name
select case (id)
case(id_gcc); name = "gfortran"
case(id_f95); name = "f95"
case(id_caf); name = "caf"
case(id_intel_classic_nix); name = "ifort"
case(id_intel_classic_mac); name = "ifort"
case(id_intel_classic_windows); name = "ifort"
case(id_intel_llvm_nix); name = "ifx"
case(id_intel_llvm_windows); name = "ifx"
case(id_intel_llvm_unknown); name = "ifx"
case(id_pgi); name = "pgfortran"
case(id_nvhpc); name = "nvfortran"
case(id_nag); name = "nagfor"
case(id_flang_classic); name = "flang-classic"
case(id_flang); name = "flang"
case(id_amdflang); name = "amdflang"
case(id_f18); name = "f18"
case(id_ibmxl); name = "xlf90"
case(id_cray); name = "crayftn"
case(id_lahey); name = "lfc"
case(id_lfortran); name = "lfortran"
case (id_all); name = "all"
case default; name = "invalid/unknown"
end select
end function compiler_id_name
!> Run a single-source Fortran program using the current compiler
!> Compile a Fortran object
logical function check_fortran_source_runs(self, input, compile_flags, link_flags) result(success)
!> Instance of the compiler object
class(compiler_t), intent(in) :: self
!> Program Source
character(len=*), intent(in) :: input
!> Optional build and link flags
character(len=*), optional, intent(in) :: compile_flags, link_flags
integer :: stat,unit
character(:), allocatable :: source,object,logf,exe,flags,ldflags
success = .false.
!> Create temporary source file
exe = get_temp_filename()
source = exe//'.f90'
object = exe//'.o'
logf = exe//'.log'
open(newunit=unit, file=source, action='readwrite', iostat=stat)
if (stat/=0) return
!> Write contents
write(unit,*) input
close(unit)
!> Get flags
flags = self%get_default_flags(release=.false.)
ldflags = self%get_default_flags(release=.false.)
if (present(compile_flags)) flags = flags//" "//compile_flags
if (present(link_flags)) ldflags = ldflags//" "//link_flags
!> Intel: Needs -warn last for error on unknown command line arguments to work
if (self%id == id_intel_llvm_nix) then
flags = flags//" "//flag_intel_warn
ldflags = ldflags//" "//flag_intel_warn
elseif (self%id == id_intel_llvm_windows) then
flags = flags//" "//flag_intel_warn_win
ldflags = ldflags//" "//flag_intel_warn_win
end if
!> Compile and link program
call self%compile_fortran(source, object, flags, logf, stat)
if (stat==0) &
call self%link(exe, ldflags//" "//object, logf, stat)
!> Run and retrieve exit code
if (stat==0) &
call run(exe,echo=.false., exitstat=stat, verbose=.false., redirect=logf)
!> Successful exit on 0 exit code
success = stat==0
!> Delete files
open(newunit=unit, file=source, action='readwrite', iostat=stat)
close(unit,status='delete')
open(newunit=unit, file=object, action='readwrite', iostat=stat)
close(unit,status='delete')
open(newunit=unit, file=logf, action='readwrite', iostat=stat)
close(unit,status='delete')
open(newunit=unit, file=exe, action='readwrite', iostat=stat)
close(unit,status='delete')
end function check_fortran_source_runs
!> Check if the given C source code compiles, links, and runs successfully
logical function check_c_source_runs(self, input, compile_flags, link_flags) result(success)
!> Instance of the compiler object
class(compiler_t), intent(in) :: self
!> C program source
character(len=*), intent(in) :: input
!> Optional build and link flags
character(len=*), optional, intent(in) :: compile_flags, link_flags
integer :: stat,unit
character(:), allocatable :: source,object,logf,exe,flags,ldflags
success = .false.
!> Create temporary source file
exe = get_temp_filename()
source = exe//'.c'
object = exe//'.o'
logf = exe//'.log'
open(newunit=unit, file=source, action='readwrite', iostat=stat)
if (stat/=0) return
!> Write contents
write(unit,'(a)') input
close(unit)
!> Get flags
flags = ""
ldflags = ""
if (present(compile_flags)) flags = flags//" "//compile_flags
if (present(link_flags)) ldflags = ldflags//" "//link_flags
!> Compile
call self%compile_c(source,object,flags,logf,stat,dry_run=.false.)
if (stat/=0) return
!> Link using C compiler for pure C programs
call run(self%cc//" "//ldflags//" "//object//" -o "//exe, &
echo=self%echo, verbose=self%verbose, redirect=logf, exitstat=stat)
if (stat/=0) return
!> Run
call run(exe//" > "//logf//" 2>&1",echo=.false.,exitstat=stat)
success = (stat == 0)
!> Delete temporary files
open(newunit=unit, file=source, action='readwrite', iostat=stat)
close(unit,status='delete')
open(newunit=unit, file=object, action='readwrite', iostat=stat)
close(unit,status='delete')
open(newunit=unit, file=logf, action='readwrite', iostat=stat)
close(unit,status='delete')
open(newunit=unit, file=exe, action='readwrite', iostat=stat)
close(unit,status='delete')
end function check_c_source_runs
!> Check if the given C++ source code compiles, links, and runs successfully
logical function check_cxx_source_runs(self, input, compile_flags, link_flags) result(success)
!> Instance of the compiler object
class(compiler_t), intent(in) :: self
!> C++ program source
character(len=*), intent(in) :: input
!> Optional build and link flags
character(len=*), optional, intent(in) :: compile_flags, link_flags
integer :: stat,unit
character(:), allocatable :: source,object,logf,exe,flags,ldflags
success = .false.
!> Create temporary source file
exe = get_temp_filename()
source = exe//'.cpp'
object = exe//'.o'
logf = exe//'.log'
open(newunit=unit, file=source, action='readwrite', iostat=stat)
if (stat/=0) return
!> Write contents
write(unit,'(a)') input
close(unit)
!> Get flags
flags = ""
ldflags = ""
if (present(compile_flags)) flags = flags//" "//compile_flags
if (present(link_flags)) ldflags = ldflags//" "//link_flags
!> Compile
call self%compile_cpp(source,object,flags,logf,stat,dry_run=.false.)
if (stat/=0) return
!> Link using C++ compiler for pure C++ programs
call run(self%cxx//" "//ldflags//" "//object//" -o "//exe, &
echo=self%echo, verbose=self%verbose, redirect=logf, exitstat=stat)
if (stat/=0) return
!> Run
call run(exe//" > "//logf//" 2>&1",echo=.false.,exitstat=stat)
success = (stat == 0)
!> Delete temporary files
open(newunit=unit, file=source, action='readwrite', iostat=stat)
close(unit,status='delete')
open(newunit=unit, file=object, action='readwrite', iostat=stat)
close(unit,status='delete')
open(newunit=unit, file=logf, action='readwrite', iostat=stat)
close(unit,status='delete')
open(newunit=unit, file=exe, action='readwrite', iostat=stat)
close(unit,status='delete')
end function check_cxx_source_runs
!> Check if the given C compile and/or link flags are accepted by the C compiler
logical function check_c_flags_supported(self, compile_flags, link_flags)
class(compiler_t), intent(in) :: self
character(len=*), optional, intent(in) :: compile_flags, link_flags
! Minimal C program that always compiles
character(len=*), parameter :: hello_world_c = &
"#include " // new_line('a') // &
"int main() { printf(""Hello, World!""); return 0; }"
check_c_flags_supported = self%check_c_source_runs(hello_world_c, compile_flags, link_flags)
end function check_c_flags_supported
!> Check if the given C++ compile and/or link flags are accepted by the C++ compiler
logical function check_cxx_flags_supported(self, compile_flags, link_flags)
class(compiler_t), intent(in) :: self
character(len=*), optional, intent(in) :: compile_flags, link_flags
! Minimal C++ program that always compiles
character(len=*), parameter :: hello_world_cxx = &
"#include " // new_line('a') // &
"int main() { printf(""Hello, World!""); return 0; }"
check_cxx_flags_supported = self%check_cxx_source_runs(hello_world_cxx, compile_flags, link_flags)
end function check_cxx_flags_supported
!> Check if the given compile and/or link flags are accepted by the compiler
logical function check_flags_supported(self, compile_flags, link_flags)
class(compiler_t), intent(in) :: self
character(len=*), optional, intent(in) :: compile_flags, link_flags
! Minimal program that always compiles
character(len=*), parameter :: hello_world = "print *, 'Hello, World!'; end"
check_flags_supported = self%check_fortran_source_runs(hello_world, compile_flags, link_flags)
end function check_flags_supported
!> Check if the current compiler supports 128-bit real precision
logical function with_qp(self)
!> Instance of the compiler object
class(compiler_t), intent(in) :: self
with_qp = self%check_fortran_source_runs &
('if (selected_real_kind(33) == -1) stop 1; end')
end function with_qp
!> Check if the current compiler supports 80-bit "extended" real precision
logical function with_xdp(self)
!> Instance of the compiler object
class(compiler_t), intent(in) :: self
with_xdp = self%check_fortran_source_runs &
('if (any(selected_real_kind(18) == [-1, selected_real_kind(33)])) stop 1; end')
end function with_xdp
!> Append new flags to existing flags, removing duplicates and empty flags (string version)
subroutine append_clean_flags(flags, new_flags)
character(:), intent(inout), allocatable :: flags
character(*), intent(in) :: new_flags
type(string_t), allocatable :: flags_array(:), new_flags_array(:)
integer :: i
call tokenize_flags(flags, flags_array)
call tokenize_flags(new_flags, new_flags_array)
call append_clean_flags_array(flags_array, new_flags_array)
do i = 1, size(flags_array)
flags = flags // " " // flags_array(i)%s
end do
end subroutine append_clean_flags
!> Append new flags to existing flags, removing duplicates and empty flags (array version)
subroutine append_clean_flags_array(flags_array, new_flags_array)
type(string_t), allocatable, intent(inout) :: flags_array(:)
type(string_t), intent(in) :: new_flags_array(:)
integer :: i
do i = 1, size(new_flags_array)
if (string_array_contains(new_flags_array(i)%s, flags_array)) cycle
! Filter out empty flags and arguments
if (new_flags_array(i)%s == "") cycle
if (trim(new_flags_array(i)%s) == "-l") cycle
if (trim(new_flags_array(i)%s) == "-L") cycle
if (trim(new_flags_array(i)%s) == "-I") cycle
if (trim(new_flags_array(i)%s) == "-J") cycle
if (trim(new_flags_array(i)%s) == "-M") cycle
call add_strings(flags_array, new_flags_array(i))
end do
end subroutine append_clean_flags_array
!> Tokenize a string into an array of compiler flags
subroutine tokenize_flags(flags, flags_array)
character(*), intent(in) :: flags
type(string_t), allocatable, intent(out) :: flags_array(:)
character(len=:), allocatable :: flags_char_array(:)
integer :: i
logical :: success
flags_char_array = sh_split(flags, join_spaced=.true., keep_quotes=.true., success=success)
if (.not. success) then
allocate(flags_array(0))
return
end if
allocate(flags_array(size(flags_char_array)))
do i = 1, size(flags_char_array)
flags_array(i)%s = trim(adjustl(flags_char_array(i)))
end do
end subroutine tokenize_flags
end module fpm_compiler
fortran-lang-fpm-90bb83a/src/fpm_environment.f90 0000664 0001750 0001750 00000041512 15145116760 022010 0 ustar alastair alastair !> 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
use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, &
& stdout=>output_unit, &
& stderr=>error_unit
use,intrinsic :: iso_c_binding, only: c_char,c_int,c_null_char
use fpm_error, only : fpm_stop
use fpm_strings, only : lower
implicit none
private
public :: get_os_type
public :: match_os_type
public :: validate_os_name
public :: os_is_unix
public :: get_env
public :: set_env
public :: delete_env
public :: get_command_arguments_quoted
public :: separator
public :: library_filename
public :: OS_NAME
integer, parameter, public :: OS_ALL = -1 ! "all" flag for profile support
integer, parameter, public :: OS_UNKNOWN = 0
integer, parameter, public :: OS_LINUX = 1
integer, parameter, public :: OS_MACOS = 2
integer, parameter, public :: OS_WINDOWS = 3
integer, parameter, public :: OS_CYGWIN = 4
integer, parameter, public :: OS_SOLARIS = 5
integer, parameter, public :: OS_FREEBSD = 6
integer, parameter, public :: OS_OPENBSD = 7
contains
!> Utility function: return library filename
pure function library_filename(package_name, shared, import, target_os) result(name)
character(*), intent(in) :: package_name
!> Whether it's a shared library
logical, intent(in) :: shared
!> Whether it's for linking (import library) or actual library
logical, intent(in) :: import
!> Build target OS: one of OS_WINDOWS, OS_MACOS, ...
integer, intent(in) :: target_os
character(len=:), allocatable :: name
if (shared) then
select case (target_os)
case (OS_WINDOWS)
if (import) then
! Linking requires the import library
name = 'lib' // package_name // '.lib'
else
! The actual shared object is a DLL
name = 'lib' // package_name // '.dll'
end if
case (OS_MACOS)
name = 'lib' // package_name // '.dylib'
case default
name = 'lib' // package_name // '.so'
end select
else
! Static library (same for all platforms)
name = 'lib' // package_name // '.a'
end if
end function library_filename
!> Return string describing the OS type flag
pure function OS_NAME(os)
integer, intent(in) :: os
character(len=:), allocatable :: OS_NAME
select case (os)
case (OS_LINUX); OS_NAME = "Linux"
case (OS_MACOS); OS_NAME = "macOS"
case (OS_WINDOWS); OS_NAME = "Windows"
case (OS_CYGWIN); OS_NAME = "Cygwin"
case (OS_SOLARIS); OS_NAME = "Solaris"
case (OS_FREEBSD); OS_NAME = "FreeBSD"
case (OS_OPENBSD); OS_NAME = "OpenBSD"
case (OS_UNKNOWN); OS_NAME = "Unknown"
case (OS_ALL) ; OS_NAME = "all"
case default ; OS_NAME = "UNKNOWN"
end select
end function OS_NAME
!> Match os_name to os_type enum (similar to profiles.f90)
integer function match_os_type(os_name) result(os_type)
character(len=*), intent(in) :: os_name
select case (lower(os_name))
case ("linux"); os_type = OS_LINUX
case ("macos"); os_type = OS_MACOS
case ("windows"); os_type = OS_WINDOWS
case ("cygwin"); os_type = OS_CYGWIN
case ("solaris"); os_type = OS_SOLARIS
case ("freebsd"); os_type = OS_FREEBSD
case ("openbsd"); os_type = OS_OPENBSD
case ("all"); os_type = OS_ALL
case default; os_type = OS_UNKNOWN
end select
end function match_os_type
!> Check if os_name is a valid name of a supported OS
pure elemental subroutine validate_os_name(os_name, is_valid)
!> Name of an operating system
character(len=*), intent(in) :: os_name
!> Boolean value of whether os_name is valid or not
logical, intent(out) :: is_valid
select case (lower(os_name))
case ("linux", "macos", "windows", "cygwin", "solaris", "freebsd", &
& "openbsd", "all")
is_valid = .true.
case default
is_valid = .false.
end select
end subroutine validate_os_name
!> Determine the OS type
integer function get_os_type() result(r)
!!
!! Returns one of OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, OS_CYGWIN,
!! OS_SOLARIS, OS_FREEBSD, OS_OPENBSD.
!!
!! 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=255) :: val
integer :: length, rc
logical :: file_exists
logical, save :: first_run = .true.
integer, save :: ret = OS_UNKNOWN
!$omp threadprivate(ret, first_run)
if (.not. first_run) then
r = ret
return
end if
first_run = .false.
r = OS_UNKNOWN
! Check environment variable `OSTYPE`.
call get_environment_variable('OSTYPE', val, length, rc)
if (rc == 0 .and. length > 0) then
! Linux
if (index(val, 'linux') > 0) then
r = OS_LINUX
ret = r
return
end if
! macOS
if (index(val, 'darwin') > 0) then
r = OS_MACOS
ret = r
return
end if
! Windows, MSYS, MinGW, Git Bash
if (index(val, 'win') > 0 .or. index(val, 'msys') > 0) then
r = OS_WINDOWS
ret = r
return
end if
! Cygwin
if (index(val, 'cygwin') > 0) then
r = OS_CYGWIN
ret = r
return
end if
! Solaris, OpenIndiana, ...
if (index(val, 'SunOS') > 0 .or. index(val, 'solaris') > 0) then
r = OS_SOLARIS
ret = r
return
end if
! FreeBSD
if (index(val, 'FreeBSD') > 0 .or. index(val, 'freebsd') > 0) then
r = OS_FREEBSD
ret = r
return
end if
! OpenBSD
if (index(val, 'OpenBSD') > 0 .or. index(val, 'openbsd') > 0) then
r = OS_OPENBSD
ret = r
return
end if
end if
! Check environment variable `OS`.
call get_environment_variable('OS', val, length, rc)
if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then
r = OS_WINDOWS
ret = r
return
end if
! Linux
inquire (file='/etc/os-release', exist=file_exists)
if (file_exists) then
r = OS_LINUX
ret = r
return
end if
! macOS
inquire (file='/usr/bin/sw_vers', exist=file_exists)
if (file_exists) then
r = OS_MACOS
ret = r
return
end if
! FreeBSD
inquire (file='/bin/freebsd-version', exist=file_exists)
if (file_exists) then
r = OS_FREEBSD
ret = r
return
end if
end function get_os_type
!> 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)
integer, intent(in), optional :: os
integer :: build_os
if (present(os)) then
build_os = os
else
build_os = get_os_type()
end if
os_is_unix = build_os /= OS_WINDOWS
end function os_is_unix
!> 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/='')then
call get_environment_variable(NAME, length=howbig,status=stat,trim_name=.true.)
select case (stat)
case (1)
!*!print *, NAME, " is not defined in the environment. Strange..."
VALUE=''
case (2)
!*!print *, "This processor doesn't support environment variables. Boooh!"
VALUE=''
case default
! make string to hold value of sufficient size
allocate(character(len=max(howbig,1)) :: VALUE)
! get value
call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.)
if(stat/=0)VALUE=''
end select
else
VALUE=''
endif
if(VALUE==''.and.present(DEFAULT))VALUE=DEFAULT
end function get_env
function get_command_arguments_quoted() result(args)
character(len=:),allocatable :: args
character(len=:),allocatable :: arg
character(len=1) :: quote
integer :: ilength, istatus, i
ilength=0
args=''
quote=merge('"',"'",separator()=='\')
do i=2,command_argument_count() ! look at all arguments after subcommand
call get_command_argument(number=i,length=ilength,status=istatus)
if(istatus /= 0) then
write(stderr,'(*(g0,1x))')'*get_command_arguments_stack* error obtaining argument ',i
exit
else
if(allocated(arg))deallocate(arg)
allocate(character(len=ilength) :: arg)
call get_command_argument(number=i,value=arg,length=ilength,status=istatus)
if(istatus /= 0) then
write(stderr,'(*(g0,1x))')'*get_command_arguments_stack* error obtaining argument ',i
exit
elseif(ilength>0)then
if(index(arg//' ','-')/=1)then
args=args//quote//arg//quote//' '
elseif(index(arg,' ')/=0)then
args=args//quote//arg//quote//' '
else
args=args//arg//' '
endif
else
args=args//repeat(quote,2)//' '
endif
endif
enddo
end function get_command_arguments_quoted
function separator() result(sep)
!>
!!##NAME
!! separator(3f) - [M_io:ENVIRONMENT] try to determine pathname directory separator character
!! (LICENSE:PD)
!!
!!##SYNOPSIS
!!
!! function separator() result(sep)
!!
!! character(len=1) :: sep
!!
!!##DESCRIPTION
!! First using the name the program was invoked with, then the name
!! returned by an INQUIRE(3f) of that name, then ".\NAME" and "./NAME"
!! try to determine the separator character used to separate directory
!! names from file basenames.
!!
!! If a slash or backslash is not found in the name, the environment
!! variable PATH is examined first for a backslash, then a slash.
!!
!! Can be very system dependent. If the queries fail the default returned
!! is "/".
!!
!!##EXAMPLE
!!
!! sample usage
!!
!! program demo_separator
!! use M_io, only : separator
!! implicit none
!! write(*,*)'separator=',separator()
!! end program demo_separator
! use the pathname returned as arg0 to determine pathname separator
implicit none
character(len=:),allocatable :: arg0
integer :: arg0_length
integer :: istat
logical :: existing
character(len=1) :: sep
!*ifort_bug*!character(len=1),save :: sep_cache=' '
character(len=4096) :: name
character(len=:),allocatable :: fname
!*ifort_bug*! if(sep_cache/=' ')then ! use cached value. NOTE: A parallel code might theoretically use multiple OS
!*ifort_bug*! sep=sep_cache
!*ifort_bug*! return
!*ifort_bug*! endif
arg0_length=0
name=' '
call get_command_argument(0,length=arg0_length,status=istat)
if(allocated(arg0))deallocate(arg0)
allocate(character(len=arg0_length) :: arg0)
call get_command_argument(0,arg0,status=istat)
! check argument name
if(index(arg0,'\')/=0)then
sep='\'
elseif(index(arg0,'/')/=0)then
sep='/'
else
! try name returned by INQUIRE(3f)
existing=.false.
name=' '
inquire(file=arg0,iostat=istat,exist=existing,name=name)
if(index(name,'\')/=0)then
sep='\'
elseif(index(name,'/')/=0)then
sep='/'
else
! well, try some common syntax and assume in current directory
fname='.\'//arg0
inquire(file=fname,iostat=istat,exist=existing)
if(existing)then
sep='\'
else
fname='./'//arg0
inquire(file=fname,iostat=istat,exist=existing)
if(existing)then
sep='/'
else ! check environment variable PATH
sep=merge('\','/',index(get_env('PATH'),'\')/=0)
!*!write(*,*)'unknown system directory path separator'
endif
endif
endif
endif
!*ifort_bug*!sep_cache=sep
end function separator
!> Set an environment variable for the current environment using the C standard library
logical function set_env(name,value,overwrite)
!> Variable name
character(*), intent(in) :: name
!> Variable value
character(*), intent(in) :: value
!> Should a former value be overwritten? default = .true.
logical, optional, intent(in) :: overwrite
! Local variables
logical :: can_overwrite
integer(c_int) :: cover,cerr
character(kind=c_char,len=1), allocatable :: c_value(:),c_name(:)
interface
integer(c_int) function c_setenv(envname, envval, overwrite) &
bind(C,name="c_setenv")
import c_int, c_char
implicit none
!> Pointer to the name string
character(kind=c_char,len=1), intent(in) :: envname(*)
!> Pointer to the value string
character(kind=c_char,len=1), intent(in) :: envval(*)
!> Overwrite option
integer(c_int), intent(in), value :: overwrite
end function c_setenv
end interface
!> Overwrite setting
cerr = 0_c_int
can_overwrite = .true.
if (present(overwrite)) can_overwrite = overwrite
cover = merge(1_c_int,0_c_int,can_overwrite)
!> C strings
call f2cs(name,c_name)
call f2cs(value,c_value)
!> Call setenv
#ifndef FPM_BOOTSTRAP
cerr = c_setenv(c_name,c_value,cover)
#endif
set_env = cerr==0_c_int
end function set_env
!> Deletes an environment variable for the current environment using the C standard library
!> Returns an error if the variable did not exist in the first place
logical function delete_env(name) result(success)
!> Variable name
character(*), intent(in) :: name
! Local variables
integer(c_int) :: cerr
character(kind=c_char,len=1), allocatable :: c_name(:)
interface
integer(c_int) function c_unsetenv(envname) bind(C,name="c_unsetenv")
import c_int, c_char
implicit none
!> Pointer to the name string
character(kind=c_char,len=1), intent(in) :: envname(*)
end function c_unsetenv
end interface
!> C strings
call f2cs(name,c_name)
!> Call setenv
#ifndef FPM_BOOTSTRAP
cerr = c_unsetenv(c_name)
#endif
success = cerr==0_c_int
end function delete_env
!> Fortran to C allocatable string
pure subroutine f2cs(f,c)
use iso_c_binding, only: c_char,c_null_char
character(*), intent(in) :: f
character(len=1,kind=c_char), allocatable, intent(out) :: c(:)
integer :: lf,i
lf = len(f)
allocate(c(lf+1))
c(lf+1) = c_null_char
forall(i=1:lf) c(i) = f(i:i)
end subroutine f2cs
end module fpm_environment
fortran-lang-fpm-90bb83a/src/fpm_environment.c 0000664 0001750 0001750 00000002440 15145116760 021631 0 ustar alastair alastair #include
#include
/// @brief Set environment variable using the C standard library
/// @param envname: points to a string containing the name of an environment variable to be added or altered.
/// @param envval: points to the value the environment variable is set to
/// @param overwrite: flag to determine whether an old value should be overwritten
/// @return success flag, 0 on successful execution
int c_setenv(const char *envname, const char *envval, int overwrite) {
#ifndef _WIN32
return setenv(envname, envval, overwrite);
#else
int errcode = 0;
if(!overwrite) {
size_t envsize = 0;
errcode = getenv_s(&envsize, NULL, 0, envname);
if (errcode || envsize) return errcode;
}
return _putenv_s(envname, envval);
#endif
}
/// @brief Delete environment variable using the C standard library
/// @param envname: points to a string containing the name of an environment variable.
/// @return success flag, 0 on successful execution
int c_unsetenv(const char *envname) {
#ifndef _WIN32
return unsetenv(envname);
#else
char* str = malloc(64*sizeof(char));
*str = '\0';
int errcode = _putenv_s(envname,str);
// Windows returns a non-0 code when setting empty variable
if (errcode==-1) errcode=0;
free(str);
return errcode;
#endif
}
fortran-lang-fpm-90bb83a/src/fpm_sources.f90 0000664 0001750 0001750 00000027556 15145116760 021143 0 ustar alastair alastair !># 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, is_hidden_file
use fpm_environment, only: get_os_type,OS_WINDOWS
use fpm_strings, only: lower, str_ends_with, string_t, operator(.in.), add_strings
use fpm_source_parsing, only: parse_f_source, parse_c_source
use fpm_manifest_executable, only: executable_config_t
use fpm_manifest_preprocess, only: preprocess_config_t
implicit none
private
public :: add_sources_from_dir, add_executable_sources
public :: get_exe_name_with_suffix, add_srcfile
character(4), parameter :: fortran_suffixes(2) = [".f90", &
".f "]
character(4), parameter :: c_suffixes(4) = [".c ", ".h ", ".cpp", ".hpp"]
!> Add one or multiple source files to a source file array (gcc-15 bug workaround)
interface add_srcfile
module procedure add_srcfile_one
module procedure add_srcfile_many
end interface add_srcfile
contains
!> Wrapper to source parsing routines.
!> Selects parsing routine based on source file name extension
type(srcfile_t) function parse_source(source_file_path,custom_f_ext,error,preprocess) result(source)
character(*), intent(in) :: source_file_path
type(string_t), optional, intent(in) :: custom_f_ext(:)
type(error_t), allocatable, intent(out) :: error
type(preprocess_config_t), optional, intent(in) :: preprocess
type(string_t), allocatable :: f_ext(:)
call list_fortran_suffixes(f_ext,custom_f_ext)
if (str_ends_with(lower(source_file_path), f_ext)) then
source = parse_f_source(source_file_path, error, preprocess)
if (source%unit_type == FPM_UNIT_PROGRAM) then
source%exe_name = basename(source_file_path,suffix=.false.)
end if
else if (str_ends_with(lower(source_file_path), c_suffixes)) then
source = parse_c_source(source_file_path,error)
endif
if (allocated(error)) then
return
end if
end function parse_source
!> List fortran suffixes, including optional ones
subroutine list_fortran_suffixes(suffixes,with_f_ext)
type(string_t), allocatable, intent(out) :: suffixes(:)
!> Additional user-defined (preprocessor) extensions that should be treated as Fortran sources
type(string_t), intent(in), optional :: with_f_ext(:)
integer :: ndefault,nuser,i
ndefault = size(fortran_suffixes)
nuser = 0; if (present(with_f_ext)) nuser = size(with_f_ext)
allocate(suffixes(ndefault + nuser))
do i=1,ndefault
suffixes(i) = string_t(fortran_suffixes(i))
end do
if (present(with_f_ext)) then
do i=1,nuser
suffixes(ndefault+i) = string_t(with_f_ext(i)%s)
end do
endif
end subroutine list_fortran_suffixes
!> Add to `sources` by looking for source files in `directory`
subroutine add_sources_from_dir(sources,directory,scope,with_executables,with_f_ext,recurse,error,&
preprocess)
!> 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
!> Additional user-defined (preprocessor) extensions that should be treated as Fortran sources
type(string_t), intent(in), optional :: with_f_ext(:)
!> Whether to recursively search subdirectories, default is `.true.`
logical, intent(in), optional :: recurse
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional source preprocessor configuration
type(preprocess_config_t), optional, intent(in) :: preprocess
integer :: i
logical, allocatable :: is_source(:), exclude_source(:)
logical :: recurse_
type(string_t), allocatable :: file_names(:)
type(string_t), allocatable :: src_file_names(:),f_ext(:)
type(string_t), allocatable :: existing_src_files(:)
type(srcfile_t), allocatable :: dir_sources(:)
recurse_ = .true.
if (present(recurse)) recurse_ = recurse
! Scan directory for sources
call list_files(directory, file_names,recurse=recurse_)
if (allocated(sources)) then
allocate(existing_src_files(size(sources)))
do i=1,size(sources)
existing_src_files(i)%s = canon_path(sources(i)%file_name)
end do
else
allocate(existing_src_files(0))
end if
! Get legal fortran suffixes
call list_fortran_suffixes(f_ext,with_f_ext)
is_source = [(.not.(is_hidden_file(basename(file_names(i)%s))) .and. &
.not.(canon_path(file_names(i)%s) .in. existing_src_files) .and. &
(str_ends_with(lower(file_names(i)%s), f_ext) .or. &
str_ends_with(lower(file_names(i)%s), c_suffixes) ),i=1,size(file_names))]
src_file_names = pack(file_names,is_source)
allocate(dir_sources(size(src_file_names)))
allocate(exclude_source(size(src_file_names)))
do i = 1, size(src_file_names)
dir_sources(i) = parse_source(src_file_names(i)%s,with_f_ext,error,preprocess)
if (allocated(error)) return
dir_sources(i)%unit_scope = scope
allocate(dir_sources(i)%link_libraries(0))
! Exclude executables unless specified otherwise
exclude_source(i) = (dir_sources(i)%unit_type == FPM_UNIT_PROGRAM)
if (dir_sources(i)%unit_type == FPM_UNIT_PROGRAM .and. &
& present(with_executables)) then
if (with_executables) then
exclude_source(i) = .false.
end if
end if
end do
if (.not.allocated(sources)) then
sources = pack(dir_sources,.not.exclude_source)
else
call add_srcfile(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,with_f_ext,error,preprocess)
!> 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
!> Additional user-defined (preprocessor) extensions that should be treated as Fortran sources
type(string_t), intent(in), optional :: with_f_ext(:)
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional source preprocessor configuration
type(preprocess_config_t), optional, intent(in) :: preprocess
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, with_f_ext=with_f_ext,recurse=.false., &
error=error, preprocess=preprocess)
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)
!> Compare lowercase strings to allow auto-discovery of pre-processed extensions
if (lower(basename(sources(j)%file_name,suffix=.true.)) == lower(executables(i)%main) .and.&
canon_path(dirname(sources(j)%file_name)) == &
canon_path(executables(i)%source_dir) ) then
sources(j)%exe_name = executables(i)%name
if (allocated(executables(i)%link)) then
sources(j)%link_libraries = executables(i)%link
end if
sources(j)%unit_type = FPM_UNIT_PROGRAM
cycle exe_loop
end if
end do
! Add if not already discovered (auto_discovery off)
associate(exe => executables(i))
exe_source = parse_source(join_path(exe%source_dir,exe%main),with_f_ext,error,preprocess)
exe_source%exe_name = exe%name
if (allocated(exe%link)) then
exe_source%link_libraries = exe%link
end if
exe_source%unit_type = FPM_UNIT_PROGRAM
exe_source%unit_scope = scope
end associate
if (allocated(error)) return
if (.not.allocated(sources)) then
sources = [exe_source]
else
call add_srcfile(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)
dirs_temp(i)%s=' '
enddo
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
call add_strings(exe_dirs,dirs_temp(1:n))
end if
end subroutine get_executable_source_dirs
!> Build an executable name with suffix. Safe routine that always returns an allocated string
function get_exe_name_with_suffix(source) result(suffixed)
type(srcfile_t), intent(in) :: source
character(len=:), allocatable :: suffixed
if (allocated(source%exe_name)) then
if (get_os_type() == OS_WINDOWS) then
suffixed = source%exe_name//'.exe'
else
suffixed = source%exe_name
end if
else
suffixed = ""
endif
end function get_exe_name_with_suffix
!> Add one source file to a source file array with a loop (gcc-15 bug on array initializer)
pure subroutine add_srcfile_one(list,new)
type(srcfile_t), allocatable, intent(inout) :: list(:)
type(srcfile_t), intent(in) :: new
integer :: i,n
type(srcfile_t), allocatable :: tmp(:)
if (allocated(list)) then
n = size(list)
else
n = 0
end if
allocate(tmp(n+1))
do i=1,n
tmp(i) = list(i)
end do
tmp(n+1) = new
call move_alloc(from=tmp,to=list)
end subroutine add_srcfile_one
!> Add multiple source files to a source file array with a loop (gcc-15 bug on array initializer)
pure subroutine add_srcfile_many(list,new)
type(srcfile_t), allocatable, intent(inout) :: list(:)
type(srcfile_t), intent(in) :: new(:)
integer :: i,n,add
type(srcfile_t), allocatable :: tmp(:)
if (allocated(list)) then
n = size(list)
else
n = 0
end if
add = size(new)
if (add == 0) return
allocate(tmp(n+add))
do i=1,n
tmp(i) = list(i)
end do
do i=1,add
tmp(n+i) = new(i)
end do
call move_alloc(from=tmp,to=list)
end subroutine add_srcfile_many
end module fpm_sources
fortran-lang-fpm-90bb83a/src/fpm_backend_output.f90 0000664 0001750 0001750 00000016772 15145116760 022465 0 ustar alastair alastair !># Build Backend Progress Output
!> This module provides a derived type `build_progress_t` for printing build status
!> and progress messages to the console while the backend is building the package.
!>
!> The `build_progress_t` type supports two modes: `normal` and `plain`
!> where the former does 'pretty' output and the latter does not.
!> The `normal` mode is intended for typical interactive usage whereas
!> 'plain' mode is used with the `--verbose` flag or when `stdout` is not attached
!> to a terminal (e.g. when piping or redirecting `stdout`). In these cases,
!> the pretty output must be suppressed to avoid control codes being output.
module fpm_backend_output
use iso_fortran_env, only: stdout=>output_unit
use fpm_error, only: error_t
use fpm_filesystem, only: basename,join_path
use fpm_targets, only: build_target_ptr
use fpm_backend_console, only: console_t, LINE_RESET, COLOR_RED, COLOR_GREEN, COLOR_YELLOW, COLOR_RESET
use fpm_compile_commands, only: compile_command_t, compile_command_table_t
implicit none
private
public build_progress_t
!> Build progress object
type build_progress_t
!> Console object for updating console lines
type(console_t) :: console
!> Number of completed targets
integer :: n_complete
!> Total number of targets scheduled
integer :: n_target
!> 'Plain' output (no colors or updating)
logical :: plain_mode = .true.
!> Store needed when updating previous console lines
integer, allocatable :: output_lines(:)
!> Build directory
character(:), allocatable :: build_dir
!> Queue of scheduled build targets
type(build_target_ptr), pointer :: target_queue(:)
!> The compile_commands.json table
type(compile_command_table_t) :: compile_commands
contains
!> Output 'compiling' status for build target
procedure :: compiling_status => output_status_compiling
!> Output 'complete' status for build target
procedure :: completed_status => output_status_complete
!> Output finished status for whole package
procedure :: success => output_progress_success
!> Output 'compile_commands.json' to build/ folder
procedure :: dump_commands => output_write_compile_commands
end type build_progress_t
!> Constructor for build_progress_t
interface build_progress_t
procedure :: new_build_progress
end interface build_progress_t
contains
!> Initialise a new build progress object
function new_build_progress(target_queue,plain_mode,build_dir) result(progress)
!> The queue of scheduled targets
type(build_target_ptr), intent(in), target :: target_queue(:)
!> Enable 'plain' output for progress object
logical, intent(in), optional :: plain_mode
!> Build directory
character(*), intent(in), optional :: build_dir
!> Progress object to initialise
type(build_progress_t) :: progress
call progress%compile_commands%destroy()
progress%n_target = size(target_queue,1)
progress%target_queue => target_queue
progress%plain_mode = plain_mode
progress%n_complete = 0
if (present(build_dir)) then
progress%build_dir = build_dir
else
progress%build_dir = "build"
end if
allocate(progress%output_lines(progress%n_target))
end function new_build_progress
!> Output 'compiling' status for build target and overall percentage progress
subroutine output_status_compiling(progress, queue_index)
!> Progress object
class(build_progress_t), intent(inout) :: progress
!> Index of build target in the target queue
integer, intent(in) :: queue_index
character(:), allocatable :: target_name
character(100) :: output_string
character(7) :: overall_progress
associate(target=>progress%target_queue(queue_index)%ptr)
if (allocated(target%source)) then
target_name = basename(target%source%file_name)
else
target_name = basename(target%output_file)
end if
write(overall_progress,'(A,I3,A)') '[',100*progress%n_complete/progress%n_target,'%] '
if (progress%plain_mode) then ! Plain output
!$omp critical
write(*,'(A7,A30)') overall_progress,target_name
!$omp end critical
else ! Pretty output
write(output_string,'(A,T40,A,A)') target_name, COLOR_YELLOW//'compiling...'//COLOR_RESET
call progress%console%write_line(trim(output_string),progress%output_lines(queue_index))
call progress%console%write_line(overall_progress//'Compiling...',advance=.false.)
end if
end associate
end subroutine output_status_compiling
!> Output 'complete' status for build target and update overall percentage progress
subroutine output_status_complete(progress, queue_index, build_stat)
!> Progress object
class(build_progress_t), intent(inout) :: progress
!> Index of build target in the target queue
integer, intent(in) :: queue_index
!> Build status flag
integer, intent(in) :: build_stat
character(:), allocatable :: target_name
character(100) :: output_string
character(7) :: overall_progress
!$omp critical
progress%n_complete = progress%n_complete + 1
!$omp end critical
associate(target=>progress%target_queue(queue_index)%ptr)
if (allocated(target%source)) then
target_name = basename(target%source%file_name)
else
target_name = basename(target%output_file)
end if
if (build_stat == 0) then
write(output_string,'(A,T40,A,A)') target_name,COLOR_GREEN//'done.'//COLOR_RESET
else
write(output_string,'(A,T40,A,A)') target_name,COLOR_RED//'failed.'//COLOR_RESET
end if
write(overall_progress,'(A,I3,A)') '[',100*progress%n_complete/progress%n_target,'%] '
if (progress%plain_mode) then ! Plain output
!$omp critical
write(*,'(A7,A30,A7)') overall_progress,target_name, 'done.'
!$omp end critical
else ! Pretty output
call progress%console%update_line(progress%output_lines(queue_index),trim(output_string))
call progress%console%write_line(overall_progress//'Compiling...',advance=.false.)
end if
end associate
end subroutine output_status_complete
!> Output finished status for whole package
subroutine output_progress_success(progress)
class(build_progress_t), intent(inout) :: progress
if (progress%plain_mode) then ! Plain output
write(*,'(A)') '[100%] Project compiled successfully.'
else ! Pretty output
write(*,'(A)') LINE_RESET//COLOR_GREEN//'[100%] Project compiled successfully.'//COLOR_RESET
end if
end subroutine output_progress_success
!> Write compile commands table
subroutine output_write_compile_commands(progress,error)
class(build_progress_t), intent(inout) :: progress
character(:), allocatable :: path
type(error_t), allocatable :: error
! Write compile commands
path = join_path(progress%build_dir,'compile_commands.json')
call progress%compile_commands%write(filename=path, error=error)
end subroutine output_write_compile_commands
end module fpm_backend_output
fortran-lang-fpm-90bb83a/src/fpm/ 0000775 0001750 0001750 00000000000 15145116760 017041 5 ustar alastair alastair fortran-lang-fpm-90bb83a/src/fpm/installer.f90 0000664 0001750 0001750 00000033002 15145116760 021354 0 ustar alastair alastair !> 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, OS_WINDOWS, OS_MACOS
use fpm_error, only : error_t, fatal_error
use fpm_targets, only: build_target_t, FPM_TARGET_ARCHIVE, FPM_TARGET_SHARED, FPM_TARGET_NAME
use fpm_filesystem, only : join_path, mkdir, exists, unix_path, windows_path, get_local_prefix, &
basename
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
!> Test program directory relative to the installation prefix
character(len=:), allocatable :: testdir
!> Include directory relative to the installation prefix
character(len=:), allocatable :: includedir
!> Module directory relative to the installation prefix
character(len=:), allocatable :: moduledir
!> 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
!> Command to move objects into the installation prefix
character(len=:), allocatable :: move
!> Cached operating system
integer :: os
contains
!> Evaluate the installation path
procedure :: install_destination
!> 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 module in its correct subdirectory
procedure :: install_module
!> Install a test program in its correct subdirectory
procedure :: install_test
!> 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 test subdirectory
character(len=*), parameter :: default_testdir = "test"
!> Default name of the include subdirectory
character(len=*), parameter :: default_includedir = "include"
!> Default name of the module subdirectory
character(len=*), parameter :: default_moduledir = "include"
!> Copy command on Unix platforms
character(len=*), parameter :: default_copy_unix = "cp"
!> Copy command on Windows platforms
character(len=*), parameter :: default_copy_win = "copy"
!> Copy command on Unix platforms
character(len=*), parameter :: default_force_copy_unix = "cp -f"
!> Copy command on Windows platforms
character(len=*), parameter :: default_force_copy_win = "copy /Y"
!> Move command on Unix platforms
character(len=*), parameter :: default_move_unix = "mv"
!> Move command on Windows platforms
character(len=*), parameter :: default_move_win = "move"
contains
!> Create a new instance of an installer
subroutine new_installer(self, prefix, bindir, libdir, includedir, moduledir, testdir, verbosity, &
copy, move)
!> 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
!> Module directory relative to the installation prefix
character(len=*), intent(in), optional :: moduledir
!> Test directory relative to the installation prefix
character(len=*), intent(in), optional :: testdir
!> Verbosity of the installer
integer, intent(in), optional :: verbosity
!> Copy command
character(len=*), intent(in), optional :: copy
!> Move command
character(len=*), intent(in), optional :: move
self%os = get_os_type()
! By default, never prompt the user for overwrites
if (present(copy)) then
self%copy = copy
else
if (os_is_unix(self%os)) then
self%copy = default_force_copy_unix
else
self%copy = default_force_copy_win
end if
end if
if (present(move)) then
self%move = move
else
if (os_is_unix(self%os)) then
self%move = default_move_unix
else
self%move = default_move_win
end if
end if
if (present(includedir)) then
self%includedir = includedir
else
self%includedir = default_includedir
end if
if (present(moduledir)) then
self%moduledir = moduledir
else
self%moduledir = default_moduledir
end if
if (present(testdir)) then
self%testdir = testdir
else
self%testdir = default_testdir
end if
if (present(prefix)) then
self%prefix = prefix
else
self%prefix = get_local_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
!> 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
character(len=:), allocatable :: exe_path, cmd
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)
if (allocated(error)) return
! on MacOS, add two relative paths for search of dynamic library dependencies:
add_rpath: if (self%os==OS_MACOS) then
exe_path = join_path(self%install_destination(self%bindir) , basename(executable))
! First path: for bin/lib/include structure
cmd = "install_name_tool -add_rpath @executable_path/../lib " // exe_path
call self%run(cmd, error)
if (allocated(error)) return
! Second path: same as executable folder
cmd = "install_name_tool -add_rpath @executable_path " // exe_path
call self%run(cmd, error)
if (allocated(error)) return
end if add_rpath
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
!> Library target
type(build_target_t), intent(in) :: library
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(:), allocatable :: def_file, implib_file
select case (library%target_type)
case (FPM_TARGET_ARCHIVE)
call self%install(library%output_file, self%libdir, error)
case (FPM_TARGET_SHARED)
call self%install(library%output_file, self%libdir, error)
! Handle shared library side-files only on Windows
if (self%os==OS_WINDOWS) then
! Try both compiler-dependent import library names
implib_file = join_path(library%output_dir, library%package_name // ".dll.a")
if (exists(implib_file)) then
call self%install(implib_file, self%libdir, error)
if (allocated(error)) return
else
implib_file = join_path(library%output_dir, library%package_name // ".lib")
if (exists(implib_file)) call self%install(implib_file, self%libdir, error)
if (allocated(error)) return
endif
end if
case default
call fatal_error(error,"Installer error: "//library%package_name//" is a "// &
FPM_TARGET_NAME(library%target_type)//", not a library")
return
end select
end subroutine install_library
!> Install a test program in its correct subdirectory
subroutine install_test(self, test, error)
!> Instance of the installer
class(installer_t), intent(inout) :: self
!> Path to the test executable
character(len=*), intent(in) :: test
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: ll
if (.not.os_is_unix(self%os)) then
ll = len(test)
if (test(max(1, ll-3):ll) /= ".exe") then
call self%install(test//".exe", self%testdir, error)
return
end if
end if
call self%install(test, self%testdir, error)
end subroutine install_test
!> 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 module in its correct subdirectory
subroutine install_module(self, module, error)
!> Instance of the installer
class(installer_t), intent(inout) :: self
!> Path to the module
character(len=*), intent(in) :: module
!> Error handling
type(error_t), allocatable, intent(out) :: error
call self%install(module, self%moduledir, error)
end subroutine install_module
!> 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 = self%install_destination(destination)
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
! Use force-copy to never prompt the user for overwrite if a package was already installed
call self%run(self%copy//' "'//source//'" "'//install_dest//'"', error)
if (allocated(error)) return
end subroutine install
!> Evaluate the installation path
function install_destination(self, destination) result(install_dest)
!> Instance of the installer
class(installer_t), intent(inout) :: self
!> Path to the destination inside the prefix
character(len=*), intent(in) :: destination
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
end function install_destination
!> 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
fortran-lang-fpm-90bb83a/src/fpm/manifest.f90 0000664 0001750 0001750 00000023145 15145116760 021174 0 ustar alastair alastair !> 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_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_preprocess, only : preprocess_config_t
use fpm_manifest_package, only : package_config_t, new_package
use fpm_error, only : error_t, fatal_error
use tomlf, only : toml_table
use fpm_toml, only : read_package_file
use fpm_manifest_test, only : test_config_t
use fpm_filesystem, only: join_path, exists, dirname, is_dir
use fpm_environment, only: os_is_unix
use fpm_strings, only: string_t
implicit none
private
public :: get_package_data, default_executable, default_library, default_test
public :: get_package_dependencies
public :: default_example
public :: package_config_t, dependency_config_t, preprocess_config_t
contains
!> Populate library in case we find the default src directory
subroutine default_library(self)
!> Instance of the library meta data
type(library_config_t), intent(out) :: self
self%source_dir = "src"
self%include_dir = [string_t("include")]
self%lib_type = [string_t("monolithic")]
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, dirname(file), 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
! Return an array of all dependencies in the manifest
subroutine get_package_dependencies(package, main, deps)
!> Parsed package meta data
type(package_config_t), intent(in) :: package
!> Is the main project
logical, intent(in) :: main
!> Unprocessed list of all dependencies listed in this manifest
type(dependency_config_t), allocatable, intent(out) :: deps(:)
integer :: ndeps,k
ndeps = 0
if (allocated(package%dependency)) &
ndeps = ndeps + size(package%dependency)
if (main) then
if (allocated(package%dev_dependency)) &
ndeps = ndeps + size(package%dev_dependency)
if (allocated(package%example)) then
do k = 1, size(package%example)
if (allocated(package%example(k)%dependency)) &
ndeps = ndeps + size(package%example(k)%dependency)
end do
end if
if (allocated(package%executable)) then
do k = 1, size(package%executable)
if (allocated(package%executable(k)%dependency)) &
ndeps = ndeps + size(package%executable(k)%dependency)
end do
end if
if (allocated(package%test)) then
do k = 1, size(package%test)
if (allocated(package%test(k)%dependency)) &
ndeps = ndeps + size(package%test(k)%dependency)
end do
end if
endif
allocate(deps(ndeps))
if (ndeps > 0) then
ndeps = 0
if (allocated(package%dependency)) &
call collect(deps,ndeps,package%dependency)
if (main) then
if (allocated(package%dev_dependency)) &
call collect(deps,ndeps,package%dev_dependency)
if (allocated(package%example)) then
do k = 1, size(package%example)
if (allocated(package%example(k)%dependency)) &
call collect(deps,ndeps,package%example(k)%dependency)
end do
end if
if (allocated(package%executable)) then
do k = 1, size(package%executable)
if (allocated(package%executable(k)%dependency)) &
call collect(deps,ndeps,package%executable(k)%dependency)
end do
end if
if (allocated(package%test)) then
do k = 1, size(package%test)
if (allocated(package%test(k)%dependency)) &
call collect(deps,ndeps,package%test(k)%dependency)
end do
end if
endif
endif
contains
! Add dependencies to the list
pure subroutine collect(list, nreq, new_deps)
type(dependency_config_t), intent(inout) :: list(:)
integer, intent(inout) :: nreq
type(dependency_config_t), intent(in) :: new_deps(:)
integer :: i
do i = 1, size(new_deps)
nreq = nreq + 1
list(nreq) = new_deps(i)
end do
end subroutine collect
end subroutine get_package_dependencies
end module fpm_manifest
fortran-lang-fpm-90bb83a/src/fpm/git.f90 0000664 0001750 0001750 00000034403 15145116760 020150 0 ustar alastair alastair !> Implementation for interacting with git repositories.
module fpm_git
use fpm_error, only: error_t, fatal_error
use fpm_filesystem, only : get_temp_filename, getline, join_path, execute_and_read_output, run
use tomlf, only: toml_table, toml_stat
use fpm_toml, only: serializable_t, get_value, set_value, set_string
implicit none
public :: git_target_t, git_target_default, git_target_branch, git_target_tag, git_target_revision, git_revision, &
& git_archive, git_matches_manifest, compressed_package_name
!> Name of the compressed package that is generated temporarily.
character(len=*), parameter :: compressed_package_name = 'compressed_package'
!> 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
!> Invalid descriptor
integer :: error = -999
end type enum_descriptor
!> Actual enumerator for descriptors
type(enum_descriptor), parameter :: git_descriptor = enum_descriptor()
!> Description of an git target
type, extends(serializable_t) :: git_target_t
!> Kind of the git target
integer :: 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
!> Serialization interface
procedure :: serializable_is_same => git_is_same
procedure :: dump_to_toml
procedure :: load_from_toml
end type git_target_t
!> Common output format for writing to the command line
character(len=*), parameter :: out_fmt = '("#", *(1x, g0))'
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
!> Check that two git targets are equal
logical function git_is_same(this,that)
class(git_target_t), intent(in) :: this
class(serializable_t), intent(in) :: that
git_is_same = .false.
select type (other=>that)
type is (git_target_t)
if (.not.(this%descriptor==other%descriptor)) return
if (allocated(this%url) .neqv. allocated(other%url)) return
if (allocated(this%url)) then
if (.not.(this%url==other%url)) return
end if
if (allocated(this%object) .neqv. allocated(other%object)) return
if (allocated(this%object)) then
if (.not.(this%object==other%object)) return
end if
class default
! Not the same type
return
end select
!> All checks passed!
git_is_same = .true.
end function git_is_same
!> Check that a cached dependency matches a manifest request
logical function git_matches_manifest(cached,manifest,verbosity,iunit)
!> Two input git targets
type(git_target_t), intent(in) :: cached,manifest
integer, intent(in) :: verbosity,iunit
git_matches_manifest = cached%url == manifest%url
if (.not.git_matches_manifest) then
if (verbosity>1) write(iunit,out_fmt) "GIT URL has changed: ",cached%url," vs. ", manifest%url
return
endif
!> The manifest dependency only contains partial information (what's requested),
!> while the cached dependency always stores a commit hash because it's built
!> after the repo is available (saved as git_descriptor%revision==revision).
!> So, comparing against the descriptor is not reliable
git_matches_manifest = allocated(cached%object) .eqv. allocated(manifest%object)
if (git_matches_manifest .and. allocated(cached%object)) &
git_matches_manifest = cached%object == manifest%object
if (.not.git_matches_manifest) then
if (verbosity>1) write(iunit,out_fmt) "GIT OBJECT has changed: ",cached%object," vs. ", manifest%object
end if
end function git_matches_manifest
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, workdir
if (allocated(self%object)) then
object = self%object
else
object = 'HEAD'
end if
workdir = "--work-tree="//local_path//" --git-dir="//join_path(local_path, ".git")
call execute_command_line("git 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 "//workdir//" fetch --depth=1 "// &
self%url//" "//object, exitstat=stat)
if (stat /= 0) then
call fatal_error(error,'Error while fetching git repository for remote dependency')
return
end if
call execute_command_line("git "//workdir//" 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, workdir
character(len=*), parameter :: hexdigits = '0123456789abcdef'
workdir = "--work-tree="//local_path//" --git-dir="//join_path(local_path, ".git")
allocate(temp_file, source=get_temp_filename())
line = "git "//workdir//" log -n 1 > "//temp_file
call execute_command_line(line, exitstat=stat)
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
!> Dump dependency to toml table
subroutine dump_to_toml(self, table, error)
!> Instance of the serializable object
class(git_target_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: ierr
call set_string(table, "descriptor", descriptor_name(self%descriptor), error, 'git_target_t')
if (allocated(error)) return
call set_string(table, "url", self%url, error, 'git_target_t')
if (allocated(error)) return
call set_string(table, "object", self%object, error, 'git_target_t')
if (allocated(error)) return
end subroutine dump_to_toml
!> Read dependency from toml table (no checks made at this stage)
subroutine load_from_toml(self, table, error)
!> Instance of the serializable object
class(git_target_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Local variables
character(len=:), allocatable :: descriptor_name
call get_value(table, "descriptor", descriptor_name)
self%descriptor = parse_descriptor(descriptor_name)
if (self%descriptor==git_descriptor%error) then
call fatal_error(error,"invalid descriptor ID <"//descriptor_name//"> in TOML entry")
return
end if
!> Target URL of the git repository
call get_value(table, "url", self%url)
!> Additional descriptor of the git object
call get_value(table,"object", self%object)
end subroutine load_from_toml
!> Parse git descriptor identifier from a string
pure integer function parse_descriptor(name)
character(len=*), intent(in) :: name
select case (name)
case ("default"); parse_descriptor = git_descriptor%default
case ("branch"); parse_descriptor = git_descriptor%branch
case ("tag"); parse_descriptor = git_descriptor%tag
case ("revision"); parse_descriptor = git_descriptor%revision
case default; parse_descriptor = git_descriptor%error
end select
end function parse_descriptor
!> Code git descriptor to a string
pure function descriptor_name(descriptor) result(name)
integer, intent(in) :: descriptor
character(len=:), allocatable :: name
select case (descriptor)
case (git_descriptor%default); name = "default"
case (git_descriptor%branch); name = "branch"
case (git_descriptor%tag); name = "tag"
case (git_descriptor%revision); name = "revision"
case default; name = "ERROR"
end select
end function descriptor_name
!> Archive a folder using `git archive`.
subroutine git_archive(source, destination, ref, additional_files, verbose, error)
!> Directory to archive.
character(*), intent(in) :: source
!> Destination of the archive.
character(*), intent(in) :: destination
!> (Symbolic) Reference to be archived.
character(*), intent(in) :: ref
!> (Optional) list of additional untracked files to be added to the archive.
character(*), optional, intent(in) :: additional_files(:)
!> Print additional information if true.
logical, intent(in) :: verbose
!> Error handling.
type(error_t), allocatable, intent(out) :: error
integer :: stat,i
character(len=:), allocatable :: cmd_output, archive_format, add_files
call execute_and_read_output('git archive -l', cmd_output, error, verbose)
if (allocated(error)) return
if (index(cmd_output, 'tar.gz') /= 0) then
archive_format = 'tar.gz'
else
call fatal_error(error, "Cannot find a suitable archive format for 'git archive'."); return
end if
allocate(character(len=0) :: add_files)
if (present(additional_files)) then
do i=1,size(additional_files)
add_files = trim(add_files)//' --add-file='//adjustl(additional_files(i))
end do
endif
call run('git archive '//ref//' &
& --format='//archive_format// &
& add_files//' &
& -o '//destination, &
& echo=verbose, &
& exitstat=stat)
if (stat /= 0) then
call fatal_error(error, "Error packing '"//source//"'."); return
end if
end
end module fpm_git
fortran-lang-fpm-90bb83a/src/fpm/downloader.f90 0000664 0001750 0001750 00000010354 15145116760 021522 0 ustar alastair alastair module fpm_downloader
use fpm_error, only: error_t, fatal_error
use fpm_filesystem, only: which, run
use fpm_versioning, only: version_t
use jonquil, only: json_object, json_value, json_error, json_load, cast_to_object
use fpm_strings, only: string_t
implicit none
private
public :: downloader_t
!> This type could be entirely avoided but it is quite practical because it can be mocked for testing.
type downloader_t
contains
procedure, nopass :: get_pkg_data, get_file, upload_form, unpack
end type
contains
!> Perform an http get request, save output to file, and parse json.
subroutine get_pkg_data(url, version, tmp_pkg_file, json, error)
character(*), intent(in) :: url
type(version_t), allocatable, intent(in) :: version
character(*), intent(in) :: tmp_pkg_file
type(json_object), intent(out) :: json
type(error_t), allocatable, intent(out) :: error
class(json_value), allocatable :: j_value
type(json_object), pointer :: ptr
type(json_error), allocatable :: j_error
if (allocated(version)) then
! Request specific version.
call get_file(url//'/'//version%s(), tmp_pkg_file, error)
else
! Request latest version.
call get_file(url, tmp_pkg_file, error)
end if
if (allocated(error)) return
call json_load(j_value, tmp_pkg_file, error=j_error)
if (allocated(j_error)) then
allocate (error); call move_alloc(j_error%message, error%message); call json%destroy(); return
end if
ptr => cast_to_object(j_value)
if (.not. associated(ptr)) then
call fatal_error(error, "Error parsing JSON from '"//url//"'."); return
end if
json = ptr
end
!> Download a file from a url using either curl or wget.
subroutine get_file(url, tmp_pkg_file, error)
character(*), intent(in) :: url
character(*), intent(in) :: tmp_pkg_file
type(error_t), allocatable, intent(out) :: error
integer :: stat
if (which('curl') /= '') then
print *, "Downloading '"//url//"' -> '"//tmp_pkg_file//"'"
call execute_command_line('curl '//url//' -s -o '//tmp_pkg_file, exitstat=stat)
else if (which('wget') /= '') then
print *, "Downloading '"//url//"' -> '"//tmp_pkg_file//"'"
call execute_command_line('wget '//url//' -q -O '//tmp_pkg_file, exitstat=stat)
else
call fatal_error(error, "Neither 'curl' nor 'wget' installed."); return
end if
if (stat /= 0) then
call fatal_error(error, "Error downloading package from '"//url//"'."); return
end if
end
!> Perform an http post request with form data.
subroutine upload_form(endpoint, form_data, verbose, error)
!> Endpoint to upload to.
character(len=*), intent(in) :: endpoint
!> Form data to upload.
type(string_t), intent(in) :: form_data(:)
!> Print additional information if true.
logical, intent(in) :: verbose
!> Error handling.
type(error_t), allocatable, intent(out) :: error
integer :: stat, i
character(len=:), allocatable :: form_data_str
form_data_str = ''
do i = 1, size(form_data)
form_data_str = form_data_str//"-F '"//form_data(i)%s//"' "
end do
if (which('curl') /= '') then
print *, 'Uploading package ...'
call run('curl -X POST -H "Content-Type: multipart/form-data" '// &
& form_data_str//endpoint, exitstat=stat, echo=verbose)
else
call fatal_error(error, "'curl' not installed."); return
end if
if (stat /= 0) then
call fatal_error(error, "Error uploading package to registry."); return
end if
end
!> Unpack a tarball to a destination.
subroutine unpack(tmp_pkg_file, destination, error)
!> Path to tarball.
character(*), intent(in) :: tmp_pkg_file
!> Destination to unpack to.
character(*), intent(in) :: destination
!> Error handling.
type(error_t), allocatable, intent(out) :: error
integer :: stat
if (which('tar') == '') then
call fatal_error(error, "'tar' not installed."); return
end if
print *, "Unpacking '"//tmp_pkg_file//"' to '"//destination//"' ..."
call execute_command_line('tar -zxf '//tmp_pkg_file//' -C '//destination, exitstat=stat)
if (stat /= 0) then
call fatal_error(error, "Error unpacking '"//tmp_pkg_file//"'."); return
end if
end
end
fortran-lang-fpm-90bb83a/src/fpm/manifest/ 0000775 0001750 0001750 00000000000 15145116760 020647 5 ustar alastair alastair fortran-lang-fpm-90bb83a/src/fpm/manifest/feature.f90 0000664 0001750 0001750 00000131111 15145116760 022620 0 ustar alastair alastair !> Implementation of the meta data for features.
!>
!> A feature is a configurable set of package properties that can be
!> conditionally enabled. Features allow fine-grained control over
!> dependencies, compiler flags, preprocessor definitions, and other
!> package components based on the target compiler and operating system.
!>
!> Features are similar to Rust Cargo features but adapted for Fortran
!> package management. Each feature can specify:
!> - Compiler-specific flags and settings
!> - Additional dependencies
!> - Preprocessor definitions
!> - Source files and build configurations
!>
!> A feature table can currently have the following fields:
!>
!>```toml
!>[features.mpi]
!>description = "Enable MPI parallel support"
!>compiler = "gfortran"
!>os = "linux"
!>flags = "-fopenmp"
!>preprocessor = ["WITH_MPI"]
!>[features.mpi.dependencies]
!>mpi = { git = "https://github.com/fortran-lang/mpi" }
!>```
!>
module fpm_manifest_feature
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_fortran, only: fortran_config_t, new_fortran_config
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_manifest_preprocess, only: preprocess_config_t, new_preprocessors
use fpm_manifest_metapackages, only: metapackage_config_t, new_meta_config
use fpm_manifest_platform, only: platform_config_t
use fpm_error, only: error_t, fatal_error, syntax_error
use fpm_environment, only: OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, OS_CYGWIN, OS_SOLARIS, &
OS_FREEBSD, OS_OPENBSD, OS_ALL, OS_NAME, match_os_type
use fpm_compiler, only: compiler_enum, compiler_id_name, match_compiler_type, id_all
use fpm_strings, only: string_t, lower, operator(==)
use tomlf, only: toml_table, toml_array, toml_key, toml_stat
use fpm_toml, only: get_value, len, serializable_t, set_value, set_string, set_list, add_table, &
get_list
implicit none
private
public :: feature_config_t, new_feature, new_features, find_feature, init_feature_components, &
unique_programs
!> Feature configuration data
type, extends(serializable_t) :: feature_config_t
!> Feature identity
character(len=:), allocatable :: name
character(len=:), allocatable :: description
!> Compiler/OS targeting (consistent with profile_config_t pattern)
type(platform_config_t) :: platform
!> Build configuration
type(build_config_t), allocatable :: build
!> Installation configuration
type(install_config_t), allocatable :: install
!> Fortran configuration
type(fortran_config_t), allocatable :: fortran
!> Library configuration
type(library_config_t), allocatable :: library
!> Executable configurations
type(executable_config_t), allocatable :: executable(:)
!> Dependencies
type(dependency_config_t), allocatable :: dependency(:)
!> Development dependencies
type(dependency_config_t), allocatable :: dev_dependency(:)
!> Examples
type(example_config_t), allocatable :: example(:)
!> Tests
type(test_config_t), allocatable :: test(:)
!> Preprocessor configuration
type(preprocess_config_t), allocatable :: preprocess(:)
!> Metapackage data
type(metapackage_config_t) :: meta
!> Compiler flags
character(len=:), allocatable :: flags
character(len=:), allocatable :: c_flags
character(len=:), allocatable :: cxx_flags
character(len=:), allocatable :: link_time_flags
!> Feature dependencies (not active yet)
type(string_t), allocatable :: requires_features(:)
contains
!> Print information on this instance
procedure :: info
!> Check validity of the TOML table
procedure, nopass :: check
!> Get manifest name
procedure :: manifest_name
!> Check if there is a cpp configuration
procedure :: has_cpp
!> Serialization interface
procedure :: serializable_is_same => feature_is_same
procedure :: dump_to_toml
procedure :: load_from_toml
end type feature_config_t
character(len=*), parameter, private :: class_name = 'feature_config_t'
interface unique_programs
module procedure :: unique_programs1
module procedure :: unique_programs2
end interface unique_programs
contains
!> Construct a new feature configuration from a TOML data structure
subroutine new_feature(self, table, root, error, name)
!> Instance of the feature configuration
type(feature_config_t), intent(out) :: self
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> Root directory of the manifest
character(len=*), intent(in), optional :: root
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional name override (if not provided, gets from table key)
character(len=*), intent(in), optional :: name
type(toml_table), pointer :: child, node
type(toml_array), pointer :: children
character(len=:), allocatable :: compiler_name, os_name
integer :: ii, nn, stat
! Only check schema for pure features (not when called from package)
if (.not. present(name)) then
call check(table, error)
if (allocated(error)) return
end if
! Get feature name from parameter or table key
if (present(name)) then
self%name = name
else
call table%get_key(self%name)
end if
! Initialize common components
call init_feature_components(self, table, root=root, error=error)
if (allocated(error)) return
! For features, get platform configuration (optional for packages)
if (.not. present(name)) then
call get_value(table, "platform", child, requested=.false., stat=stat)
if (stat == toml_stat%success .and. associated(child)) then
call self%platform%load_from_toml(child, error)
if (allocated(error)) return
end if
end if
end subroutine new_feature
!> 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) then
call syntax_error(error, "Feature table 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 feature table")
exit
! Keys
case("description", "platform", "flags", "c-flags", &
"cxx-flags", "link-time-flags", "preprocessor", "requires", &
"build", "install", "fortran", "library", "dependencies", &
"dev-dependencies", "executable", "example", "test", "preprocess")
continue
! OS names (lowercase)
case("linux", "macos", "windows", "cygwin", "solaris", "freebsd", "openbsd")
continue
! Compiler names
case ("gfortran", "f95", "caf", "ifort", "ifx", "pgfortran", "nvfortran", "nagfor", &
"flang", "flang-new", "f18", "xlf90", "lfortran")
continue
! Standard feature configuration names
case("debug", "release")
continue
end select
end do
end subroutine check
!> Construct new feature array from a TOML data structure
subroutine new_features(features, table, root, error)
!> Instance of the feature configuration array
type(feature_config_t), allocatable, intent(out) :: features(:)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> Root directory of the manifest
character(len=*), intent(in), optional :: root
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table), pointer :: node
type(toml_key), allocatable :: list(:)
integer :: ifeature, stat
call table%get_keys(list)
if (size(list) < 1) then
allocate(features(0))
return
end if
allocate(features(size(list)))
do ifeature = 1, size(list)
call get_value(table, list(ifeature)%key, node, stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Feature "//list(ifeature)%key//" must be a table entry")
exit
end if
call new_feature(features(ifeature), node, root, error)
if (allocated(error)) exit
end do
end subroutine new_features
!> Find matching feature configuration (similar to find_profile)
subroutine find_feature(features, feature_name, current_platform, found, chosen_feature)
type(feature_config_t), allocatable, intent(in) :: features(:)
character(*), intent(in) :: feature_name
type(platform_config_t), intent(in) :: current_platform
logical, intent(out) :: found
type(feature_config_t), intent(out) :: chosen_feature
integer :: i
found = .false.
if (size(features) < 1) return
! Try to find exact match (feature + compiler + OS)
do i = 1, size(features)
if (features(i)%name == feature_name .and. &
features(i)%platform%matches(current_platform)) then
chosen_feature = features(i)
found = .true.
return
end if
end do
! Try to find compiler match with OS_ALL
do i = 1, size(features)
if (features(i)%name == feature_name .and. &
features(i)%platform%matches(current_platform)) then
chosen_feature = features(i)
found = .true.
return
end if
end do
! Try to find COMPILER_ALL match
do i = 1, size(features)
if (features(i)%name == feature_name .and. &
features(i)%platform%matches(current_platform)) then
chosen_feature = features(i)
found = .true.
return
end if
end do
end subroutine find_feature
!> Write information on instance
subroutine info(self, unit, verbosity)
!> Instance of the feature configuration
class(feature_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) "Feature"
if (allocated(self%name)) then
write(unit, fmt) "- name", self%name
end if
if (allocated(self%description)) then
write(unit, fmt) "- description", self%description
end if
call self%platform%info(unit, verbosity)
if (allocated(self%flags)) then
write(unit, fmt) "- flags", self%flags
end if
if (allocated(self%c_flags)) then
write(unit, fmt) "- c-flags", self%c_flags
end if
if (allocated(self%cxx_flags)) then
write(unit, fmt) "- cxx-flags", self%cxx_flags
end if
if (allocated(self%link_time_flags)) then
write(unit, fmt) "- link-time-flags", self%link_time_flags
end if
if (allocated(self%build)) then
call self%build%info(unit, pr - 1)
end if
if (allocated(self%install)) then
call self%install%info(unit, pr - 1)
end if
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
end subroutine info
!> Check that two feature configs are equal
logical function feature_is_same(this, that)
class(feature_config_t), intent(in) :: this
class(serializable_t), intent(in) :: that
integer :: ii
feature_is_same = .false.
select type (other=>that)
type is (feature_config_t)
if (allocated(this%name).neqv.allocated(other%name)) return
if (allocated(this%name)) then
if (.not.(this%name==other%name)) return
end if
if (allocated(this%description).neqv.allocated(other%description)) return
if (allocated(this%description)) then
if (.not.(this%description==other%description)) return
end if
if (.not.this%platform == other%platform) return
if (allocated(this%build).neqv.allocated(other%build)) return
if (allocated(this%build)) then
if (.not.(this%build==other%build)) return
end if
if (allocated(this%install).neqv.allocated(other%install)) return
if (allocated(this%install)) then
if (.not.(this%install==other%install)) return
end if
if (allocated(this%fortran).neqv.allocated(other%fortran)) return
if (allocated(this%fortran)) then
if (.not.(this%fortran==other%fortran)) return
end if
if (allocated(this%library).neqv.allocated(other%library)) return
if (allocated(this%library)) then
if (.not.(this%library==other%library)) return
end if
if (allocated(this%executable).neqv.allocated(other%executable)) return
if (allocated(this%executable)) then
if (.not.(size(this%executable)==size(other%executable))) return
do ii = 1, size(this%executable)
if (.not.(this%executable(ii)==other%executable(ii))) return
end do
end if
if (allocated(this%dependency).neqv.allocated(other%dependency)) return
if (allocated(this%dependency)) then
if (.not.(size(this%dependency)==size(other%dependency))) return
do ii = 1, size(this%dependency)
if (.not.(this%dependency(ii)==other%dependency(ii))) return
end do
end if
if (allocated(this%dev_dependency).neqv.allocated(other%dev_dependency)) return
if (allocated(this%dev_dependency)) then
if (.not.(size(this%dev_dependency)==size(other%dev_dependency))) return
do ii = 1, size(this%dev_dependency)
if (.not.(this%dev_dependency(ii)==other%dev_dependency(ii))) return
end do
end if
if (allocated(this%example).neqv.allocated(other%example)) return
if (allocated(this%example)) then
if (.not.(size(this%example)==size(other%example))) return
do ii = 1, size(this%example)
if (.not.(this%example(ii)==other%example(ii))) return
end do
end if
if (allocated(this%test).neqv.allocated(other%test)) return
if (allocated(this%test)) then
if (.not.(size(this%test)==size(other%test))) return
do ii = 1, size(this%test)
if (.not.(this%test(ii)==other%test(ii))) return
end do
end if
if (allocated(this%preprocess).neqv.allocated(other%preprocess)) return
if (allocated(this%preprocess)) then
if (.not.(size(this%preprocess)==size(other%preprocess))) return
do ii = 1, size(this%preprocess)
if (.not.(this%preprocess(ii)==other%preprocess(ii))) return
end do
end if
if (allocated(this%flags).neqv.allocated(other%flags)) return
if (allocated(this%flags)) then
if (.not.(this%flags==other%flags)) return
end if
if (allocated(this%c_flags).neqv.allocated(other%c_flags)) return
if (allocated(this%c_flags)) then
if (.not.(this%c_flags==other%c_flags)) return
end if
if (allocated(this%cxx_flags).neqv.allocated(other%cxx_flags)) return
if (allocated(this%cxx_flags)) then
if (.not.(this%cxx_flags==other%cxx_flags)) return
end if
if (allocated(this%link_time_flags).neqv.allocated(other%link_time_flags)) return
if (allocated(this%link_time_flags)) then
if (.not.(this%link_time_flags==other%link_time_flags)) return
end if
if (allocated(this%requires_features).neqv.allocated(other%requires_features)) return
if (allocated(this%requires_features)) then
if (.not.(size(this%requires_features)==size(other%requires_features))) return
do ii = 1, size(this%requires_features)
if (.not.(this%requires_features(ii)==other%requires_features(ii))) return
end do
end if
if (.not.this%meta==other%meta) return
class default
return
end select
feature_is_same = .true.
end function feature_is_same
!> Dump feature to toml table
subroutine dump_to_toml(self, table, error)
!> Instance of the serializable object
class(feature_config_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, ptr_pkg
character(30) :: unnamed
call set_string(table, "name", self%name, error, class_name)
if (allocated(error)) return
call set_string(table, "description", self%description, error, class_name)
if (allocated(error)) return
call add_table(table, "platform", ptr, error, class_name)
if (allocated(error)) return
call self%platform%dump_to_toml(ptr, error)
if (allocated(error)) return
call set_string(table, "flags", self%flags, error, class_name)
if (allocated(error)) return
call set_string(table, "c-flags", self%c_flags, error, class_name)
if (allocated(error)) return
call set_string(table, "cxx-flags", self%cxx_flags, error, class_name)
if (allocated(error)) return
call set_string(table, "link-time-flags", self%link_time_flags, error, class_name)
if (allocated(error)) return
call set_list(table, "requires", self%requires_features, error)
if (allocated(error)) return
if (allocated(self%build)) then
call add_table(table, "build", ptr, error, class_name)
if (allocated(error)) return
call self%build%dump_to_toml(ptr, error)
if (allocated(error)) return
end if
if (allocated(self%install)) then
call add_table(table, "install", ptr, error, class_name)
if (allocated(error)) return
call self%install%dump_to_toml(ptr, error)
if (allocated(error)) return
end if
if (allocated(self%fortran)) then
call add_table(table, "fortran", ptr, error, class_name)
if (allocated(error)) return
call self%fortran%dump_to_toml(ptr, error)
if (allocated(error)) return
end if
if (allocated(self%library)) then
call add_table(table, "library", ptr, error, class_name)
if (allocated(error)) return
call self%library%dump_to_toml(ptr, error)
if (allocated(error)) return
end if
if (allocated(self%executable)) then
call add_table(table, "executable", ptr_pkg)
if (.not. associated(ptr_pkg)) then
call fatal_error(error, class_name//" cannot create 'executable' table ")
return
end if
do ii = 1, size(self%executable)
associate (pkg => self%executable(ii))
!> Because dependencies are named, fallback if this has no name
!> So, serialization will work regardless of size(self%dep) == self%ndep
if (len_trim(pkg%name)==0) then
write(unnamed,1) 'EXECUTABLE',ii
call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(executable)')
else
call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(executable)')
end if
if (allocated(error)) return
call pkg%dump_to_toml(ptr, error)
if (allocated(error)) return
end associate
end do
end if
if (allocated(self%dependency)) then
call add_table(table, "dependencies", ptr_pkg)
if (.not. associated(ptr_pkg)) then
call fatal_error(error, class_name//" cannot create 'dependencies' table ")
return
end if
do ii = 1, size(self%dependency)
associate (pkg => self%dependency(ii))
if (len_trim(pkg%name)==0) then
write(unnamed,1) 'DEPENDENCY',ii
call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(dependencies)')
else
call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(dependencies)')
end if
if (allocated(error)) return
call pkg%dump_to_toml(ptr, error)
if (allocated(error)) return
end associate
end do
end if
if (allocated(self%example)) then
call add_table(table, "example", ptr_pkg)
if (.not. associated(ptr_pkg)) then
call fatal_error(error, class_name//" cannot create 'example' table ")
return
end if
do ii = 1, size(self%example)
associate (pkg => self%example(ii))
!> Because dependencies are named, fallback if this has no name
!> So, serialization will work regardless of size(self%dep) == self%ndep
if (len_trim(pkg%name)==0) then
write(unnamed,1) 'EXAMPLE',ii
call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(example)')
else
call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(example)')
end if
if (allocated(error)) return
call pkg%dump_to_toml(ptr, error)
if (allocated(error)) return
end associate
end do
end if
if (allocated(self%test)) then
call add_table(table, "test", ptr_pkg)
if (.not. associated(ptr_pkg)) then
call fatal_error(error, class_name//" cannot create 'test' table ")
return
end if
do ii = 1, size(self%test)
associate (pkg => self%test(ii))
!> Because dependencies are named, fallback if this has no name
!> So, serialization will work regardless of size(self%dep) == self%ndep
if (len_trim(pkg%name)==0) then
write(unnamed,1) 'TEST',ii
call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(test)')
else
call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(test)')
end if
if (allocated(error)) return
call pkg%dump_to_toml(ptr, error)
if (allocated(error)) return
end associate
end do
end if
if (allocated(self%preprocess)) then
call add_table(table, "preprocess", ptr_pkg)
if (.not. associated(ptr_pkg)) then
call fatal_error(error, class_name//" cannot create 'preprocess' table ")
return
end if
do ii = 1, size(self%preprocess)
associate (pkg => self%preprocess(ii))
!> Because dependencies are named, fallback if this has no name
!> So, serialization will work regardless of size(self%dep) == self%ndep
if (len_trim(pkg%name)==0) then
write(unnamed,1) 'PREPROCESS',ii
call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(preprocess)')
else
call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(preprocess)')
end if
if (allocated(error)) return
call pkg%dump_to_toml(ptr, error)
if (allocated(error)) return
end associate
end do
end if
call add_table(table, "metapackages", ptr, error, class_name)
if (allocated(error)) return
call self%meta%dump_to_toml(ptr, error)
if (allocated(error)) return
1 format('UNNAMED_',a,'_',i0)
end subroutine dump_to_toml
!> Read feature from toml table (no checks made at this stage)
subroutine load_from_toml(self, table, error)
!> Instance of the serializable object
class(feature_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_key), allocatable :: keys(:), pkg_keys(:)
integer :: ii, jj
type(toml_table), pointer :: ptr, ptr_pkg
call table%get_keys(keys)
call get_value(table, "name", self%name)
call get_value(table, "description", self%description)
call get_value(table, "flags", self%flags)
call get_value(table, "c-flags", self%c_flags)
call get_value(table, "cxx-flags", self%cxx_flags)
call get_value(table, "link-time-flags", self%link_time_flags)
call get_list(table, "requires", self%requires_features, error)
if (allocated(error)) return
if (allocated(self%executable)) deallocate(self%executable)
if (allocated(self%dependency)) deallocate(self%dependency)
if (allocated(self%dev_dependency)) deallocate(self%dev_dependency)
if (allocated(self%example)) deallocate(self%example)
if (allocated(self%test)) deallocate(self%test)
if (allocated(self%preprocess)) deallocate(self%preprocess)
do ii = 1, size(keys)
select case (keys(ii)%key)
case ("platform")
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table')
return
end if
call self%platform%load_from_toml(ptr, error)
if (allocated(error)) return
case ("build")
allocate(self%build)
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table')
return
end if
call self%build%load_from_toml(ptr, error)
if (allocated(error)) return
case ("install")
allocate(self%install)
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table')
return
end if
call self%install%load_from_toml(ptr, error)
case ("fortran")
allocate(self%fortran)
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table')
return
end if
call self%fortran%load_from_toml(ptr, error)
case ("library")
allocate(self%library)
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table')
return
end if
call self%library%load_from_toml(ptr, error)
case ("executable")
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,class_name//': error retrieving executable table')
return
end if
!> Read all packages
call ptr%get_keys(pkg_keys)
allocate(self%executable(size(pkg_keys)))
do jj = 1, size(pkg_keys)
call get_value(ptr, pkg_keys(jj), ptr_pkg)
call self%executable(jj)%load_from_toml(ptr_pkg, error)
if (allocated(error)) return
end do
case ("dependencies")
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,class_name//': error retrieving dependency table')
return
end if
!> Read all packages
call ptr%get_keys(pkg_keys)
allocate(self%dependency(size(pkg_keys)))
do jj = 1, size(pkg_keys)
call get_value(ptr, pkg_keys(jj), ptr_pkg)
call self%dependency(jj)%load_from_toml(ptr_pkg, error)
if (allocated(error)) return
end do
case ("dev-dependencies")
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,class_name//': error retrieving dev-dependencies table')
return
end if
!> Read all packages
call ptr%get_keys(pkg_keys)
allocate(self%dev_dependency(size(pkg_keys)))
do jj = 1, size(pkg_keys)
call get_value(ptr, pkg_keys(jj), ptr_pkg)
call self%dev_dependency(jj)%load_from_toml(ptr_pkg, error)
if (allocated(error)) return
end do
case ("example")
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,class_name//': error retrieving example table')
return
end if
!> Read all packages
call ptr%get_keys(pkg_keys)
allocate(self%example(size(pkg_keys)))
do jj = 1, size(pkg_keys)
call get_value(ptr, pkg_keys(jj), ptr_pkg)
call self%example(jj)%load_from_toml(ptr_pkg, error)
if (allocated(error)) return
end do
case ("test")
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,class_name//': error retrieving test table')
return
end if
!> Read all packages
call ptr%get_keys(pkg_keys)
allocate(self%test(size(pkg_keys)))
do jj = 1, size(pkg_keys)
call get_value(ptr, pkg_keys(jj), ptr_pkg)
call self%test(jj)%load_from_toml(ptr_pkg, error)
if (allocated(error)) return
end do
case ("preprocess")
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,class_name//': error retrieving preprocess table')
return
end if
!> Read all packages
call ptr%get_keys(pkg_keys)
allocate(self%preprocess(size(pkg_keys)))
do jj = 1, size(pkg_keys)
call get_value(ptr, pkg_keys(jj), ptr_pkg)
call self%preprocess(jj)%load_from_toml(ptr_pkg, error)
if (allocated(error)) return
end do
case ("metapackages")
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table')
return
end if
call self%meta%load_from_toml(ptr, error)
case default
cycle
end select
end do
end subroutine load_from_toml
!> Initialize the feature components (shared between new_feature and new_package)
subroutine init_feature_components(self, table, platform, root, error)
type(feature_config_t), intent(inout) :: self
type(toml_table), intent(inout) :: table
type(platform_config_t), optional, intent(in) :: platform
character(len=*), intent(in), optional :: root
type(error_t), allocatable, intent(out) :: error
type(toml_table), pointer :: child, node
type(toml_array), pointer :: children
integer :: ii, nn, stat
! Initialize platform with defaults
if (present(platform)) then
self%platform = platform
else
self%platform = platform_config_t(id_all,OS_ALL)
end if
! Get description
call get_value(table, "description", self%description)
! Get compiler flags
call get_value(table, "flags", self%flags)
call get_value(table, "c-flags", self%c_flags)
call get_value(table, "cxx-flags", self%cxx_flags)
call get_value(table, "link-time-flags", self%link_time_flags)
! Get feature dependencies
call get_list(table, "requires", self%requires_features, error)
if (allocated(error)) return
! Get build configuration
call get_value(table, "build", child, requested=.false., stat=stat)
if (stat == toml_stat%success .and. associated(child)) then
allocate(self%build)
call new_build_config(self%build, child, self%name, error)
if (allocated(error)) return
end if
! Get install configuration
call get_value(table, "install", child, requested=.false., stat=stat)
if (stat == toml_stat%success .and. associated(child)) then
allocate(self%install)
call new_install_config(self%install, child, error)
if (allocated(error)) return
end if
! Get Fortran configuration
call get_value(table, "fortran", child, requested=.false., stat=stat)
if (stat == toml_stat%success .and. associated(child)) then
allocate(self%fortran)
call new_fortran_config(self%fortran, child, error)
if (allocated(error)) return
end if
! Get library configuration
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
! Get dependencies and metapackage dependencies
call get_value(table, "dependencies", child, requested=.false.)
if (associated(child)) then
call new_dependencies(self%dependency, child, root, self%meta, error=error)
if (allocated(error)) return
end if
! Get development dependencies
call get_value(table, "dev-dependencies", child, requested=.false.)
if (associated(child)) then
call new_dependencies(self%dev_dependency, child, root, error=error)
if (allocated(error)) return
end if
! Get executables
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
end if
! Get examples
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
end if
! Get tests
call get_value(table, "test", children, requested=.false.)
if (associated(children)) then
nn = len(children)
allocate(self%test(nn))
do ii = 1, nn
call get_value(children, ii, node, stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Could not retrieve test from array entry")
exit
end if
call new_test(self%test(ii), node, error)
if (allocated(error)) exit
end do
if (allocated(error)) return
end if
! Get preprocessors
call get_value(table, "preprocess", child, requested=.false.)
if (associated(child)) then
call new_preprocessors(self%preprocess, child, error)
if (allocated(error)) return
end if
! Validate unique program names
if (allocated(self%executable)) then
call unique_programs(self%executable, error)
if (allocated(error)) return
end if
if (allocated(self%example)) then
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
if (allocated(self%test)) then
call unique_programs(self%test, error)
if (allocated(error)) return
end if
end subroutine init_feature_components
!> 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
!> Return a name string as it would appear in the TOML manifest
function manifest_name(self) result(name)
class(feature_config_t), intent(in) :: self
character(:), allocatable :: name
character(:), allocatable :: platform
platform = self%platform%name()
if (len(platform)>0) then
name = self%name//'.'//platform
else
name = self%name
end if
end function manifest_name
!> Check if there is a CPP preprocessor configuration
elemental logical function has_cpp(self)
class(feature_config_t), intent(in) :: self
integer :: i
has_cpp = .false.
if (.not.allocated(self%preprocess)) return
do i=1,size(self%preprocess)
has_cpp = self%preprocess(i)%is_cpp()
if (has_cpp) return
end do
end function has_cpp
end module fpm_manifest_feature
fortran-lang-fpm-90bb83a/src/fpm/manifest/install.f90 0000664 0001750 0001750 00000012635 15145116760 022644 0 ustar alastair alastair !> Implementation of the installation configuration.
!>
!> An install table can currently have the following fields
!>
!>```toml
!>library = bool
!>module-dir = "path"
!>```
module fpm_manifest_install
use fpm_error, only : error_t, fatal_error, syntax_error
use tomlf, only : toml_table, toml_key, toml_stat
use fpm_toml, only : get_value, set_value, serializable_t, set_string
implicit none
private
public :: install_config_t, new_install_config
!> Configuration data for installation
type, extends(serializable_t) :: install_config_t
!> Install library with this project
logical :: library = .false.
!> Install tests with this project
logical :: test = .false.
!> Directory where compiled module files should be installed
character(len=:), allocatable :: module_dir
contains
!> Print information on this instance
procedure :: info
!> Serialization interface
procedure :: serializable_is_same => install_conf_same
procedure :: dump_to_toml
procedure :: load_from_toml
end type install_config_t
character(*), parameter, private :: class_name = '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.)
call get_value(table, "test", self%test, .false.)
call get_value(table, "module-dir", self%module_dir)
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","test","module-dir")
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))
write(unit, fmt) " - test install", trim(merge("enabled ", "disabled", self%test))
if (allocated(self%module_dir)) then
write(unit, fmt) " - module directory", self%module_dir
end if
end subroutine info
logical function install_conf_same(this,that)
class(install_config_t), intent(in) :: this
class(serializable_t), intent(in) :: that
install_conf_same = .false.
select type (other=>that)
type is (install_config_t)
if (this%library.neqv.other%library) return
if (this%test.neqv.other%test) return
if (allocated(this%module_dir).neqv.allocated(other%module_dir)) return
if (allocated(this%module_dir)) then
if (.not.(this%module_dir==other%module_dir)) return
end if
class default
! Not the same type
return
end select
!> All checks passed!
install_conf_same = .true.
end function install_conf_same
!> Dump install config to toml table
subroutine dump_to_toml(self, table, error)
!> Instance of the serializable object
class(install_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call set_value(table, "library", self%library, error, class_name)
if (allocated(error)) return
call set_value(table, "test", self%test, error, class_name)
if (allocated(error)) return
call set_string(table, "module-dir", self%module_dir, error, class_name)
if (allocated(error)) return
end subroutine dump_to_toml
!> Read install config from toml table (no checks made at this stage)
subroutine load_from_toml(self, table, error)
!> Instance of the serializable object
class(install_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: stat
call get_value(table, "library", self%library, error, class_name)
if (allocated(error)) return
call get_value(table, "test", self%test, error, class_name)
if (allocated(error)) return
call get_value(table, "module-dir", self%module_dir)
if (allocated(error)) return
end subroutine load_from_toml
end module fpm_manifest_install
fortran-lang-fpm-90bb83a/src/fpm/manifest/build.f90 0000664 0001750 0001750 00000026207 15145116760 022275 0 ustar alastair alastair !> 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, len_trim, is_valid_module_prefix, operator(==)
use tomlf, only: toml_table, toml_key, toml_stat
use fpm_toml, only : serializable_t, get_value, get_list, set_value, set_string, set_list
implicit none
private
public :: build_config_t, new_build_config
!> Configuration data for build
type, extends(serializable_t) :: build_config_t
!> Automatic discovery of executables
logical :: auto_executables = .true.
!> Automatic discovery of examples
logical :: auto_examples = .true.
!> Automatic discovery of tests
logical :: auto_tests = .true.
!> Enforcing of package module names
logical :: module_naming = .false.
type(string_t) :: module_prefix
!> Libraries to link against
type(string_t), allocatable :: link(:)
!> External modules to use
type(string_t), allocatable :: external_modules(:)
contains
!> Print information on this instance
procedure :: info
!> Serialization interface
procedure :: serializable_is_same => build_conf_is_same
procedure :: dump_to_toml
procedure :: load_from_toml
end type build_config_t
character(*), parameter, private :: class_name = 'build_config_t'
contains
!> Construct a new build configuration from a TOML data structure
subroutine new_build_config(self, table, package_name, 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
!> Package name
character(len=*), intent(in) :: package_name
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: stat
call check(table, package_name, 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
!> Module naming: fist, attempt boolean value first
call get_value(table, "module-naming", self%module_naming, .false., stat=stat)
if (stat == toml_stat%success) then
! Boolean value found. Set no custom prefix. This also falls back to key not provided
if (allocated(self%module_prefix%s)) deallocate(self%module_prefix%s)
else
!> Value found, but not a boolean. Attempt to read a prefix string
call get_value(table, "module-naming", self%module_prefix%s)
if (.not.allocated(self%module_prefix%s)) then
call syntax_error(error,"Could not read value for 'module-naming' in fpm.toml, expecting logical or a string")
return
end if
if (.not.is_valid_module_prefix(self%module_prefix)) then
call syntax_error(error,"Invalid custom module name prefix for in fpm.toml: <"//self%module_prefix%s// &
">, expecting a valid alphanumeric string")
return
end if
! Set module naming to ON
self%module_naming = .true.
end if
call get_list(table, "link", self%link, error)
if (allocated(error)) return
call get_list(table, "external-modules", self%external_modules, error)
if (allocated(error)) return
end subroutine new_build_config
!> Check local schema for allowed entries
subroutine check(table, package_name, error)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> Package name
character(len=*), intent(in) :: package_name
!> 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", "external-modules", "module-naming")
continue
case default
call syntax_error(error, 'Manifest file syntax error: key "'//list(ikey)%key//'" found in the [build] '//&
'section of package/dependency "'//package_name//'" fpm.toml is not allowed')
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, imod
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)
write(unit, fmt) " - enforce module naming ", merge("enabled ", "disabled", self%module_naming)
if (allocated(self%link)) then
write(unit, fmt) " - link against"
do ilink = 1, size(self%link)
write(unit, fmt) " - " // self%link(ilink)%s
end do
end if
if (allocated(self%external_modules)) then
write(unit, fmt) " - external modules"
do imod = 1, size(self%external_modules)
write(unit, fmt) " - " // self%external_modules(imod)%s
end do
end if
end subroutine info
!> Check that two dependency trees are equal
logical function build_conf_is_same(this,that)
class(build_config_t), intent(in) :: this
class(serializable_t), intent(in) :: that
build_conf_is_same = .false.
select type (other=>that)
type is (build_config_t)
if (this%auto_executables.neqv.other%auto_executables) return
if (this%auto_examples.neqv.other%auto_examples) return
if (this%auto_tests.neqv.other%auto_tests) return
if (this%module_naming.neqv.other%module_naming) return
if (.not.this%module_prefix==other%module_prefix) return
if (.not.this%link==other%link) return
if (.not.this%external_modules==other%external_modules) return
class default
! Not the same type
return
end select
!> All checks passed!
build_conf_is_same = .true.
end function build_conf_is_same
!> Dump build config to toml table
subroutine dump_to_toml(self, table, error)
!> Instance of the serializable object
class(build_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call set_value(table, "auto-executables", self%auto_executables, error, class_name)
if (allocated(error)) return
call set_value(table, "auto-tests", self%auto_tests, error, class_name)
if (allocated(error)) return
call set_value(table, "auto-examples", self%auto_examples, error, class_name)
if (allocated(error)) return
! Module naming can either contain a boolean value, or the prefix
has_prefix: if (self%module_naming .and. len_trim(self%module_prefix)>0) then
call set_string(table, "module-naming", self%module_prefix, error, class_name)
else
call set_value (table, "module-naming", self%module_naming, error, class_name)
end if has_prefix
if (allocated(error)) return
call set_list(table, "link", self%link, error)
if (allocated(error)) return
call set_list(table, "external-modules", self%external_modules, error)
if (allocated(error)) return
end subroutine dump_to_toml
!> Read build config from toml table (no checks made at this stage)
subroutine load_from_toml(self, table, error)
!> Instance of the serializable object
class(build_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: stat
call get_value(table, "auto-executables", self%auto_executables, error, class_name)
if (allocated(error)) return
call get_value(table, "auto-tests", self%auto_tests, error, class_name)
if (allocated(error)) return
call get_value(table, "auto-examples", self%auto_examples, error, class_name)
if (allocated(error)) return
!> Module naming: fist, attempt boolean value first
call get_value(table, "module-naming", self%module_naming, .false., stat=stat)
if (stat == toml_stat%success) then
! Boolean value found. Set no custom prefix. This also falls back to key not provided
if (allocated(self%module_prefix%s)) deallocate(self%module_prefix%s)
else
!> Value found, but not a boolean. Attempt to read a prefix string
call get_value(table, "module-naming", self%module_prefix%s)
if (.not.allocated(self%module_prefix%s)) then
call syntax_error(error,"Could not read value for 'module-naming' in fpm.toml, expecting logical or a string")
return
end if
self%module_naming = .true.
end if
call get_list(table, "link", self%link, error)
if (allocated(error)) return
call get_list(table, "external-modules", self%external_modules, error)
if (allocated(error)) return
end subroutine load_from_toml
end module fpm_manifest_build
fortran-lang-fpm-90bb83a/src/fpm/manifest/fortran.f90 0000664 0001750 0001750 00000013665 15145116760 022655 0 ustar alastair alastair module fpm_manifest_fortran
use fpm_error, only : error_t, syntax_error, fatal_error
use tomlf, only : toml_table, toml_key, toml_stat
use fpm_toml, only : get_value, serializable_t, set_value, set_string
implicit none
private
public :: fortran_config_t, new_fortran_config, default_fortran_config
!> Configuration data for Fortran
type, extends(serializable_t) :: fortran_config_t
!> Enable default implicit typing
logical :: implicit_typing = .false.
!> Enable implicit external interfaces
logical :: implicit_external = .false.
!> Form to use for all Fortran sources
character(:), allocatable :: source_form
contains
!> Serialization interface
procedure :: serializable_is_same => fortran_is_same
procedure :: dump_to_toml
procedure :: load_from_toml
end type fortran_config_t
character(len=*), parameter, private :: class_name = 'fortran_config_t'
contains
!> Initialize fortran config
subroutine default_fortran_config(self)
type(fortran_config_t), intent(inout) :: self
self%implicit_external = .false.
self%implicit_typing = .false.
self%source_form = 'free'
end subroutine default_fortran_config
!> Construct a new build configuration from a TOML data structure
subroutine new_fortran_config(self, table, error)
!> Instance of the fortran configuration
type(fortran_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
character(:), allocatable :: source_form
call check(table, error)
if (allocated(error)) return
call get_value(table, "implicit-typing", self%implicit_typing, .false., stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error,"Error while reading value for 'implicit-typing' in fpm.toml, expecting logical")
return
end if
call get_value(table, "implicit-external", self%implicit_external, .false., stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error,"Error while reading value for 'implicit-external' in fpm.toml, expecting logical")
return
end if
call get_value(table, "source-form", source_form, "free", stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error,"Error while reading value for 'source-form' in fpm.toml, expecting logical")
return
end if
select case(source_form)
case default
call fatal_error(error,"Value of source-form cannot be '"//source_form//"'")
return
case("free", "fixed", "default")
self%source_form = source_form
end select
end subroutine new_fortran_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("implicit-typing", "implicit-external", "source-form")
continue
case default
call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in fortran")
exit
end select
end do
end subroutine check
logical function fortran_is_same(this,that)
class(fortran_config_t), intent(in) :: this
class(serializable_t), intent(in) :: that
fortran_is_same = .false.
select type (other=>that)
type is (fortran_config_t)
if (this%implicit_typing.neqv.other%implicit_typing) return
if (this%implicit_external.neqv.other%implicit_external) return
if (allocated(this%source_form).neqv.allocated(other%source_form)) return
if (allocated(this%source_form)) then
if (.not.this%source_form==other%source_form) return
end if
class default
! Not the same type
return
end select
!> All checks passed!
fortran_is_same = .true.
end function fortran_is_same
!> Dump install config to toml table
subroutine dump_to_toml(self, table, error)
!> Instance of the serializable object
class(fortran_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call set_value(table, "implicit-typing", self%implicit_typing, error, class_name)
if (allocated(error)) return
call set_value(table, "implicit-external", self%implicit_external, error, class_name)
if (allocated(error)) return
call set_string(table, "source-form", self%source_form, error, class_name)
if (allocated(error)) return
end subroutine dump_to_toml
!> Read install config from toml table (no checks made at this stage)
subroutine load_from_toml(self, table, error)
!> Instance of the serializable object
class(fortran_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call get_value(table, "implicit-typing", self%implicit_typing, error, class_name)
if (allocated(error)) return
call get_value(table, "implicit-external", self%implicit_external, error, class_name)
if (allocated(error)) return
call get_value(table, "source-form", self%source_form)
end subroutine load_from_toml
end module fpm_manifest_fortran
fortran-lang-fpm-90bb83a/src/fpm/manifest/example.f90 0000664 0001750 0001750 00000012113 15145116760 022620 0 ustar alastair alastair !> 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, bad_name_error
use tomlf, only : toml_table, toml_key, toml_stat
use fpm_toml, only : get_value, get_list
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
if (bad_name_error(error,'example',self%name))then
return
endif
call get_value(table, "source-dir", self%source_dir, "example")
call get_value(table, "main", self%main, "main.f90")
call get_value(table, "dependencies", child, requested=.false.)
if (associated(child)) then
call new_dependencies(self%dependency, child, error=error)
if (allocated(error)) return
end if
call get_list(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
fortran-lang-fpm-90bb83a/src/fpm/manifest/feature_collection.f90 0000664 0001750 0001750 00000160617 15145116760 025050 0 ustar alastair alastair
module fpm_manifest_feature_collection
use fpm_manifest_feature, only: feature_config_t, new_feature, init_feature_components
use fpm_manifest_platform, only: platform_config_t, is_platform_key
use fpm_manifest_dependency, only: dependency_config_t
use fpm_manifest_example, only: example_config_t
use fpm_manifest_executable, only: executable_config_t
use fpm_manifest_metapackages, only: metapackage_config_t, metapackage_request_t
use fpm_manifest_test, only: test_config_t
use fpm_manifest_preprocess, only: preprocess_config_t
use fpm_error, only: error_t, fatal_error, syntax_error
use fpm_environment, only: OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, OS_CYGWIN, OS_SOLARIS, &
OS_FREEBSD, OS_OPENBSD, OS_ALL, match_os_type, OS_NAME
use fpm_compiler, only: compiler_enum, compiler_id_name, match_compiler_type, &
id_unknown, id_gcc, id_f95, id_caf, &
id_intel_classic_nix, id_intel_classic_mac, id_intel_classic_windows, &
id_intel_llvm_nix, id_intel_llvm_windows, id_intel_llvm_unknown, &
id_pgi, id_nvhpc, id_nag, id_flang, id_lahey, id_lfortran, id_all
use fpm_strings, only: string_t, lower, operator(==), split, str
use tomlf, only: toml_table, toml_array, toml_key, toml_stat
use fpm_toml, only: get_value, len, serializable_t, set_value, set_string, set_list, add_table, &
get_list
implicit none
private
public :: new_collections, get_default_features, &
default_debug_feature, default_release_feature, &
add_default_features, collection_from_feature
!> Feature configuration data
type, public, extends(serializable_t) :: feature_collection_t
! Features shared by all platforms, all compilers
type(feature_config_t) :: base
! Features shared by specific platform/compiler configurations
type(feature_config_t), allocatable :: variants(:)
contains
procedure :: serializable_is_same => feature_collection_same
procedure :: dump_to_toml => feature_collection_dump
procedure :: load_from_toml => feature_collection_load
procedure :: push_variant
procedure :: extract_for_target
procedure :: check => check_collection
procedure :: merge_into_package
procedure :: has_cpp
end type feature_collection_t
!> Interface for feature_collection_t constructor
interface feature_collection_t
module procedure collection_from_feature
end interface feature_collection_t
contains
!> Equality (semantic): base and variants (size + element-wise)
logical function feature_collection_same(this, that)
class(feature_collection_t), intent(in) :: this
class(serializable_t), intent(in) :: that
integer :: i
feature_collection_same = .false.
select type (other => that)
type is (feature_collection_t)
if (.not.(this%base == other%base)) return
if (allocated(this%variants) .neqv. allocated(other%variants)) return
if (allocated(this%variants)) then
if (size(this%variants) /= size(other%variants)) return
do i = 1, size(this%variants)
if (.not.(this%variants(i) == other%variants(i))) return
end do
end if
class default
return
end select
feature_collection_same = .true.
end function feature_collection_same
!> Serialize: base as a subtable; variants under a "variants" table
subroutine feature_collection_dump(self, table, error)
class(feature_collection_t), intent(inout) :: self
type(toml_table), intent(inout) :: table
type(error_t), allocatable, intent(out) :: error
type(toml_table), pointer :: ptr_base, ptr_vars, ptr
integer :: i
character(len=32) :: key
! base
call add_table(table, "base", ptr_base)
if (.not. associated(ptr_base)) then
call fatal_error(error, "feature_collection_t: cannot create 'base' table"); return
end if
call self%base%dump_to_toml(ptr_base, error); if (allocated(error)) return
! variants (optional)
if (allocated(self%variants)) then
call add_table(table, "variants", ptr_vars)
if (.not. associated(ptr_vars)) then
call fatal_error(error, "feature_collection_t: cannot create 'variants' table"); return
end if
do i = 1, size(self%variants)
write(key, '("variant_", i0)') i
call add_table(ptr_vars, trim(key), ptr)
if (.not. associated(ptr)) then
call fatal_error(error, "feature_collection_t: cannot create entry for "//trim(key)); return
end if
call self%variants(i)%dump_to_toml(ptr, error); if (allocated(error)) return
end do
end if
end subroutine feature_collection_dump
!> Deserialize: read base; then any number of variants under "variants"
subroutine feature_collection_load(self, table, error)
class(feature_collection_t), intent(inout) :: self
type(toml_table), intent(inout) :: table
type(error_t), allocatable, intent(out) :: error
type(toml_table), pointer :: ptr_base, ptr_vars, ptr
type(toml_key), allocatable :: keys(:)
integer :: i
! base (required)
call get_value(table, "base", ptr_base)
if (.not. associated(ptr_base)) then
call fatal_error(error, "feature_collection_t: missing 'base' table"); return
end if
call self%base%load_from_toml(ptr_base, error); if (allocated(error)) return
! variants (optional)
call get_value(table, "variants", ptr_vars)
if (.not. associated(ptr_vars)) then
if (allocated(self%variants)) deallocate(self%variants)
return
end if
call ptr_vars%get_keys(keys)
if (allocated(self%variants)) deallocate(self%variants)
allocate(self%variants(size(keys)))
do i = 1, size(keys)
call get_value(ptr_vars, keys(i), ptr)
if (.not. associated(ptr)) then
call fatal_error(error, "feature_collection_t: invalid variant entry '" &
//keys(i)%key//"'"); return
end if
call self%variants(i)%load_from_toml(ptr, error); if (allocated(error)) return
end do
end subroutine feature_collection_load
! helper: append a variant to self%variants
elemental subroutine push_variant(self,variant)
class(feature_collection_t), intent(inout) :: self
type(feature_config_t), intent(in) :: variant
type(feature_config_t), allocatable :: tmp(:)
integer :: n
if (.not. allocated(self%variants)) then
allocate(self%variants(1), source=variant)
else
n = size(self%variants)
allocate(tmp(n+1))
if (n>0) tmp(1:n) = self%variants
tmp(n+1) = variant
call move_alloc(tmp, self%variants)
end if
end subroutine push_variant
logical function is_compiler_key(s)
character(*), intent(in) :: s
is_compiler_key = match_compiler_type(s) /= id_unknown
end function is_compiler_key
logical function is_os_key(s)
character(*), intent(in) :: s
is_os_key = match_os_type(s) /= OS_UNKNOWN
end function is_os_key
!> Initialize multiple feature collections from manifest features table
subroutine new_collections(collections, table, error)
type(feature_collection_t), allocatable, intent(out) :: collections(:)
type(toml_table), intent(inout) :: table
type(error_t), allocatable, intent(out) :: error
type(toml_key), allocatable :: keys(:)
type(toml_table), pointer :: feature_table
integer :: i, stat
! Get all top-level feature names from the features table
call table%get_keys(keys)
if (size(keys) == 0) then
! No features defined, return default collections
call get_default_features(collections, error)
return
end if
! Create one collection per top-level feature name
allocate(collections(size(keys)))
do i = 1, size(keys)
! Get the subtable for this feature
call get_value(table, keys(i)%key, feature_table, stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Could not retrieve feature table for '"//keys(i)%key//"'")
return
end if
! Create collection from this feature's subtable
call new_collection_from_subtable(collections(i), feature_table, keys(i)%key, error)
if (allocated(error)) return
end do
end subroutine new_collections
!> Create a feature collection from a TOML subtable by traversing the hierarchy
!> Supports flexible configurations like:
!> [features]
!> name.os.compiler.* = ... # specific compiler + OS
!> name.compiler.* = ... # all OS, specific compiler
!> name.os.* = ... # specific OS, all compilers
!> name.* = ... # base feature (all OS, all compilers)
subroutine new_collection_from_subtable(self, table, name, error)
type(feature_collection_t), intent(out) :: self
type(toml_table), intent(inout) :: table
character(*), intent(in) :: name
type(error_t), allocatable, intent(out) :: error
integer :: i
type(platform_config_t) :: default_platform
type(toml_key), allocatable :: keys(:)
default_platform = platform_config_t(id_all,OS_ALL)
! Initialize base feature
self%base%name = name
self%base%platform = default_platform
! Traverse the table hierarchy to find variants
call traverse_feature_table(self, table, name, default_platform, error)
if (allocated(error)) return
! Check collection
call self%check(error)
if (allocated(error)) return
end subroutine new_collection_from_subtable
!> Recursively traverse a feature table to find variants
recursive subroutine traverse_feature_table(collection, table, feature_name, &
constraint, error)
type(feature_collection_t), intent(inout) :: collection
type(toml_table), intent(inout) :: table
character(*), intent(in) :: feature_name
type(platform_config_t), intent(in) :: constraint
type(error_t), allocatable, intent(out) :: error
type(toml_key), allocatable :: keys(:)
type(toml_table), pointer :: subtable
character(len=:), allocatable :: value_str
integer :: i, stat, os_type, compiler_type
type(feature_config_t) :: feature_variant
type(platform_config_t) :: platform
logical :: has_platform_keys, has_feature_data
call table%get_keys(keys)
has_platform_keys = .false.
has_feature_data = .false.
! First pass: check what types of keys we have
do i = 1, size(keys)
! Check if this key is a valid OS name
os_type = match_os_type(keys(i)%key)
if (os_type /= OS_UNKNOWN) then
has_platform_keys = .true.
cycle
end if
! Check if this key is a valid compiler name
compiler_type = match_compiler_type(keys(i)%key)
if (compiler_type /= id_unknown) then
has_platform_keys = .true.
cycle
end if
! This is a feature specification (like "flags" or "preprocess")
has_feature_data = .true.
! No compiler/OS flags can appear in feature specification branches
if (is_platform_key(keys(i)%key)) then
call fatal_error(error, "Key '"//keys(i)%key//"' is not allowed in feature table")
return
end if
end do
! If we have platform keys, traverse them
if (has_platform_keys) then
do i = 1, size(keys)
! Check if this key is an OS name
os_type = match_os_type(keys(i)%key)
if (os_type /= OS_UNKNOWN) then
! This is an OS constraint
! Check for chained OS commands (e.g., feature.windows.linux)
if (constraint%os_type /= OS_ALL) then
call fatal_error(error, "Cannot chain OS constraints: '" // &
constraint%os_name() // "." // keys(i)%key // &
"' - OS was already specified")
return
end if
! Get subtable and recurse
call get_value(table, keys(i)%key, subtable, stat=stat)
if (stat == toml_stat%success) then
platform = platform_config_t(constraint%compiler,os_type)
call traverse_feature_table(collection, subtable, feature_name, &
platform, error)
if (allocated(error)) return
end if
cycle
end if
! Check if this key is a compiler name
compiler_type = match_compiler_type(keys(i)%key)
if (compiler_type /= id_unknown) then
! Check for chained compiler commands (e.g., feature.gfortran.ifort)
if (constraint%compiler /= id_all) then
call fatal_error(error, "Cannot chain compiler constraints: '" // &
constraint%compiler_name() // "." // keys(i)%key // &
"' - compiler was already specified")
return
end if
! This is a compiler constraint - get subtable and recurse
call get_value(table, keys(i)%key, subtable, stat=stat)
if (stat == toml_stat%success) then
platform = platform_config_t(compiler_type,constraint%os_type)
call traverse_feature_table(collection, subtable, feature_name, &
platform, error)
if (allocated(error)) return
end if
cycle
end if
end do
end if
! If we found feature data at this level (no more platform keys), initialize feature components
if (has_feature_data) then
! Initialize a new feature variant
feature_variant%name = feature_name
! Check that the table is right
call feature_variant%check(table, error)
if (allocated(error)) return
call init_feature_components(feature_variant, table, constraint, error=error)
if (allocated(error)) return
if (constraint%any_platform()) then
! This is a base feature specification
call merge_feature_configs(collection%base, feature_variant, error)
if (allocated(error)) return
else
! This is a constrained variant
call collection%push_variant(feature_variant)
end if
end if
! If this is the root table and we haven't processed any feature data yet,
! call init_feature_components on the base feature (may be empty)
if (constraint%any_platform() .and. .not.(has_platform_keys.or.has_feature_data)) then
! Check that the table is right
call feature_variant%check(table, error)
if (allocated(error)) return
! Initialize base feature components from empty or root table
call init_feature_components(collection%base, table, error=error)
if (allocated(error)) return
end if
end subroutine traverse_feature_table
!> Merge two feature configurations using standardized rules:
!> - String properties (flags): concatenate with spaces (additive)
!> - Array properties: append arrays (additive)
!> - Allocatable properties: source overwrites target if target not allocated (conflict if both allocated)
!> - Metapackages: OR logic - turn on any that are requested (additive)
subroutine merge_feature_configs(target, source, error)
type(feature_config_t), intent(inout) :: target
type(feature_config_t), intent(in) :: source
type(error_t), allocatable, intent(out) :: error
! Check for allocatable property conflicts (should be caught by validation, but double-check)
if (allocated(target%build) .and. allocated(source%build)) then
call fatal_error(error, "build configuration can only be specified in one feature variant")
return
end if
if (allocated(target%install) .and. allocated(source%install)) then
call fatal_error(error, "install configuration can only be specified in one feature variant")
return
end if
if (allocated(target%fortran) .and. allocated(source%fortran)) then
call fatal_error(error, "fortran configuration can only be specified in one feature variant")
return
end if
if (allocated(target%library) .and. allocated(source%library)) then
call fatal_error(error, "library configuration can only be specified in one feature variant")
return
end if
! Merge simple string fields - source takes precedence if target doesn't have one
if (allocated(source%description) .and. .not. allocated(target%description)) then
target%description = source%description
end if
! ADDITIVE: String properties (flags) - concatenate with spaces
call merge_string_additive(target%flags, source%flags)
call merge_string_additive(target%c_flags, source%c_flags)
call merge_string_additive(target%cxx_flags, source%cxx_flags)
call merge_string_additive(target%link_time_flags, source%link_time_flags)
! ALLOCATABLE: Only set if target doesn't have it (conflicts checked above)
if (allocated(source%build) .and. .not. allocated(target%build)) then
allocate(target%build)
target%build = source%build
end if
if (allocated(source%install) .and. .not. allocated(target%install)) then
allocate(target%install)
target%install = source%install
end if
if (allocated(source%fortran) .and. .not. allocated(target%fortran)) then
allocate(target%fortran)
target%fortran = source%fortran
end if
if (allocated(source%library) .and. .not. allocated(target%library)) then
allocate(target%library)
target%library = source%library
end if
! ADDITIVE: Array properties - append source to target
call merge_executable_arrays(target%executable, source%executable, error)
if (allocated(error)) return
call merge_dependency_arrays(target%dependency, source%dependency, error)
if (allocated(error)) return
call merge_dependency_arrays(target%dev_dependency, source%dev_dependency, error)
if (allocated(error)) return
call merge_example_arrays(target%example, source%example, error)
if (allocated(error)) return
call merge_test_arrays(target%test, source%test, error)
if (allocated(error)) return
call merge_preprocess_arrays(target%preprocess, source%preprocess)
call merge_string_arrays(target%requires_features, source%requires_features)
! ADDITIVE: Metapackages - OR logic (if either requests it, turn it on)
call merge_metapackages(target%meta, source%meta)
end subroutine merge_feature_configs
!> Merge executable arrays by appending source to target, checking for duplicates
subroutine merge_executable_arrays(target, source, error)
type(executable_config_t), allocatable, intent(inout) :: target(:)
type(executable_config_t), allocatable, intent(in) :: source(:)
type(error_t), allocatable, intent(out) :: error
type(executable_config_t), allocatable :: temp(:)
integer :: target_size, source_size, i, j
if (.not. allocated(source)) return
source_size = size(source)
if (source_size == 0) return
! Check for duplicates between source and target
if (allocated(target)) then
target_size = size(target)
do i = 1, source_size
do j = 1, target_size
if (allocated(source(i)%name) .and. allocated(target(j)%name)) then
if (source(i)%name == target(j)%name) then
call fatal_error(error, "Duplicate executable '"//source(i)%name//"' found. " // &
"Multiple definitions of the same executable are not currently allowed.")
return
end if
end if
end do
end do
end if
if (.not. allocated(target)) then
allocate(target(source_size), source=source)
else
target_size = size(target)
allocate(temp(target_size + source_size))
temp(1:target_size) = target
temp(target_size+1:target_size+source_size) = source
call move_alloc(temp, target)
end if
end subroutine merge_executable_arrays
!> Merge dependency arrays by appending source to target, checking for duplicates
subroutine merge_dependency_arrays(target, source, error)
type(dependency_config_t), allocatable, intent(inout) :: target(:)
type(dependency_config_t), allocatable, intent(in) :: source(:)
type(error_t), allocatable, intent(out) :: error
type(dependency_config_t), allocatable :: temp(:)
integer :: target_size, source_size, i, j
if (.not. allocated(source)) return
source_size = size(source)
if (source_size == 0) return
! Check for duplicates between source and target
if (allocated(target)) then
target_size = size(target)
do i = 1, source_size
do j = 1, target_size
if (allocated(source(i)%name) .and. allocated(target(j)%name)) then
if (source(i)%name == target(j)%name) then
call fatal_error(error, "Duplicate dependency '"//source(i)%name//"' found. " // &
"Multiple definitions of the same dependency are not currently allowed.")
return
end if
end if
end do
end do
end if
if (.not. allocated(target)) then
allocate(target(source_size), source=source)
else
target_size = size(target)
allocate(temp(target_size + source_size))
temp(1:target_size) = target
temp(target_size+1:target_size+source_size) = source
call move_alloc(temp, target)
end if
end subroutine merge_dependency_arrays
!> Merge string properties additively by concatenating with space
subroutine merge_string_additive(target, source)
character(len=:), allocatable, intent(inout) :: target
character(len=:), allocatable, intent(in) :: source
if (allocated(source)) then
if (allocated(target)) then
target = trim(target) // " " // trim(source)
else
target = source
end if
end if
end subroutine merge_string_additive
!> Merge example arrays by appending source to target, checking for duplicates
subroutine merge_example_arrays(target, source, error)
type(example_config_t), allocatable, intent(inout) :: target(:)
type(example_config_t), allocatable, intent(in) :: source(:)
type(error_t), allocatable, intent(out) :: error
type(example_config_t), allocatable :: temp(:)
integer :: target_size, source_size, i, j
if (.not. allocated(source)) return
source_size = size(source)
if (source_size == 0) return
! Check for duplicates between source and target
if (allocated(target)) then
target_size = size(target)
do i = 1, source_size
do j = 1, target_size
if (allocated(source(i)%name) .and. allocated(target(j)%name)) then
if (source(i)%name == target(j)%name) then
call fatal_error(error, "Duplicate example '"//source(i)%name//"' found. " // &
"Multiple definitions of the same example are not currently allowed.")
return
end if
end if
end do
end do
end if
if (.not. allocated(target)) then
allocate(target(source_size), source=source)
else
target_size = size(target)
allocate(temp(target_size + source_size))
temp(1:target_size) = target
temp(target_size+1:target_size+source_size) = source
call move_alloc(temp, target)
end if
end subroutine merge_example_arrays
!> Merge test arrays by appending source to target, checking for duplicates
subroutine merge_test_arrays(target, source, error)
type(test_config_t), allocatable, intent(inout) :: target(:)
type(test_config_t), allocatable, intent(in) :: source(:)
type(error_t), allocatable, intent(out) :: error
type(test_config_t), allocatable :: temp(:)
integer :: target_size, source_size, i, j
if (.not. allocated(source)) return
source_size = size(source)
if (source_size == 0) return
! Check for duplicates between source and target
if (allocated(target)) then
target_size = size(target)
do i = 1, source_size
do j = 1, target_size
if (allocated(source(i)%name) .and. allocated(target(j)%name)) then
if (source(i)%name == target(j)%name) then
call fatal_error(error, "Duplicate test '"//source(i)%name//"' found. " // &
"Multiple definitions of the same test are not currently allowed.")
return
end if
end if
end do
end do
end if
if (.not. allocated(target)) then
allocate(target(source_size))
target = source
else
target_size = size(target)
allocate(temp(target_size + source_size))
temp(1:target_size) = target
temp(target_size+1:target_size+source_size) = source
call move_alloc(temp, target)
end if
end subroutine merge_test_arrays
!> Merge preprocess arrays by merging configurations for same preprocessor names
!> and appending new ones
subroutine merge_preprocess_arrays(target, source)
type(preprocess_config_t), allocatable, intent(inout) :: target(:)
type(preprocess_config_t), allocatable, intent(in) :: source(:)
type(preprocess_config_t), allocatable :: temp(:)
integer :: target_size, source_size, i, j, new_count
integer, allocatable :: source_to_target_map(:) ! Maps source index to target index (0 = new)
if (.not. allocated(source)) return
source_size = size(source)
if (source_size == 0) return
if (.not. allocated(target)) then
allocate(target(source_size), source=source)
return
end if
target_size = size(target)
! Create mapping arrays in a single pass
allocate(source_to_target_map(source_size), source=0)
! Single loop to build the mapping
do i = 1, source_size
if (allocated(source(i)%name)) then
do j = 1, target_size
if (allocated(target(j)%name)) then
if (target(j)%name == source(i)%name) then
source_to_target_map(i) = j
exit
end if
end if
end do
end if
end do
! Merge overlapping configurations
do i = 1, source_size
j = source_to_target_map(i)
if (j==0) cycle ! new config
call merge_preprocessor_config(target(j), source(i))
end do
! Count and add new preprocessors
new_count = count(source_to_target_map==0)
if (new_count > 0) then
allocate(temp(target_size + new_count))
temp(1:target_size) = target
! Add new preprocessors in a single pass
j = target_size
do i = 1, source_size
if (source_to_target_map(i)==0) then
j = j + 1
temp(j) = source(i)
end if
end do
call move_alloc(temp, target)
end if
end subroutine merge_preprocess_arrays
!> Helper to merge two preprocessor configurations with the same name
subroutine merge_preprocessor_config(target, source)
type(preprocess_config_t), intent(inout) :: target
type(preprocess_config_t), intent(in) :: source
! Merge suffixes arrays
call merge_string_arrays(target%suffixes, source%suffixes)
! Merge directories arrays
call merge_string_arrays(target%directories, source%directories)
! Merge macros arrays
call merge_string_arrays(target%macros, source%macros)
end subroutine merge_preprocessor_config
!> Merge string arrays by appending source to target
subroutine merge_string_arrays(target, source)
type(string_t), allocatable, intent(inout) :: target(:)
type(string_t), allocatable, intent(in) :: source(:)
type(string_t), allocatable :: temp(:)
integer :: target_size, source_size
if (.not. allocated(source)) return
source_size = size(source)
if (source_size == 0) return
if (.not. allocated(target)) then
allocate(target(source_size))
target = source
else
target_size = size(target)
allocate(temp(target_size + source_size))
temp(1:target_size) = target
temp(target_size+1:target_size+source_size) = source
call move_alloc(temp, target)
end if
end subroutine merge_string_arrays
!> Merge metapackages using OR logic - if either requests it, turn it on
subroutine merge_metapackages_additive(target, source)
type(metapackage_request_t), intent(inout) :: target
type(metapackage_request_t), intent(in) :: source
! OR logic: if either requests a metapackage, turn it on
if (source%on) then
target%on = .true.
target%name = source%name
! Use source version if target doesn't have one
if (allocated(source%version) .and. .not. allocated(target%version)) then
target%version = source%version
end if
end if
end subroutine merge_metapackages_additive
!> Merge whole metapackage config
subroutine merge_metapackages(target, source)
type(metapackage_config_t), intent(inout) :: target
type(metapackage_config_t), intent(in) :: source
call merge_metapackages_additive(target%openmp,source%openmp)
call merge_metapackages_additive(target%stdlib,source%stdlib)
call merge_metapackages_additive(target%minpack,source%minpack)
call merge_metapackages_additive(target%mpi,source%mpi)
call merge_metapackages_additive(target%hdf5,source%hdf5)
call merge_metapackages_additive(target%netcdf,source%netcdf)
call merge_metapackages_additive(target%blas,source%blas)
end subroutine merge_metapackages
!> Create default debug feature collection
function default_debug_feature() result(collection)
type(feature_collection_t) :: collection
! Initialize base feature with debug settings
collection%base%name = 'debug'
collection%base%platform%compiler = id_all
collection%base%platform%os_type = OS_ALL
! Add debug variants for different compilers
call collection%push_variant(default_variant('debug', id_caf, OS_ALL, &
' -Wall -Wextra -Wimplicit-interface -Wno-external-argument-mismatch&
& -fPIC -fmax-errors=1 -g -fcheck=bounds&
& -fcheck=array-temps -fbacktrace', &
' -fPIC', &
' -fPIC'))
call collection%push_variant(default_variant('debug', id_gcc, OS_ALL, &
' -Wall -Wextra -Wimplicit-interface -Wno-external-argument-mismatch&
& -fPIC -fmax-errors=1 -g -fcheck=bounds&
& -fcheck=array-temps -fbacktrace -fcoarray=single', &
' -Wall -Wextra -fPIC -fmax-errors=1 -g', &
' -Wall -Wextra -fPIC -fmax-errors=1 -g'))
call collection%push_variant(default_variant('debug', id_f95, OS_ALL, &
' -Wall -Wextra -Wimplicit-interface -Wno-external-argument-mismatch&
& -fPIC -fmax-errors=1 -g -fcheck=bounds&
& -fcheck=array-temps -Wno-maybe-uninitialized -Wno-uninitialized -fbacktrace', &
' -fPIC', &
' -fPIC'))
call collection%push_variant(default_variant('debug', id_nvhpc, OS_ALL, &
' -Minform=inform -Mbackslash -g -Mbounds -Mchkptr -Mchkstk -traceback', &
' -fPIC', &
' -fPIC'))
call collection%push_variant(default_variant('debug', id_intel_classic_nix, OS_ALL, &
' -warn all -check all -error-limit 1 -O0 -g -assume byterecl -traceback', &
' -fPIC', &
' -fPIC'))
call collection%push_variant(default_variant('debug', id_intel_classic_nix, OS_WINDOWS, &
' /warn:all /check:all /error-limit:1&
& /Od /Z7 /assume:byterecl /traceback'))
call collection%push_variant(default_variant('debug', id_intel_llvm_nix, OS_ALL, &
' -warn all -check all -error-limit 1 -O0 -g -assume byterecl -traceback', &
' -fPIC', &
' -fPIC'))
call collection%push_variant(default_variant('debug', id_intel_llvm_nix, OS_WINDOWS, &
' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl'))
call collection%push_variant(default_variant('debug', id_lfortran, OS_ALL, '', ' -fPIC', ' -fPIC'))
end function default_debug_feature
!> Create default release feature collection
function default_release_feature() result(collection)
type(feature_collection_t) :: collection
! Initialize base feature with release settings
collection%base%name = 'release'
collection%base%platform%compiler = id_all
collection%base%platform%os_type = OS_ALL
! Add release variants for different compilers
call collection%push_variant(default_variant('release', id_caf, OS_ALL, &
' -O3 -Wimplicit-interface -fPIC -fmax-errors=1 -funroll-loops', &
' -fPIC', &
' -fPIC'))
call collection%push_variant(default_variant('release', id_gcc, OS_ALL, &
' -O3 -Wimplicit-interface -fPIC -fmax-errors=1 -funroll-loops -fcoarray=single', &
' -O3 -fPIC -fmax-errors=1 -funroll-loops', &
' -O3 -fPIC -fmax-errors=1 -funroll-loops'))
call collection%push_variant(default_variant('release', id_f95, OS_ALL, &
' -O3 -Wimplicit-interface -fPIC -fmax-errors=1 -ffast-math -funroll-loops', &
' -fPIC', &
' -fPIC'))
call collection%push_variant(default_variant('release', id_nvhpc, OS_ALL, &
' -Mbackslash', &
' -fPIC', &
' -fPIC'))
call collection%push_variant(default_variant('release', id_intel_classic_nix, OS_LINUX, &
' -fp-model precise -pc64 -align all -error-limit 1 -reentrancy&
& threaded -nogen-interfaces -assume byterecl', &
' -fPIC', &
' -fPIC'))
call collection%push_variant(default_variant('release', id_intel_classic_windows, &
OS_WINDOWS, ' /fp:precise /align:all /error-limit:1 /reentrancy:threaded&
& /nogen-interfaces /assume:byterecl'))
call collection%push_variant(default_variant('release', id_intel_llvm_nix, &
OS_LINUX, ' -fp-model=precise -pc64 -align all -error-limit 1 -reentrancy threaded&
& -nogen-interfaces -assume byterecl', &
' -fPIC', &
' -fPIC'))
call collection%push_variant(default_variant('release', id_intel_llvm_nix, &
OS_WINDOWS, ' /fp:precise /align:all /error-limit:1 /reentrancy:threaded&
& /nogen-interfaces /assume:byterecl'))
call collection%push_variant(default_variant('release', id_nag, OS_ALL, &
' -O4 -coarray=single -PIC', &
' -fPIC', &
' -fPIC'))
call collection%push_variant(default_variant('release', id_lfortran, OS_ALL, &
' flag_lfortran_opt', &
' -fPIC', &
' -fPIC'))
end function default_release_feature
!> Get default feature collections (debug and release)
subroutine get_default_features(collections, error)
!> Feature collections array to populate (debug and release)
type(feature_collection_t), allocatable, intent(out) :: collections(:)
!> Error handling
type(error_t), allocatable, intent(out) :: error
! Allocate array for debug and release collections
allocate(collections(2))
! Create debug and release collections
collections(1) = default_debug_feature()
collections(2) = default_release_feature()
end subroutine get_default_features
!> Helper to create a feature variant
function default_variant(name, compiler_id, os_type, flags, c_flags, cxx_flags) result(feature)
character(len=*), intent(in) :: name
integer(compiler_enum), intent(in) :: compiler_id
integer, intent(in) :: os_type
character(len=*), optional, intent(in) :: flags
character(len=*), optional, intent(in) :: c_flags
character(len=*), optional, intent(in) :: cxx_flags
type(feature_config_t) :: feature
feature%name = name
feature%platform%compiler = compiler_id
feature%platform%os_type = os_type
feature%flags = ""
feature%c_flags = ""
feature%cxx_flags = ""
if (present(flags)) then
feature%flags = flags
end if
if (present(c_flags)) then
feature%c_flags = c_flags
end if
if (present(cxx_flags)) then
feature%cxx_flags = cxx_flags
end if
end function default_variant
!> Check that the collection has valid OS/compiler logic and can be merged safely
!> Implements standardized feature hierarchy validation:
!> 1. OS_all+id_all (base) → id_compiler+OS_all → id_all+OS_current → id_compiler+OS_current
!> 2. Additive properties (flags) can be concatenated
!> 3. Allocatable properties can only exist in one variant per merge path
subroutine check_collection(self, error)
class(feature_collection_t), intent(in) :: self
type(error_t), allocatable, intent(out) :: error
integer :: i, j
! Check base feature has valid platform settings
if (self%base%platform%os_type == OS_UNKNOWN) then
call fatal_error(error, "Base feature '"//self%base%name//"' has invalid OS type")
return
end if
if (self%base%platform%compiler == id_unknown) then
call fatal_error(error, "Base feature '"//self%base%name//"' has invalid compiler type")
return
end if
! Base feature must be OS_ALL + id_all for proper hierarchy
if (self%base%platform%os_type /= OS_ALL .or. self%base%platform%compiler /= id_all) then
call fatal_error(error, "Base feature '"//self%base%name// &
"' must have OS_ALL and id_all platform settings")
return
end if
! Check all variants have valid platform settings and hierarchy rules
if (allocated(self%variants)) then
do i = 1, size(self%variants)
! Validate OS and compiler settings
if (self%variants(i)%platform%os_type == OS_UNKNOWN) then
call fatal_error(error, "Variant "//trim(str(i))//" of feature '" &
//self%base%name//"' has invalid OS type")
return
end if
if (self%variants(i)%platform%compiler == id_unknown) then
call fatal_error(error, "Variant "//trim(str(i))//" of feature '" &
//self%base%name//"' has invalid compiler type")
return
end if
! Check that variant name matches base name
if (allocated(self%variants(i)%name) .and. allocated(self%base%name)) then
if (self%variants(i)%name /= self%base%name) then
call fatal_error(error, "Variant "//trim(str(i))//" name '" &
//self%variants(i)%name// &
"' does not match base name '"//self%base%name//"'")
return
end if
end if
! Validate feature hierarchy rules
call validate_variant_hierarchy(self%variants(i), i, error)
if (allocated(error)) return
! Check for exact duplicate platforms
do j = i + 1, size(self%variants)
if (self%variants(i)%platform == self%variants(j)%platform) then
call fatal_error(error, "Duplicate platform configurations: "// &
self%variants(i)%manifest_name()// &
" and "//self%variants(j)%manifest_name())
return
end if
end do
end do
! Check for conflicts between variants that could be applied together
call check_merge_conflicts(self, error)
if (allocated(error)) return
end if
end subroutine check_collection
!> Validate that a variant follows the feature hierarchy rules
!> Valid combinations:
!> - id_compiler + OS_all (compiler-specific, all OS)
!> - id_all + OS_specific (OS-specific, all compilers)
!> - id_compiler + OS_specific (target-specific)
!> Note: id_all + OS_all variants are allowed during parsing but should be merged into base
subroutine validate_variant_hierarchy(variant, index, error)
type(feature_config_t), intent(in) :: variant
integer, intent(in) :: index
type(error_t), allocatable, intent(out) :: error
! For now, allow all combinations - the merge logic handles id_all + OS_ALL -> base
! The validation was too strict for current parsing logic
! TODO: Implement stricter validation after parsing is fixed
! All combinations are valid in the hierarchy:
! - id_all + OS_all (should be merged to base, but parsing might create these temporarily)
! - id_compiler + OS_all (compiler-specific)
! - id_all + OS_specific (OS-specific)
! - id_compiler + OS_specific (target-specific)
end subroutine validate_variant_hierarchy
!> Check for merge conflicts between variants that could be applied together
!> This validates that no two applicable variants have conflicting allocatable properties
subroutine check_merge_conflicts(collection, error)
class(feature_collection_t), intent(in) :: collection
type(error_t), allocatable, intent(out) :: error
integer :: i, j
type(feature_config_t) :: merged_feature
integer, parameter :: test_compilers(3) = [id_gcc, id_flang, id_intel_classic_nix]
integer, parameter :: test_oses(3) = [OS_LINUX, OS_WINDOWS, OS_MACOS]
integer :: comp_idx, os_idx
! Test merge conflicts for common compiler/OS combinations
do comp_idx = 1, size(test_compilers)
do os_idx = 1, size(test_oses)
! Start with base feature
merged_feature = collection%base
! Try to merge all applicable variants for this target
if (allocated(collection%variants)) then
do i = 1, size(collection%variants)
if (variant_applies_to_target(collection%variants(i), &
test_compilers(comp_idx), test_oses(os_idx))) then
! Check for allocatable property conflicts before merging
call check_single_merge_conflict(merged_feature, collection%variants(i), &
test_compilers(comp_idx), test_oses(os_idx), error)
if (allocated(error)) return
! Simulate the merge (without error checking since we just checked)
call simulate_merge(merged_feature, collection%variants(i))
end if
end do
end if
end do
end do
end subroutine check_merge_conflicts
!> Check if a variant applies to the given target compiler and OS
logical function variant_applies_to_target(variant, target_compiler, target_os)
type(feature_config_t), intent(in) :: variant
integer, intent(in) :: target_compiler, target_os
! A variant applies if:
! - Compiler matches or is id_all
! - OS matches or is OS_ALL
variant_applies_to_target = &
(variant%platform%compiler == target_compiler .or. variant%platform%compiler == id_all) .and. &
(variant%platform%os_type == target_os .or. variant%platform%os_type == OS_ALL)
end function variant_applies_to_target
!> Check for conflicts between two features that would be merged
subroutine check_single_merge_conflict(target, source, compiler_id, os_id, error)
type(feature_config_t), intent(in) :: target, source
integer, intent(in) :: compiler_id, os_id
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: compiler, os
compiler = compiler_id_name(compiler_id)
os = OS_NAME(os_id)
if (allocated(target%build) .and. allocated(source%build)) then
call fatal_error(error, "Feature '"//target%name//"' has conflicting build configurations for "// &
compiler//"+"//os//": both base/variants specify build settings")
return
end if
if (allocated(target%install) .and. allocated(source%install)) then
call fatal_error(error, "Feature '"//target%name//"' has conflicting install configurations for "// &
compiler//"+"//os//": both base/variants specify install settings")
return
end if
if (allocated(target%fortran) .and. allocated(source%fortran)) then
call fatal_error(error, "Feature '"//target%name//"' has conflicting fortran configurations for "// &
compiler//"+"//os//": both base/variants specify fortran settings")
return
end if
if (allocated(target%library) .and. allocated(source%library)) then
call fatal_error(error, "Feature '"//target%name//"' has conflicting library configurations for "// &
compiler//"+"//os//": both base/variants specify library settings")
return
end if
end subroutine check_single_merge_conflict
!> Simulate merging source into target for conflict checking (without error handling)
subroutine simulate_merge(target, source)
type(feature_config_t), intent(inout) :: target
type(feature_config_t), intent(in) :: source
! Only merge allocatable properties if target doesn't have them
! (conflicts should have been caught by check_single_merge_conflict)
if (allocated(source%build) .and. .not. allocated(target%build)) then
allocate(target%build)
target%build = source%build
end if
if (allocated(source%install) .and. .not. allocated(target%install)) then
allocate(target%install)
target%install = source%install
end if
if (allocated(source%fortran) .and. .not. allocated(target%fortran)) then
allocate(target%fortran)
target%fortran = source%fortran
end if
if (allocated(source%library) .and. .not. allocated(target%library)) then
allocate(target%library)
target%library = source%library
end if
end subroutine simulate_merge
!> Merge a feature configuration into an existing global package
subroutine merge_into_package(self, package, target, error)
class(feature_collection_t), intent(in) :: self
class(feature_config_t), intent(inout) :: package
type(platform_config_t), intent(in) :: target
type(error_t), allocatable, intent(out) :: error
type(feature_config_t) :: feature
! Extract the feature configuration for the target platform
feature = self%extract_for_target(target, error)
if (allocated(error)) return
! Merge the extracted feature into the package
call merge_feature_configs(package, feature, error)
if (allocated(error)) return
end subroutine merge_into_package
!> Extract a merged feature configuration for the given target platform
type(feature_config_t) function extract_for_target(self, target, error) result(feature)
class(feature_collection_t), intent(in) :: self
type(platform_config_t), intent(in) :: target
type(error_t), allocatable, intent(out) :: error
integer :: i
! Start with base feature as foundation
feature = self%base
! Apply matching variants on top of base
if (allocated(self%variants)) then
do i = 1, size(self%variants)
if (self%variants(i)%platform%matches(target)) then
! Merge this variant into the feature
call merge_feature_configs(feature, self%variants(i), error)
if (allocated(error)) return
end if
end do
end if
end function extract_for_target
!> Add default features to existing features array if they don't already exist
subroutine add_default_features(features, error)
!> Instance of the feature collections array (will be resized)
type(feature_collection_t), allocatable, intent(inout) :: features(:)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(feature_collection_t), allocatable :: temp_features(:)
type(feature_collection_t), allocatable :: default_features(:)
logical :: debug_exists, release_exists
integer :: i, current_size, new_size
! Get default features
call get_default_features(default_features, error)
if (allocated(error)) return
! Check if debug and release features already exist
debug_exists = .false.
release_exists = .false.
if (allocated(features)) then
do i = 1, size(features)
if (allocated(features(i)%base%name)) then
if (features(i)%base%name == "debug") debug_exists = .true.
if (features(i)%base%name == "release") release_exists = .true.
end if
end do
current_size = size(features)
else
current_size = 0
end if
! Calculate how many features to add
new_size = current_size
if (.not. debug_exists) new_size = new_size + 1
if (.not. release_exists) new_size = new_size + 1
! If nothing to add, return
if (new_size == current_size) return
! Create new array with existing + missing defaults
allocate(temp_features(new_size))
! Copy existing features
if (current_size > 0) then
temp_features(1:current_size) = features(1:current_size)
end if
! Add missing defaults
i = current_size
if (.not. debug_exists) then
i = i + 1
temp_features(i) = default_features(1) ! debug feature
end if
if (.not. release_exists) then
i = i + 1
temp_features(i) = default_features(2) ! release feature
end if
! Replace the features array
call move_alloc(temp_features, features)
end subroutine add_default_features
!> Create a feature collection from a single feature_config_t
!> The feature becomes the base configuration for all OS/compiler combinations
type(feature_collection_t) function collection_from_feature(self) result(collection)
!> Feature configuration to convert
class(feature_config_t), intent(in) :: self
! Copy the feature into the base configuration
collection%base = self
! Set platform to all OS and all compilers for the base
collection%base%platform%os_type = OS_ALL
collection%base%platform%compiler = id_all
! Copy the name if available
if (allocated(self%name)) collection%base%name = self%name
! No variants initially - just the base configuration
! (variants can be added later if needed)
end function collection_from_feature
!> Check if there is a CPP preprocessor configuration
elemental logical function has_cpp(self)
class(feature_collection_t), intent(in) :: self
integer :: i
has_cpp = self%base%has_cpp()
if (has_cpp) return
if (.not.allocated(self%variants)) return
do i=1,size(self%variants)
has_cpp = self%variants(i)%has_cpp()
if (has_cpp) return
end do
end function has_cpp
end module fpm_manifest_feature_collection
fortran-lang-fpm-90bb83a/src/fpm/manifest/library.f90 0000664 0001750 0001750 00000025523 15145116760 022642 0 ustar alastair alastair !> 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, fatal_error
use fpm_strings, only: string_t, string_cat, operator(==)
use tomlf, only : toml_table, toml_key, toml_stat
use fpm_toml, only : get_value, get_list, serializable_t, set_value, &
set_list, set_string, get_value, has_list
implicit none
private
public :: library_config_t, new_library
!> Configuration meta data for a library
type, extends(serializable_t) :: 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
!> Shared / Static / Monolithic library types (can be multiple)
type(string_t), allocatable :: lib_type(:)
contains
!> Print information on this instance
procedure :: info
!> Serialization interface
procedure :: serializable_is_same => library_is_same
procedure :: dump_to_toml
procedure :: load_from_toml
!> Check library types
procedure, non_overridable :: monolithic
procedure, non_overridable :: shared
procedure, non_overridable :: static
end type library_config_t
character(*), parameter, private :: class_name = 'library_config_t'
contains
!> Check if this is a shared library config
!> (full packages built as shared libs)
elemental logical function shared(self)
!> Instance of the library configuration
class(library_config_t), intent(in) :: self
integer :: i
shared = .false.
if (allocated(self%lib_type)) then
do i = 1, size(self%lib_type)
if (self%lib_type(i)%s == "shared") then
shared = .true.
return
end if
end do
endif
end function shared
!> Check if this is a static library config
!> (full packages built as static libs)
elemental logical function static(self)
!> Instance of the library configuration
class(library_config_t), intent(in) :: self
integer :: i
static = .false.
if (allocated(self%lib_type)) then
do i = 1, size(self%lib_type)
if (self%lib_type(i)%s == "static") then
static = .true.
return
end if
end do
endif
end function static
!> Check if this is a monolithic library config
!> (single monolithic archive with all objects used by this project)
elemental logical function monolithic(self)
!> Instance of the library configuration
class(library_config_t), intent(in) :: self
integer :: i
if (allocated(self%lib_type)) then
monolithic = .false.
do i = 1, size(self%lib_type)
if (self%lib_type(i)%s == "monolithic") then
monolithic = .true.
return
end if
end do
else
! Default: monolithic
monolithic = .true.
endif
end function monolithic
!> 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
integer :: stat, i
character(len=:), allocatable :: single_type
call check(table, error)
if (allocated(error)) return
if (has_list(table, "source-dir")) then
call syntax_error(error, "Manifest key [library.source-dir] does not allow list input")
return
end if
! library.type can now be either a single value or a list
call get_value(table, "source-dir", self%source_dir, "src")
call get_value(table, "build-script", self%build_script)
call get_list(table, "include-dir", self%include_dir, error)
if (allocated(error)) return
! Parse library type - can be single value or array
if (has_list(table, "type")) then
! Array of types
call get_list(table, "type", self%lib_type, error)
if (allocated(error)) return
else
! Single type - convert to array for consistency
call get_value(table, "type", single_type, "monolithic")
self%lib_type = [string_t(single_type)]
end if
if (.not.allocated(self%lib_type)) then
self%lib_type = [string_t("monolithic")]
end if
! Validate all types in the array
do i = 1, size(self%lib_type)
select case(self%lib_type(i)%s)
case("shared","static","monolithic")
! OK
case default
call fatal_error(error,"Value of library.type cannot be '"//self%lib_type(i)%s &
//"', choose shared/static/monolithic (default)")
return
end select
end do
! Check that monolithic is not specified together with static or shared
if (monolithic(self) .and. (static(self) .or. shared(self))) then
call fatal_error(error,"library.type 'monolithic' cannot be specified together with 'static' or 'shared'")
return
end if
! 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", "type")
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
write(unit, fmt) "- library type", string_cat(self%lib_type,",")
if (allocated(self%build_script)) then
write(unit, fmt) "- custom build", self%build_script
end if
end subroutine info
logical function library_is_same(this,that)
class(library_config_t), intent(in) :: this
class(serializable_t), intent(in) :: that
library_is_same = .false.
select type (other=>that)
type is (library_config_t)
if (.not.this%include_dir==other%include_dir) return
if (allocated(this%source_dir).neqv.allocated(other%source_dir)) return
if (allocated(this%source_dir)) then
if (.not.this%source_dir==other%source_dir) return
end if
if (allocated(this%build_script).neqv.allocated(other%build_script)) return
if (allocated(this%build_script)) then
if (.not.this%build_script==other%build_script) return
end if
if (allocated(this%lib_type).neqv.allocated(other%lib_type)) return
if (allocated(this%lib_type)) then
if (.not.this%lib_type==other%lib_type) return
end if
class default
! Not the same type
return
end select
!> All checks passed!
library_is_same = .true.
end function library_is_same
!> Dump install config to toml table
subroutine dump_to_toml(self, table, error)
!> Instance of the serializable object
class(library_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call set_string(table, "source-dir", self%source_dir, error, class_name)
if (allocated(error)) return
call set_string(table, "build-script", self%build_script, error, class_name)
if (allocated(error)) return
call set_list(table, "include-dir", self%include_dir, error)
if (allocated(error)) return
call set_list(table, "type", self%lib_type, error)
if (allocated(error)) return
end subroutine dump_to_toml
!> Read install config from toml table (no checks made at this stage)
subroutine load_from_toml(self, table, error)
!> Instance of the serializable object
class(library_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call get_value(table, "source-dir", self%source_dir)
if (allocated(error)) return
call get_value(table, "build-script", self%build_script)
if (allocated(error)) return
call get_list(table, "include-dir", self%include_dir, error)
if (allocated(error)) return
call get_list(table, "type", self%lib_type, error)
if (allocated(error)) return
end subroutine load_from_toml
end module fpm_manifest_library
fortran-lang-fpm-90bb83a/src/fpm/manifest/platform.f90 0000664 0001750 0001750 00000035125 15145116760 023021 0 ustar alastair alastair !> Platform configuration type.
!>
!> This type captures only the target compiler and operating-system
!> selector, and implements the standard serialization interface
!> (serializable_t) used across FPM manifest classes.
!>
!> TOML representation:
!> compiler = "" # e.g., "gfortran", "ifx", "all"
!> os = "" # e.g., "linux", "macos", "windows", "all"
module fpm_manifest_platform
use fpm_error, only : error_t, fatal_error
use tomlf, only : toml_table
use fpm_toml, only : serializable_t, set_string, get_value
use fpm_environment,only : OS_ALL, OS_NAME, match_os_type, OS_UNKNOWN, validate_os_name, &
OS_WINDOWS, OS_LINUX, OS_MACOS
use fpm_compiler, only : compiler_enum, compiler_id_name, match_compiler_type, id_all, &
id_unknown, validate_compiler_name, id_intel_classic_nix, id_intel_classic_mac, &
id_intel_classic_windows, id_intel_llvm_nix, id_intel_llvm_windows, id_intel_llvm_unknown
use fpm_strings, only : lower
implicit none
private
public :: platform_config_t
public :: is_platform_key
!> Shortcuts for the Intel OS variants
integer(compiler_enum), parameter :: &
id_intel_classic(*) = [id_intel_classic_mac,id_intel_classic_nix,id_intel_classic_windows], &
id_intel_llvm (*) = [id_intel_llvm_nix,id_intel_llvm_windows,id_intel_llvm_unknown]
!> Serializable platform configuration (compiler + OS only)
type, extends(serializable_t) :: platform_config_t
integer(compiler_enum) :: compiler = id_all
integer :: os_type = OS_ALL
contains
procedure :: serializable_is_same => platform_is_same
procedure :: dump_to_toml
procedure :: load_from_toml
!> Print information
procedure :: info
!> Return .true. if THIS platform selector is compatible with CURRENT (wildcards allowed)
procedure :: matches => platform_is_suitable
!> Get compiler name as string
procedure :: compiler_name => platform_compiler_name
!> Get OS name as string
procedure :: os_name => platform_os_name
!> Get configuration name as it appears in the manifest
procedure :: name => platform_config_name
!> Validation
procedure :: is_valid => platform_is_valid
!> Properties
procedure, non_overridable :: any_compiler
procedure, non_overridable :: any_os
procedure, non_overridable :: any_platform
end type platform_config_t
! Overloaded initializer
interface platform_config_t
module procedure new_platform
module procedure new_platform_id
end interface
character(len=*), parameter, private :: class_name = 'platform_config_t'
contains
!> Initialize a new platform config from compiler name
!> Automatically selects correct Intel compiler version based on OS
type(platform_config_t) function new_platform(compiler, os_type)
character(*), intent(in) :: compiler
integer, intent(in) :: os_type
new_platform%compiler = match_compiler_type(compiler)
new_platform%os_type = os_type
! Correct Intel compiler ID based on OS (fallback to unix version for OS_ALL)
new_platform%compiler = correct_compiler_for_os(new_platform%compiler, os_type)
end function new_platform
!> Initialize a new platform config from compiler enum ID
!> Automatically selects correct Intel compiler version based on OS
type(platform_config_t) function new_platform_id(compiler_id, os_type)
integer(compiler_enum), intent(in) :: compiler_id
integer, intent(in) :: os_type
new_platform_id%compiler = compiler_id
new_platform_id%os_type = os_type
! Correct Intel compiler ID based on OS (fallback to unix version for OS_ALL)
new_platform_id%compiler = correct_compiler_for_os(new_platform_id%compiler, os_type)
end function new_platform_id
!> Correct Intel compiler ID to match the target OS
!> Returns the appropriate OS-specific Intel compiler variant
function correct_compiler_for_os(compiler_id, os_type) result(corrected_id)
integer(compiler_enum), intent(in) :: compiler_id
integer, intent(in) :: os_type
integer(compiler_enum) :: corrected_id
corrected_id = compiler_id ! Default: no change
! Intel classic compilers: map to OS-specific version
select case (compiler_id)
case (id_intel_classic_mac,id_intel_classic_nix,id_intel_classic_windows)
select case (os_type)
case (OS_WINDOWS)
corrected_id = id_intel_classic_windows
case (OS_MACOS)
corrected_id = id_intel_classic_mac
case default
corrected_id = id_intel_classic_nix ! Fallback to unix version
end select
case (id_intel_llvm_nix,id_intel_llvm_windows)
select case (os_type)
case (OS_WINDOWS)
corrected_id = id_intel_llvm_windows
case default
corrected_id = id_intel_llvm_nix ! Fallback to unix version
end select
end select
end function correct_compiler_for_os
!> Check if a compiler ID is suitable for a target platform
!> Handles special cases like Intel compiler variants
logical function compiler_is_suitable(compiler_id, target) result(suitable)
integer(compiler_enum), intent(in) :: compiler_id
type(platform_config_t), intent(in) :: target
! Default case: exact match or compiler_id is id_all
suitable = (compiler_id == id_all .or. compiler_id == target%compiler)
if (suitable) return
! Intel classic compilers: all variants are equivalent
if (any(compiler_id == id_intel_classic) .and. any(target%compiler == id_intel_classic)) then
suitable = .true.
return
end if
! Intel LLVM compilers: all variants are equivalent
if (any(compiler_id == id_intel_llvm) .and. any(target%compiler == id_intel_llvm)) then
suitable = .true.
return
end if
! Future extensions can be added here for other compiler families
end function compiler_is_suitable
!> Compare two platform_config_t (semantic equality)
logical function platform_is_same(this, that)
class(platform_config_t), intent(in) :: this
class(serializable_t), intent(in) :: that
platform_is_same = .false.
select type (other => that)
type is (platform_config_t)
if (this%compiler /= other%compiler) return
if (this%os_type /= other%os_type ) return
class default
return
end select
platform_is_same = .true.
end function platform_is_same
!> Dump to TOML table
subroutine dump_to_toml(self, table, error)
class(platform_config_t), intent(inout) :: self
type(toml_table), intent(inout) :: table
type(error_t), allocatable, intent(out) :: error
! Compiler as canonical name (e.g., "gfortran", "ifx", "all")
call set_string(table, "compiler", compiler_id_name(self%compiler), error, class_name)
if (allocated(error)) return
! OS as canonical name (e.g., "linux", "macos", "windows", "all")
call set_string(table, "os", OS_NAME(self%os_type), error, class_name)
if (allocated(error)) return
end subroutine dump_to_toml
!> Load from TOML table
subroutine load_from_toml(self, table, error)
class(platform_config_t), intent(inout) :: self
type(toml_table), intent(inout) :: table
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: s
! Compiler (default "all")
call get_value(table, "compiler", s, "all")
self%compiler = match_compiler_type(s)
if (self%compiler == id_unknown) then
call fatal_error(error, class_name//": unsupported compiler '"//s//"'")
return
end if
! OS (default "all")
call get_value(table, "os", s, "all")
self%os_type = match_os_type(s)
! match_os_type should map unknowns to a sentinel; rely on it for validation.
! If you prefer a hard failure on unknown here, uncomment the next block:
! if (self%os_type == OS_UNKNOWN) then
! call fatal_error(error, class_name//": unsupported os '"//s//"'")
! return
! end if
end subroutine load_from_toml
!> Write information on instance (similar style to profile_config_t%info)
subroutine info(self, unit, verbosity)
class(platform_config_t), intent(in) :: self
integer, intent(in) :: unit
integer, optional, intent(in) :: verbosity
integer :: pr
character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)'
pr = merge(verbosity, 1, present(verbosity))
write(unit, fmt) "Platform"
write(unit, fmt) "- compiler", compiler_id_name(self%compiler)
write(unit, fmt) "- os", OS_NAME(self%os_type)
! Currently 'verbosity' does not expand output; reserved for future fields.
end subroutine info
!> Return .true. if SELF is suitable for a given target platform
!>
!> Rules:
!> - compiler matches if SELF%compiler == id_all OR == target%compiler
!> - os matches if SELF%os_type == OS_ALL OR == target%os_type
!> - id_unknown / OS_UNKNOWN in SELF are treated as "no match" (conservative)
!> - Intel compilers must match OS (ifort unix/windows versions use different flags)
logical function platform_is_suitable(self, target) result(ok)
class(platform_config_t), intent(in) :: self
type(platform_config_t), intent(in) :: target
logical :: compiler_ok, os_ok
! Check that both platforms are valid
if (.not. self%is_valid() .or. .not. target%is_valid()) then
ok = .false.
return
end if
compiler_ok = compiler_is_suitable(self%compiler, target)
os_ok = any(self%os_type == [OS_ALL,target%os_type])
! Basic matching
ok = compiler_ok .and. os_ok
if (.not. ok) return
! Additional validation: Intel compilers must have compatible OS
! ifort on Unix/Mac should not match ifort on Windows and vice versa
if (self%compiler /= id_all .and. self%os_type /= OS_ALL) then
ok = compiler_os_compatible(self%compiler, self%os_type) .and. &
compiler_os_compatible(target%compiler, target%os_type)
end if
end function platform_is_suitable
!> Check if a platform configuration is valid (no unknowns, compatible compiler+OS)
logical function platform_is_valid(self) result(valid)
class(platform_config_t), intent(in) :: self
! Check compiler+OS compatibility
valid = compiler_os_compatible(self%compiler, self%os_type)
end function platform_is_valid
!> Check if a compiler ID is compatible with an OS type
elemental logical function compiler_os_compatible(compiler_id, os_type) result(compatible)
integer(compiler_enum), intent(in) :: compiler_id
integer, intent(in) :: os_type
! Check for unknowns
if (compiler_id == id_unknown .or. os_type == OS_UNKNOWN) then
compatible = .false.
return
end if
! Intel classic compilers: OS-specific variants
select case (compiler_id)
case (id_intel_classic_windows)
compatible = any(os_type == [OS_ALL,OS_WINDOWS])
case (id_intel_classic_nix)
compatible = any(os_type == [OS_ALL,OS_LINUX])
case (id_intel_classic_mac)
compatible = any(os_type == [OS_ALL,OS_MACOS])
case (id_intel_llvm_windows)
compatible = any(os_type == [OS_ALL,OS_WINDOWS])
case (id_intel_llvm_nix)
compatible = any(os_type == [OS_ALL,OS_LINUX,OS_MACOS])
case default
! Other compilers are compatible with any OS
compatible = os_type/=OS_UNKNOWN .and. compiler_id/=id_unknown
end select
end function compiler_os_compatible
!> Check if a key (os or compiler) can be used for platform setting
elemental logical function is_platform_key(key)
character(*), intent(in) :: key
call validate_compiler_name(key, is_platform_key)
if (is_platform_key) return
call validate_os_name(key, is_platform_key)
if (is_platform_key) return
end function is_platform_key
!> Get compiler name as string
function platform_compiler_name(self) result(name)
class(platform_config_t), intent(in) :: self
character(len=:), allocatable :: name
name = compiler_id_name(self%compiler)
end function platform_compiler_name
!> Get OS name as string
function platform_os_name(self) result(name)
class(platform_config_t), intent(in) :: self
character(len=:), allocatable :: name
name = OS_NAME(self%os_type)
end function platform_os_name
!> Get configuration name
function platform_config_name(self) result(name)
class(platform_config_t), intent(in) :: self
character(len=:), allocatable :: name
if (self%os_type==OS_ALL .and. self%compiler==id_all) then
name = ""
elseif (self%os_type==OS_ALL) then
name = self%compiler_name()
elseif (self%compiler==id_all) then
name = self%os_name()
else
name = self%os_name()//'.'//self%compiler_name()
end if
end function platform_config_name
!> Whether the configuration is generic
elemental logical function any_compiler(self)
class(platform_config_t), intent(in) :: self
any_compiler = self%compiler == id_all
end function any_compiler
elemental logical function any_os(self)
class(platform_config_t), intent(in) :: self
any_os = self%os_type == OS_ALL
end function any_os
elemental logical function any_platform(self)
class(platform_config_t), intent(in) :: self
any_platform = any_os(self) .and. any_compiler(self)
end function any_platform
end module fpm_manifest_platform
fortran-lang-fpm-90bb83a/src/fpm/manifest/dependency.f90 0000664 0001750 0001750 00000056501 15145116760 023314 0 ustar alastair alastair !> 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" }
!>"dep5" = { path = "path", features = ["feat1", "feat2"] }
!>"dep6" = { path = "path", profile = "myprofile" }
!>```
!>
!> The `features` and `profile` keys are mutually exclusive.
!> `features` provides a list of individual feature names;
!> `profile` provides a single profile name defined in the dependency's manifest.
!>
!> 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, fatal_error
use fpm_git, only: git_target_t, git_target_tag, git_target_branch, &
& git_target_revision, git_target_default, git_matches_manifest
use tomlf, only: toml_table, toml_key, toml_stat
use fpm_toml, only: get_value, check_keys, serializable_t, add_table, &
& set_value, set_string, get_list, set_list
use fpm_filesystem, only: windows_path, join_path
use fpm_environment, only: get_os_type, OS_WINDOWS
use fpm_manifest_metapackages, only: metapackage_config_t, is_meta_package, new_meta_config, &
metapackage_request_t, new_meta_request
use fpm_versioning, only: version_t, new_version
use fpm_strings, only: string_t
use fpm_manifest_preprocess
implicit none
private
public :: dependency_config_t, new_dependency, new_dependencies, manifest_has_changed, &
& dependency_destroy, resize
!> Configuration meta data for a dependency
type, extends(serializable_t) :: dependency_config_t
!> Name of the dependency
character(len=:), allocatable :: name
!> Local target
character(len=:), allocatable :: path
!> Namespace which the dependency belongs to.
!> Enables multiple dependencies with the same name.
!> Required for dependencies that are obtained via the official registry.
character(len=:), allocatable :: namespace
!> The requested version of the dependency.
!> The latest version is used if not specified.
type(version_t), allocatable :: requested_version
!> Requested macros for the dependency
type(preprocess_config_t), allocatable :: preprocess(:)
!> Requested features for the dependency
type(string_t), allocatable :: features(:)
!> Requested profile for the dependency (mutually exclusive with features)
character(len=:), allocatable :: profile
!> Git descriptor
type(git_target_t), allocatable :: git
contains
!> Print information on this instance
procedure :: info
!> Add a preprocessor configuration
procedure :: add_preprocess
!> Serialization interface
procedure :: serializable_is_same => dependency_is_same
procedure :: dump_to_toml
procedure :: load_from_toml
end type dependency_config_t
!> Common output format for writing to the command line
character(len=*), parameter :: out_fmt = '("#", *(1x, g0))'
interface resize
module procedure resize_dependency_config
end interface resize
contains
!> Construct a new dependency configuration from a TOML data structure
subroutine new_dependency(self, table, root, error)
!> Instance of the dependency configuration
type(dependency_config_t), intent(out) :: self
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> Root directory of the manifest
character(*), intent(in), optional :: root
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(len=:), allocatable :: uri, value, requested_version
type(toml_table), pointer :: child
call check(table, error)
if (allocated(error)) return
call table%get_key(self%name)
call get_value(table, "namespace", self%namespace)
call get_value(table, "v", requested_version)
if (allocated(requested_version)) then
if (.not. allocated(self%requested_version)) allocate (self%requested_version)
call new_version(self%requested_version, requested_version, error)
if (allocated(error)) return
end if
!> Get optional preprocessor directives
call get_value(table, "preprocess", child, requested=.false.)
if (associated(child)) then
call new_preprocessors(self%preprocess, child, error)
if (allocated(error)) return
endif
!> Get optional features list
call get_list(table, "features", self%features, error)
if (allocated(error)) return
!> Get optional profile name
call get_value(table, "profile", self%profile)
call get_value(table, "path", uri)
if (allocated(uri)) then
if (get_os_type() == OS_WINDOWS) uri = windows_path(uri)
if (present(root)) uri = join_path(root,uri) ! Relative to the fpm.toml it’s written in
call move_alloc(uri, self%path)
return
end if
call get_value(table, "git", uri)
if (allocated(uri)) then
call get_value(table, "tag", value)
if (allocated(value)) then
self%git = git_target_tag(uri, value)
end if
if (.not. allocated(self%git)) then
call get_value(table, "branch", value)
if (allocated(value)) then
self%git = git_target_branch(uri, value)
end if
end if
if (.not. allocated(self%git)) then
call get_value(table, "rev", value)
if (allocated(value)) then
self%git = git_target_revision(uri, value)
end if
end if
if (.not. allocated(self%git)) then
self%git = git_target_default(uri)
end if
return
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(string_t), allocatable :: string_list(:)
type(toml_key), allocatable :: list(:)
type(toml_table), pointer :: child
!> List of valid keys for the dependency table.
character(*), dimension(*), parameter :: valid_keys = [character(24) :: &
& "namespace", &
"v", &
"path", &
"git", &
"tag", &
"branch", &
"rev", &
"preprocess", &
"features", &
"profile" &
& ]
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
call check_keys(table, valid_keys, error)
if (allocated(error)) return
if (table%has_key("path") .and. table%has_key("git")) then
call syntax_error(error, "Dependency '"//name//"' cannot have both git and path entries")
return
end if
if ((table%has_key("branch") .and. table%has_key("rev")) .or. &
(table%has_key("branch") .and. table%has_key("tag")) .or. &
(table%has_key("rev") .and. table%has_key("tag"))) then
call syntax_error(error, "Dependency '"//name//"' can only have one of branch, rev or tag present")
return
end if
if ((table%has_key("branch") .or. table%has_key("tag") .or. table%has_key("rev")) &
.and. .not. table%has_key("git")) then
call syntax_error(error, "Dependency '"//name//"' has git identifier but no git url")
return
end if
if (.not. table%has_key("path") .and. .not. table%has_key("git") &
.and. .not. table%has_key("namespace")) then
call syntax_error(error, "Please provide a 'namespace' for dependency '"//name// &
& "' if it is not a local path or git repository")
return
end if
if (table%has_key('v') .and. (table%has_key('path') .or. table%has_key('git'))) then
call syntax_error(error, "Dependency '"//name//"' cannot have both v and git/path entries")
return
end if
! Check preprocess key
if (table%has_key('preprocess')) then
call get_value(table, 'preprocess', child)
if (.not.associated(child)) then
call syntax_error(error, "Dependency '"//name//"' has invalid 'preprocess' entry")
return
end if
end if
! Check that features and profile are not both specified
if (table%has_key('features') .and. table%has_key('profile')) then
call syntax_error(error, "Dependency '"//name//"' cannot have both 'features' and 'profile' entries")
return
end if
end subroutine check
!> Construct new dependency array from a TOML data structure
subroutine new_dependencies(deps, table, root, meta, error)
!> Instance of the dependency configuration
type(dependency_config_t), allocatable, intent(out) :: deps(:)
!> (optional) metapackages
type(metapackage_config_t), optional, intent(out) :: meta
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> Root directory of the manifest
character(*), intent(in), optional :: root
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_table), pointer :: node
type(toml_key), allocatable :: list(:)
type(dependency_config_t), allocatable :: all_deps(:)
type(metapackage_request_t) :: meta_request
logical, allocatable :: is_meta(:)
logical :: metapackages_allowed
integer :: idep, stat, ndep
call table%get_keys(list)
! An empty table is okay
if (size(list) < 1) return
!> Flag dependencies that should be treated as metapackages
metapackages_allowed = present(meta)
allocate(is_meta(size(list)),source=.false.)
allocate(all_deps(size(list)))
!> Parse all meta- and non-metapackage dependencies
do idep = 1, size(list)
! Check if this is a standard dependency node
call get_value(table, list(idep)%key, node, stat=stat)
is_standard_dependency: if (stat /= toml_stat%success) then
! See if it can be a valid metapackage name
call new_meta_request(meta_request, list(idep)%key, table, error=error)
!> Neither a standard dep nor a metapackage
if (allocated(error)) then
call syntax_error(error, "Dependency "//list(idep)%key//" is not a valid metapackage or a table entry")
return
endif
!> Valid meta dependency
is_meta(idep) = .true.
else
! Parse as a standard dependency
is_meta(idep) = .false.
call new_dependency(all_deps(idep), node, root, error)
if (allocated(error)) return
end if is_standard_dependency
end do
! Non-meta dependencies
ndep = count(.not.is_meta)
! Finalize standard dependencies
allocate(deps(ndep))
ndep = 0
do idep = 1, size(list)
if (is_meta(idep)) cycle
ndep = ndep+1
deps(ndep) = all_deps(idep)
end do
! Finalize meta dependencies
if (metapackages_allowed) call new_meta_config(meta,table,is_meta,error)
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, ilink
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
if (allocated(self%features)) then
write(unit, fmt) " - features"
do ilink = 1, size(self%features)
write(unit, fmt) " - " // self%features(ilink)%s
end do
end if
if (allocated(self%profile)) then
write(unit, fmt) " - profile", self%profile
end if
end subroutine info
!> Check if two dependency configurations are different
logical function manifest_has_changed(cached, manifest, verbosity, iunit) result(has_changed)
!> Two instances of the dependency configuration
class(dependency_config_t), intent(in) :: cached, manifest
!> Log verbosity
integer, intent(in) :: verbosity, iunit
has_changed = .true.
!> Perform all checks
if (allocated(cached%git).neqv.allocated(manifest%git)) then
if (verbosity>1) write(iunit,out_fmt) "GIT presence has changed. "
return
endif
if (allocated(cached%git)) then
if (.not.git_matches_manifest(cached%git,manifest%git,verbosity,iunit)) return
end if
!> All checks passed! The two instances are equal
has_changed = .false.
end function manifest_has_changed
!> Clean memory
elemental subroutine dependency_destroy(self)
class(dependency_config_t), intent(inout) :: self
if (allocated(self%name)) deallocate(self%name)
if (allocated(self%path)) deallocate(self%path)
if (allocated(self%namespace)) deallocate(self%namespace)
if (allocated(self%requested_version)) deallocate(self%requested_version)
if (allocated(self%git)) deallocate(self%git)
if (allocated(self%features)) deallocate(self%features)
if (allocated(self%profile)) deallocate(self%profile)
end subroutine dependency_destroy
!> Check that two dependency configs are equal
logical function dependency_is_same(this,that)
class(dependency_config_t), intent(in) :: this
class(serializable_t), intent(in) :: that
dependency_is_same = .false.
select type (other=>that)
type is (dependency_config_t)
if (allocated(this%name).neqv.allocated(other%name)) return
if (allocated(this%name)) then
if (.not.(this%name==other%name)) return
endif
if (allocated(this%path).neqv.allocated(other%path)) return
if (allocated(this%path)) then
if (.not.(this%path==other%path)) return
endif
if (allocated(this%namespace).neqv.allocated(other%namespace)) return
if (allocated(this%namespace)) then
if (.not.(this%namespace==other%namespace)) return
endif
if (allocated(this%requested_version).neqv.allocated(other%requested_version)) return
if (allocated(this%requested_version)) then
if (.not.(this%requested_version==other%requested_version)) return
endif
if (allocated(this%features).neqv.allocated(other%features)) return
if (allocated(this%features)) then
if (.not.(this%features==other%features)) return
endif
if (allocated(this%profile).neqv.allocated(other%profile)) return
if (allocated(this%profile)) then
if (.not.(this%profile==other%profile)) return
endif
if ((allocated(this%git).neqv.allocated(other%git))) return
if (allocated(this%git)) then
if (.not.(this%git==other%git)) return
endif
class default
! Not the same type
return
end select
!> All checks passed!
dependency_is_same = .true.
end function dependency_is_same
!> Dump dependency to toml table
subroutine dump_to_toml(self, table, error)
!> Instance of the serializable object
class(dependency_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(toml_table), pointer :: ptr
type(error_t), allocatable, intent(out) :: error
integer :: ierr
call set_string(table, "name", self%name, error, 'dependency_config_t')
if (allocated(error)) return
call set_string(table, "path", self%path, error, 'dependency_config_t')
if (allocated(error)) return
call set_string(table, "namespace", self%namespace, error, 'dependency_config_t')
if (allocated(error)) return
if (allocated(self%requested_version)) then
call set_string(table, "requested_version", self%requested_version%s(), error, 'dependency_config_t')
if (allocated(error)) return
endif
call set_list(table, "features", self%features, error)
if (allocated(error)) return
call set_string(table, "profile", self%profile, error, 'dependency_config_t')
if (allocated(error)) return
if (allocated(self%git)) then
call add_table(table, "git", ptr, error)
if (allocated(error)) return
call self%git%dump_to_toml(ptr, error)
if (allocated(error)) return
endif
end subroutine dump_to_toml
!> Read dependency from toml table (no checks made at this stage)
subroutine load_from_toml(self, table, error)
!> Instance of the serializable object
class(dependency_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Local variables
type(toml_key), allocatable :: list(:)
type(toml_table), pointer :: ptr
character(len=:), allocatable :: requested_version
integer :: ierr,ii
call dependency_destroy(self)
call get_value(table, "name", self%name)
call get_value(table, "path", self%path)
call get_value(table, "namespace", self%namespace)
call get_value(table, "requested_version", requested_version)
if (allocated(requested_version)) then
allocate(self%requested_version)
call new_version(self%requested_version, requested_version, error)
if (allocated(error)) then
error%message = 'dependency_config_t: version error from TOML table - '//error%message
return
endif
end if
call get_list(table, "features", self%features, error)
if (allocated(error)) return
call get_value(table, "profile", self%profile)
call table%get_keys(list)
add_git: do ii = 1, size(list)
if (list(ii)%key=="git") then
call get_value(table, list(ii)%key, ptr, stat=ierr)
if (ierr /= toml_stat%success) then
call fatal_error(error,'dependency_config_t: cannot retrieve git from TOML table')
exit
endif
allocate(self%git)
call self%git%load_from_toml(ptr, error)
if (allocated(error)) return
exit add_git
end if
end do add_git
end subroutine load_from_toml
!> Reallocate a list of dependencies
pure subroutine resize_dependency_config(var, n)
!> Instance of the array to be resized
type(dependency_config_t), allocatable, intent(inout) :: var(:)
!> Dimension of the final array size
integer, intent(in), optional :: n
type(dependency_config_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_config
subroutine add_preprocess(dep, preprocess)
!> Instance of the dependency config
class(dependency_config_t), intent(inout) :: dep
!> Instance of the preprocessor configuration
type(preprocess_config_t), intent(in) :: preprocess
integer :: i,n
type(preprocess_config_t), allocatable :: new_preprocess(:)
if (allocated(dep%preprocess)) then
n = size(dep%preprocess)
if (n<1) then
deallocate(dep%preprocess)
allocate(dep%preprocess(1),source=preprocess)
else
find_similar: do i=1,n
if (dep%preprocess(i)%name==dep%name) then
call dep%preprocess(i)%add_config(preprocess)
return
end if
end do find_similar
! Similar preprocessor config not found: add a new one
allocate(new_preprocess(n+1))
new_preprocess(1:n) = dep%preprocess
new_preprocess(n+1) = preprocess
call move_alloc(from=new_preprocess,to=dep%preprocess)
end if
else
! Copy configuration
allocate(dep%preprocess(1),source=preprocess)
end if
end subroutine add_preprocess
end module fpm_manifest_dependency
fortran-lang-fpm-90bb83a/src/fpm/manifest/profiles.f90 0000664 0001750 0001750 00000024524 15145116760 023021 0 ustar alastair alastair !> Implementation of the profiles configuration.
!>
!> A profile is a named collection of features that can be applied together.
!> Profiles provide a convenient way to group features for different use cases,
!> such as debug builds, release builds, or specific target configurations.
!>
!> A profile table has the following structure:
!>```toml
!>[profiles.debug]
!>features = ["debug-flags", "development-tools"]
!>
!>[profiles.release]
!>features = ["optimized", "strip-symbols"]
!>```
module fpm_manifest_profile
use fpm_error, only: error_t, fatal_error, syntax_error
use fpm_strings, only: string_t, operator(==)
use tomlf, only: toml_table, toml_array, toml_key, toml_stat, len
use fpm_toml, only: get_value, serializable_t, set_string, set_list, get_list, add_table
implicit none
private
public :: profile_config_t, new_profile, new_profiles, get_default_profiles, add_default_profiles
!> Configuration data for a profile
type, extends(serializable_t) :: profile_config_t
!> Profile name
character(len=:), allocatable :: name
!> List of features to apply
type(string_t), allocatable :: features(:)
contains
!> Print information on this instance
procedure :: info
!> Serialization interface
procedure :: serializable_is_same => profile_is_same
procedure :: dump_to_toml
procedure :: load_from_toml
end type profile_config_t
character(len=*), parameter, private :: class_name = 'profile_config_t'
contains
!> Construct a new profile configuration from a TOML array
subroutine new_profile(self, features_array, profile_name, error)
!> Instance of the profile configuration
type(profile_config_t), intent(out) :: self
!> TOML array containing the feature names
type(toml_array), intent(inout) :: features_array
!> Name of the profile
character(len=*), intent(in) :: profile_name
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i, stat
character(len=:), allocatable :: feature_name
! Set profile name
self%name = profile_name
! Get feature names from array
if (len(features_array) > 0) then
allocate(self%features(len(features_array)))
do i = 1, len(features_array)
call get_value(features_array, i, feature_name, stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Failed to read feature name from profile " // profile_name)
return
end if
self%features(i)%s = feature_name
end do
else
allocate(self%features(0))
end if
end subroutine new_profile
!> Construct new profiles array from a TOML data structure
subroutine new_profiles(profiles, table, error)
!> Instance of the profile configuration array
type(profile_config_t), allocatable, intent(out) :: profiles(:)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_array), pointer :: array_node
type(toml_key), allocatable :: list(:)
integer :: iprofile, stat
call table%get_keys(list)
if (size(list) < 1) then
allocate(profiles(0))
return
end if
allocate(profiles(size(list)))
do iprofile = 1, size(list)
call get_value(table, list(iprofile)%key, array_node, stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Profile "//list(iprofile)%key//" must be an array of feature names")
exit
end if
call new_profile(profiles(iprofile), array_node, list(iprofile)%key, error)
if (allocated(error)) exit
end do
end subroutine new_profiles
!> Write information on instance
subroutine info(self, unit, verbosity)
!> Instance of the profile configuration
class(profile_config_t), intent(in) :: self
!> Unit for IO
integer, intent(in) :: unit
!> Verbosity of the printout
integer, intent(in), optional :: verbosity
integer :: pr, 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) "Profile"
if (allocated(self%name)) then
write(unit, fmt) "- name", self%name
end if
if (allocated(self%features)) then
if (size(self%features) > 0) then
write(unit, fmti) "- features", size(self%features)
if (pr > 1) then
do ii = 1, size(self%features)
write(unit, fmt) " - feature", self%features(ii)%s
end do
end if
end if
end if
end subroutine info
!> Check that two profile configs are equal
logical function profile_is_same(this, that)
class(profile_config_t), intent(in) :: this
class(serializable_t), intent(in) :: that
integer :: ii
profile_is_same = .false.
select type (other=>that)
type is (profile_config_t)
if (allocated(this%name).neqv.allocated(other%name)) return
if (allocated(this%name)) then
if (.not.(this%name==other%name)) return
end if
if (allocated(this%features).neqv.allocated(other%features)) return
if (allocated(this%features)) then
if (.not.(size(this%features)==size(other%features))) return
do ii = 1, size(this%features)
if (.not.(this%features(ii)==other%features(ii))) return
end do
end if
class default
return
end select
profile_is_same = .true.
end function profile_is_same
!> Dump profile to toml table
subroutine dump_to_toml(self, table, error)
!> Instance of the serializable object
class(profile_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call set_string(table, "name", self%name, error, class_name)
if (allocated(error)) return
call set_list(table, "features", self%features, error)
if (allocated(error)) return
end subroutine dump_to_toml
!> Read profile from toml table (no checks made at this stage)
subroutine load_from_toml(self, table, error)
!> Instance of the serializable object
class(profile_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call get_value(table, "name", self%name)
call get_list(table, "features", self%features, error)
if (allocated(error)) return
end subroutine load_from_toml
!> Create default profiles with standard features
subroutine get_default_profiles(profiles, error)
!> Instance of the profile configuration array
type(profile_config_t), allocatable, intent(out) :: profiles(:)
!> Error handling
type(error_t), allocatable, intent(out) :: error
! Create two default profiles: debug and release
allocate(profiles(2))
! Debug profile with "debug" feature
profiles(1)%name = "debug"
allocate(profiles(1)%features(1))
profiles(1)%features(1)%s = "debug"
! Release profile with "release" feature
profiles(2)%name = "release"
allocate(profiles(2)%features(1))
profiles(2)%features(1)%s = "release"
end subroutine get_default_profiles
!> Add default profiles to existing profiles array if they don't already exist
subroutine add_default_profiles(profiles, error)
!> Instance of the profile configuration array (will be resized)
type(profile_config_t), allocatable, intent(inout) :: profiles(:)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(profile_config_t), allocatable :: temp_profiles(:)
type(profile_config_t), allocatable :: default_profiles(:)
logical :: debug_exists, release_exists
integer :: i, current_size, new_size
! Get default profiles
call get_default_profiles(default_profiles, error)
if (allocated(error)) return
! Check if debug and release profiles already exist
debug_exists = .false.
release_exists = .false.
if (allocated(profiles)) then
do i = 1, size(profiles)
if (allocated(profiles(i)%name)) then
if (profiles(i)%name == "debug") debug_exists = .true.
if (profiles(i)%name == "release") release_exists = .true.
end if
end do
current_size = size(profiles)
else
current_size = 0
end if
! Calculate how many profiles to add
new_size = current_size
if (.not. debug_exists) new_size = new_size + 1
if (.not. release_exists) new_size = new_size + 1
! If nothing to add, return
if (new_size == current_size) return
! Create new array with existing + missing defaults
allocate(temp_profiles(new_size))
! Copy existing profiles
if (current_size > 0) then
temp_profiles(1:current_size) = profiles(1:current_size)
end if
! Add missing defaults
i = current_size
if (.not. debug_exists) then
i = i + 1
temp_profiles(i) = default_profiles(1) ! debug profile
end if
if (.not. release_exists) then
i = i + 1
temp_profiles(i) = default_profiles(2) ! release profile
end if
! Replace the profiles array
call move_alloc(temp_profiles, profiles)
end subroutine add_default_profiles
end module fpm_manifest_profile
fortran-lang-fpm-90bb83a/src/fpm/manifest/test.f90 0000664 0001750 0001750 00000011741 15145116760 022152 0 ustar alastair alastair !> 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 : new_dependencies
use fpm_manifest_executable, only : executable_config_t
use fpm_error, only : error_t, syntax_error, bad_name_error
use tomlf, only : toml_table, toml_key, toml_stat
use fpm_toml, only : get_value, get_list
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
if (bad_name_error(error,'test',self%name))then
return
endif
call get_value(table, "source-dir", self%source_dir, "test")
call get_value(table, "main", self%main, "main.f90")
call get_value(table, "dependencies", child, requested=.false.)
if (associated(child)) then
call new_dependencies(self%dependency, child, error=error)
if (allocated(error)) return
end if
call get_list(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
fortran-lang-fpm-90bb83a/src/fpm/manifest/package.f90 0000664 0001750 0001750 00000100756 15145116760 022573 0 ustar alastair alastair !> 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]
!>[profiles]
!>[build]
!>[install]
!>[fortran]
!>[[ executable ]]
!>[[ example ]]
!>[[ test ]]
!>[extra]
!>```
module fpm_manifest_package
use fpm_manifest_build, only: build_config_t, new_build_config
use fpm_manifest_dependency, only : dependency_config_t, new_dependencies
use fpm_manifest_profile, only : profile_config_t, new_profiles, add_default_profiles
use fpm_manifest_example, only : example_config_t, new_example
use fpm_manifest_executable, only : executable_config_t, new_executable
use fpm_manifest_fortran, only : fortran_config_t, new_fortran_config
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_manifest_preprocess, only : preprocess_config_t, new_preprocessors
use fpm_manifest_feature, only: feature_config_t, init_feature_components
use fpm_manifest_feature_collection, only: feature_collection_t, new_collections, add_default_features
use fpm_manifest_platform, only: platform_config_t
use fpm_strings, only: string_t
use fpm_filesystem, only : exists, getline, join_path
use fpm_error, only : error_t, fatal_error, syntax_error, bad_name_error
use tomlf, only : toml_table, toml_array, toml_key, toml_stat
use fpm_toml, only : get_value, len, serializable_t, set_value, set_string, set_list, add_table
use fpm_versioning, only : version_t, new_version
implicit none
private
public :: package_config_t, new_package
!> Package meta data
!> Package configuration data - extends a `feature_config_t` to represent the "default"
!> package feature. The following are now inherited from feature_config_t: name (but for package
!> it's the package name), description, compiler, os_type (defaults to id_all, OS_ALL for packages)
!> library, executable(:), dependency(:), dev_dependency(:), example(:), test(:), preprocess(:)
!> flags, c_flags, cxx_flags, link_time_flags, requires_features(:)
type, extends(feature_config_t) :: package_config_t
!> Package version (name is inherited from feature_config_t%name)
type(version_t) :: version
!> Package metadata (package-specific)
character(len=:), allocatable :: license
character(len=:), allocatable :: author
character(len=:), allocatable :: maintainer
character(len=:), allocatable :: copyright
!> Additional feature collections beyond the default package feature
type(feature_collection_t), allocatable :: features(:)
!> Profiles (collections of features)
type(profile_config_t), allocatable :: profiles(:)
contains
!> Print information on this instance
procedure :: info
!> Serialization interface
procedure :: serializable_is_same => manifest_is_same
procedure :: dump_to_toml
procedure :: load_from_toml
!> Check if any features has a cpp configuration
procedure :: has_cpp
!> Export package configuration with features applied
procedure :: export_config
!> Find feature by name, returns index or 0 if not found
procedure :: find_feature
!> Find profile by name, returns index or 0 if not found
procedure :: find_profile
end type package_config_t
character(len=*), parameter, private :: class_name = 'package_config_t'
contains
!> Construct a new package configuration from a TOML data structure
subroutine new_package(self, table, root, error)
!> Instance of the package configuration
type(package_config_t), intent(out) :: self
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> Root directory of the manifest
character(len=*), intent(in), optional :: root
!> Error handling
type(error_t), allocatable, intent(out) :: error
! Backspace (8), tabulator (9), newline (10), formfeed (12) and carriage
! return (13) are invalid in package names
character(len=*), parameter :: invalid_chars = &
achar(8) // achar(9) // achar(10) // achar(12) // achar(13)
type(toml_table), pointer :: child, node
type(toml_array), pointer :: children
character(len=:), allocatable :: version, version_file
integer :: ii, nn, stat, io
! Ensure metapackage data is initialized although off
call self%meta%reset()
call check(table, error)
if (allocated(error)) return
! Get package name and perform validation
call get_value(table, "name", self%name)
if (.not.allocated(self%name)) then
call syntax_error(error, "Could not retrieve package name")
return
end if
if (bad_name_error(error,'package',self%name)) return
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
! Get package-specific metadata
call get_value(table, "license", self%license)
call get_value(table, "author", self%author)
call get_value(table, "maintainer", self%maintainer)
call get_value(table, "copyright", self%copyright)
! Initialize shared feature components
call init_feature_components(self%feature_config_t, table, root=root, error=error)
if (allocated(error)) return
call get_value(table, "version", version, "0")
call new_version(self%version, version, error)
if (allocated(error) .and. present(root)) then
version_file = join_path(root, version)
if (exists(version_file)) then
deallocate(error)
open(file=version_file, newunit=io, iostat=stat)
if (stat == 0) then
call getline(io, version, iostat=stat)
end if
if (stat == 0) then
close(io, iostat=stat)
end if
if (stat == 0) then
call new_version(self%version, version, error)
else
call fatal_error(error, "Reading version number from file '" &
& //version_file//"' failed")
end if
end if
end if
if (allocated(error)) return
call get_value(table, "profiles", child, requested=.false.)
if (associated(child)) then
call new_profiles(self%profiles, child, error)
if (allocated(error)) return
else
! No profiles defined - start with empty array
allocate(self%profiles(0))
end if
call get_value(table, "features", child, requested=.false.)
if (associated(child)) then
! Parse features from manifest using new_collections
call new_collections(self%features, child, error)
if (allocated(error)) return
else
! No features defined - start with empty array
allocate(self%features(0))
end if
! Add default features and profiles if they don't already exist
call add_default_features(self%features, error)
if (allocated(error)) return
call add_default_profiles(self%profiles, error)
if (allocated(error)) return
! Validate profiles after all features and profiles have been loaded
call validate_profiles(self, error)
if (allocated(error)) return
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", "profiles", "features", "test", "executable", &
& "example", "library", "install", "extra", "preprocess", "fortran")
continue
end select
end do
if (allocated(error)) return
if (.not.name_present) then
call syntax_error(error, "Package name is not provided, please add a name entry")
end if
end subroutine check
!> Write information on instance
subroutine info(self, unit, verbosity)
!> Instance of the package configuration
class(package_config_t), intent(in) :: self
!> Unit for IO
integer, intent(in) :: unit
!> Verbosity of the printout
integer, intent(in), optional :: verbosity
integer :: pr, ii
character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', &
& fmti = '("#", 1x, a, t30, i0)'
if (present(verbosity)) then
pr = verbosity
else
pr = 1
end if
if (pr < 1) return
write(unit, fmt) "Package"
if (allocated(self%name)) then
write(unit, fmt) "- name", self%name
end if
call self%build%info(unit, pr - 1)
call self%install%info(unit, pr - 1)
if (allocated(self%library)) then
write(unit, fmt) "- target", "archive"
call self%library%info(unit, pr - 1)
end if
if (allocated(self%executable)) then
if (size(self%executable) > 1 .or. pr > 2) then
write(unit, fmti) "- executables", size(self%executable)
end if
do ii = 1, size(self%executable)
call self%executable(ii)%info(unit, pr - 1)
end do
end if
if (allocated(self%dependency)) then
if (size(self%dependency) > 1 .or. pr > 2) then
write(unit, fmti) "- dependencies", size(self%dependency)
end if
do ii = 1, size(self%dependency)
call self%dependency(ii)%info(unit, pr - 1)
end do
end if
if (allocated(self%example)) then
if (size(self%example) > 1 .or. pr > 2) then
write(unit, fmti) "- examples", size(self%example)
end if
do ii = 1, size(self%example)
call self%example(ii)%info(unit, pr - 1)
end do
end if
if (allocated(self%test)) then
if (size(self%test) > 1 .or. pr > 2) then
write(unit, fmti) "- tests", size(self%test)
end if
do ii = 1, size(self%test)
call self%test(ii)%info(unit, pr - 1)
end do
end if
if (allocated(self%dev_dependency)) then
if (size(self%dev_dependency) > 1 .or. pr > 2) then
write(unit, fmti) "- development deps.", size(self%dev_dependency)
end if
do ii = 1, size(self%dev_dependency)
call self%dev_dependency(ii)%info(unit, pr - 1)
end do
end if
if (allocated(self%profiles)) then
if (size(self%profiles) > 1 .or. pr > 2) then
write(unit, fmti) "- profiles", size(self%profiles)
end if
do ii = 1, size(self%profiles)
call self%profiles(ii)%info(unit, pr - 1)
end do
end if
end subroutine info
logical function manifest_is_same(this,that)
class(package_config_t), intent(in) :: this
class(serializable_t), intent(in) :: that
integer :: ii
manifest_is_same = .false.
select type (other=>that)
type is (package_config_t)
! Compare base fields
if (.not.this%feature_config_t==other%feature_config_t) return
! Manifest-specific fields
if (.not.this%version==other%version) return
if (allocated(this%license).neqv.allocated(other%license)) return
if (allocated(this%license)) then
if (.not.this%license==other%license) return
end if
if (allocated(this%author).neqv.allocated(other%author)) return
if (allocated(this%author)) then
if (.not.this%author==other%author) return
end if
if (allocated(this%maintainer).neqv.allocated(other%maintainer)) return
if (allocated(this%maintainer)) then
if (.not.this%maintainer==other%maintainer) return
end if
if (allocated(this%copyright).neqv.allocated(other%copyright)) return
if (allocated(this%copyright)) then
if (.not.this%copyright==other%copyright) return
end if
if (allocated(this%profiles).neqv.allocated(other%profiles)) return
if (allocated(this%profiles)) then
if (.not.size(this%profiles)==size(other%profiles)) return
do ii=1,size(this%profiles)
if (.not.this%profiles(ii)==other%profiles(ii)) return
end do
end if
class default
! Not the same type
return
end select
!> All checks passed!
manifest_is_same = .true.
end function manifest_is_same
!> Dump manifest to toml table
subroutine dump_to_toml(self, table, error)
!> Instance of the serializable object
class(package_config_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,ptr_pkg
character(30) :: unnamed
character(128) :: profile_name
! Dump feature first
call self%feature_config_t%dump_to_toml(table, error)
if (allocated(error)) return
! Package-specific fields
call set_string(table, "version", self%version%s(), error, class_name)
if (allocated(error)) return
call set_string(table, "license", self%license, error, class_name)
if (allocated(error)) return
call set_string(table, "author", self%author, error, class_name)
if (allocated(error)) return
call set_string(table, "maintainer", self%maintainer, error, class_name)
if (allocated(error)) return
call set_string(table, "copyright", self%copyright, error, class_name)
if (allocated(error)) return
if (allocated(self%profiles)) then
call add_table(table, "profiles", ptr_pkg)
if (.not. associated(ptr_pkg)) then
call fatal_error(error, class_name//" cannot create 'profiles' table ")
return
end if
do ii = 1, size(self%profiles)
associate (pkg => self%profiles(ii))
!> Duplicate profile names are possible, as multiple profiles are possible with the
!> same name, same compiler, etc. So, use a unique name here
write(profile_name,2) ii
call add_table(ptr_pkg, trim(profile_name), ptr, error, class_name//'(profiles)')
if (allocated(error)) return
call pkg%dump_to_toml(ptr, error)
if (allocated(error)) return
end associate
end do
end if
2 format('PROFILE_',i0)
end subroutine dump_to_toml
!> Read manifest from toml table (no checks made at this stage)
subroutine load_from_toml(self, table, error)
!> Instance of the serializable object
class(package_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_key), allocatable :: keys(:),pkg_keys(:)
integer :: ii, jj
character(len=:), allocatable :: flag
type(toml_table), pointer :: ptr,ptr_pkg
! Clean state
if (allocated(self%library)) deallocate(self%library)
if (allocated(self%executable)) deallocate(self%executable)
if (allocated(self%dependency)) deallocate(self%dependency)
if (allocated(self%dev_dependency)) deallocate(self%dev_dependency)
if (allocated(self%profiles)) deallocate(self%profiles)
if (allocated(self%example)) deallocate(self%example)
if (allocated(self%test)) deallocate(self%test)
if (allocated(self%preprocess)) deallocate(self%preprocess)
!> Load base fields
call self%feature_config_t%load_from_toml(table, error)
if (allocated(error)) return
call table%get_keys(keys)
call get_value(table, "license", self%license)
call get_value(table, "author", self%author)
call get_value(table, "maintainer", self%maintainer)
call get_value(table, "copyright", self%copyright)
call get_value(table, "version", flag)
call new_version(self%version, flag, error)
if (allocated(error)) then
error%message = class_name//': version error from TOML table - '//error%message
return
endif
sub_deps: do ii = 1, size(keys)
select case (keys(ii)%key)
case ("profiles")
call get_value(table, keys(ii), ptr)
if (.not.associated(ptr)) then
call fatal_error(error,class_name//': error retrieving profiles table')
return
end if
!> Read all packages
call ptr%get_keys(pkg_keys)
allocate(self%profiles(size(pkg_keys)))
do jj = 1, size(pkg_keys)
call get_value(ptr, pkg_keys(jj), ptr_pkg)
call self%profiles(jj)%load_from_toml(ptr_pkg, error)
if (allocated(error)) return
end do
case default
cycle sub_deps
end select
end do sub_deps
end subroutine load_from_toml
!> Export package configuration for a given (OS+compiler) platform
type(package_config_t) function export_config(self, platform, features, profile, verbose, error) result(cfg)
!> Instance of the package configuration
class(package_config_t), intent(in), target :: self
!> Target platform
type(platform_config_t), intent(in) :: platform
!> Optional list of features to apply (cannot be used with profile)
type(string_t), optional, intent(in), target :: features(:)
!> Optional profile name to apply (cannot be used with features)
character(len=*), optional, intent(in) :: profile
!> Verbose output flag
logical, optional, intent(in) :: verbose
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i, idx
type(string_t), pointer :: want_features(:)
logical :: apply_default
! Validate that both profile and features are not specified simultaneously
if (present(profile) .and. present(features)) then
call syntax_error(error, "Cannot specify both 'profile' and 'features' parameters simultaneously")
return
end if
! Copy the entire package configuration
cfg = self
! Determine which features to apply and whether to include the "default" profile.
! Default profile features are applied when:
! - No explicit profile/features are specified (implicit debug build)
! - The "debug" or "release" profile is requested
! Default profile features are NOT applied when:
! - An explicit features list is specified
! - A custom (non-debug/release) profile is requested
apply_default = .false.
if (present(features)) then
want_features => features
elseif (present(profile)) then
idx = find_profile(self, profile)
if (idx<=0) then
call fatal_error(error, "Cannot find profile "//profile//" in package "//self%name)
return
end if
want_features => self%profiles(idx)%features
apply_default = (profile == "debug" .or. profile == "release")
else
nullify(want_features)
apply_default = .true.
endif
! Apply "default" profile features first (baseline configuration)
if (apply_default) then
idx = find_profile(self, "default")
if (idx > 0) then
call apply_default_features(self, self%profiles(idx), cfg, platform, verbose, error)
if (allocated(error)) return
end if
end if
! Then apply the requested features on top
apply_features: if (associated(want_features)) then
do i=1,size(want_features)
! Find feature
idx = self%find_feature(want_features(i)%s)
if (idx<=0) then
call fatal_error(error, "Cannot find feature "//want_features(i)%s//&
" in package "//self%name)
return
end if
! Print feature collection info if verbose
if (present(verbose)) then
if (verbose) then
call print_feature_collection(self%features(idx), platform)
end if
end if
! Add it to the current configuration
call self%features(idx)%merge_into_package(cfg, platform, error)
if (allocated(error)) return
end do
end if apply_features
! Ensure allocatable fields are always allocated with default values if not already set
if (.not. allocated(cfg%build)) then
allocate(cfg%build)
cfg%build%auto_executables = .true.
cfg%build%auto_examples = .true.
cfg%build%auto_tests = .true.
cfg%build%module_naming = .false.
end if
if (.not. allocated(cfg%install)) then
allocate(cfg%install)
cfg%install%library = .false.
cfg%install%test = .false.
end if
if (.not. allocated(cfg%fortran)) then
allocate(cfg%fortran)
cfg%fortran%implicit_typing = .false.
cfg%fortran%implicit_external = .false.
cfg%fortran%source_form = 'free'
end if
end function export_config
!> Find profile by name, returns index or 0 if not found
function find_profile(self, profile_name) result(idx)
!> Instance of the package configuration
class(package_config_t), intent(in) :: self
!> Name of the feature to find
character(len=*), intent(in) :: profile_name
!> Index of the feature (0 if not found)
integer :: idx
integer :: i
idx = 0
! Check if features are allocated
if (.not. allocated(self%profiles)) return
! Search through features array
do i = 1, size(self%profiles)
if (allocated(self%profiles(i)%name)) then
if (self%profiles(i)%name == profile_name) then
idx = i
return
end if
end if
end do
end function find_profile
!> Apply all features from a profile into the package configuration
subroutine apply_default_features(self, prof, cfg, platform, verbose, error)
!> Instance of the package configuration
class(package_config_t), intent(in) :: self
!> Profile whose features to apply
type(profile_config_t), intent(in) :: prof
!> Package configuration to merge into
type(package_config_t), intent(inout) :: cfg
!> Target platform
type(platform_config_t), intent(in) :: platform
!> Verbose output flag
logical, optional, intent(in) :: verbose
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i, idx
if (.not. allocated(prof%features)) return
do i = 1, size(prof%features)
idx = self%find_feature(prof%features(i)%s)
if (idx <= 0) then
call fatal_error(error, "Cannot find feature "//prof%features(i)%s//&
" in package "//self%name)
return
end if
if (present(verbose)) then
if (verbose) then
call print_feature_collection(self%features(idx), platform)
end if
end if
call self%features(idx)%merge_into_package(cfg, platform, error)
if (allocated(error)) return
end do
end subroutine apply_default_features
!> Find feature by name, returns index or 0 if not found
function find_feature(self, feature_name) result(idx)
!> Instance of the package configuration
class(package_config_t), intent(in) :: self
!> Name of the feature to find
character(len=*), intent(in) :: feature_name
!> Index of the feature (0 if not found)
integer :: idx
integer :: i
idx = 0
! Check if features are allocated
if (.not. allocated(self%features)) return
! Search through features array
do i = 1, size(self%features)
if (allocated(self%features(i)%base%name)) then
if (self%features(i)%base%name == feature_name) then
idx = i
return
end if
end if
end do
end function find_feature
!> Validate profiles - check for duplicate names and valid feature references
subroutine validate_profiles(self, error)
!> Instance of the package configuration
class(package_config_t), intent(in) :: self
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i, j
! Check if profiles are allocated
if (.not. allocated(self%profiles)) return
! Check for duplicate profile names
do i = 1, size(self%profiles)
do j = i + 1, size(self%profiles)
if (allocated(self%profiles(i)%name) .and. allocated(self%profiles(j)%name)) then
if (self%profiles(i)%name == self%profiles(j)%name) then
call syntax_error(error, "Duplicate profile name '" // self%profiles(i)%name // "'")
return
end if
end if
end do
end do
! Check that all profile features reference valid features
do i = 1, size(self%profiles)
if (allocated(self%profiles(i)%features)) then
do j = 1, size(self%profiles(i)%features)
! Check if feature exists (case sensitive)
if (self%find_feature(self%profiles(i)%features(j)%s) == 0) then
call syntax_error(error, "Profile '" // self%profiles(i)%name // &
"' references undefined feature '" // self%profiles(i)%features(j)%s // "'")
return
end if
end do
end if
end do
end subroutine validate_profiles
!> Check if there is a CPP preprocessor configuration
elemental logical function has_cpp(self)
class(package_config_t), intent(in) :: self
integer :: i
has_cpp = self%feature_config_t%has_cpp()
if (has_cpp) return
if (.not.allocated(self%features)) return
do i=1,size(self%features)
has_cpp = self%features(i)%has_cpp()
if (has_cpp) return
end do
end function has_cpp
!> Print feature collection information in verbose mode
subroutine print_feature_collection(collection, platform)
use, intrinsic :: iso_fortran_env, only: stdout => output_unit
use fpm_compiler, only: compiler_name
use fpm_environment, only: os_name
use fpm_strings, only: string_cat
type(feature_collection_t), intent(in) :: collection
type(platform_config_t), intent(in) :: platform
type(feature_config_t) :: extracted
type(error_t), allocatable :: error_tmp
integer :: i, j, n_macros
! Extract the feature configuration for the target platform
extracted = collection%extract_for_target(platform, error_tmp)
if (allocated(error_tmp)) return
! Print header with feature name
if (allocated(extracted%name)) then
print *, '+ feature collection: ', trim(extracted%name)
end if
! Print platform information
print *, '+ platform: ', platform%compiler_name(), ' on ', platform%os_name()
! Print flags
if (allocated(extracted%flags)) then
print *, '+ flags: ', trim(extracted%flags)
end if
if (allocated(extracted%c_flags)) then
print *, '+ c-flags: ', trim(extracted%c_flags)
end if
if (allocated(extracted%cxx_flags)) then
print *, '+ cxx-flags: ', trim(extracted%cxx_flags)
end if
if (allocated(extracted%link_time_flags)) then
print *, '+ link-flags: ', trim(extracted%link_time_flags)
end if
! Print preprocessor macros
if (allocated(extracted%preprocess)) then
n_macros = 0
do i = 1, size(extracted%preprocess)
if (allocated(extracted%preprocess(i)%macros)) then
n_macros = n_macros + size(extracted%preprocess(i)%macros)
end if
end do
if (n_macros > 0) then
print *, '+ cpp-macros: yes (', n_macros, ' defined)'
do i = 1, size(extracted%preprocess)
if (allocated(extracted%preprocess(i)%macros)) then
do j = 1, size(extracted%preprocess(i)%macros)
print *, '+ - ', trim(extracted%preprocess(i)%macros(j)%s)
end do
end if
end do
else
print *, '+ cpp-macros: no'
end if
else
print *, '+ cpp-macros: no'
end if
! Print description if available
if (allocated(extracted%description)) then
print *, '+ description: ', trim(extracted%description)
end if
! Print number of variants in collection
if (allocated(collection%variants)) then
print *, '+ variants: ', size(collection%variants)
end if
end subroutine print_feature_collection
end module fpm_manifest_package
fortran-lang-fpm-90bb83a/src/fpm/manifest/executable.f90 0000664 0001750 0001750 00000026161 15145116760 023316 0 ustar alastair alastair !> 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, resize
use fpm_error, only : error_t, syntax_error, bad_name_error, fatal_error
use fpm_strings, only : string_t, operator(==)
use tomlf, only : toml_table, toml_key, toml_stat
use fpm_toml, only : get_value, get_list, serializable_t, add_table, &
set_string, set_list
implicit none
private
public :: executable_config_t, new_executable
!> Configuation meta data for an executable
type, extends(serializable_t) :: 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
!> Serialization interface
procedure :: serializable_is_same => exe_is_same
procedure :: dump_to_toml
procedure :: load_from_toml
end type executable_config_t
character(*), parameter, private :: class_name = '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
if (bad_name_error(error,'executable',self%name))then
return
endif
call get_value(table, "source-dir", self%source_dir, "app")
call get_value(table, "main", self%main, "main.f90")
call get_value(table, "dependencies", child, requested=.false.)
if (associated(child)) then
call new_dependencies(self%dependency, child, error=error)
if (allocated(error)) return
end if
call get_list(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
logical function exe_is_same(this,that)
class(executable_config_t), intent(in) :: this
class(serializable_t), intent(in) :: that
integer :: ii
exe_is_same = .false.
select type (other=>that)
type is (executable_config_t)
if (.not.this%link==other%link) return
if (allocated(this%name).neqv.allocated(other%name)) return
if (allocated(this%name)) then
if (.not.this%name==other%name) return
end if
if (allocated(this%source_dir).neqv.allocated(other%source_dir)) return
if (allocated(this%source_dir)) then
if (.not.this%source_dir==other%source_dir) return
end if
if (allocated(this%main).neqv.allocated(other%main)) return
if (allocated(this%main)) then
if (.not.this%main==other%main) return
end if
if (allocated(this%dependency).neqv.allocated(other%dependency)) return
if (allocated(this%dependency)) then
if (.not.(size(this%dependency)==size(other%dependency))) return
do ii = 1, size(this%dependency)
if (.not.(this%dependency(ii)==other%dependency(ii))) return
end do
end if
class default
! Not the same type
return
end select
!> All checks passed!
exe_is_same = .true.
end function exe_is_same
!> Dump install config to toml table
subroutine dump_to_toml(self, table, error)
!> Instance of the serializable object
class(executable_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Local variables
integer :: ierr, ii
type(toml_table), pointer :: ptr_deps,ptr
character(27) :: unnamed
call set_string(table, "name", self%name, error)
if (allocated(error)) return
call set_string(table, "source-dir", self%source_dir, error)
if (allocated(error)) return
call set_string(table, "main", self%main, error)
if (allocated(error)) return
if (allocated(self%dependency)) then
! Create dependency table
call add_table(table, "dependencies", ptr_deps)
if (.not. associated(ptr_deps)) then
call fatal_error(error, class_name//" cannot create dependency table ")
return
end if
do ii = 1, size(self%dependency)
associate (dep => self%dependency(ii))
!> Because dependencies are named, fallback if this has no name
!> So, serialization will work regardless of size(self%dep) == self%ndep
if (len_trim(dep%name)==0) then
write(unnamed,1) ii
call add_table(ptr_deps, trim(unnamed), ptr)
else
call add_table(ptr_deps, dep%name, ptr)
end if
if (.not. associated(ptr)) then
call fatal_error(error, class_name//" cannot create entry for dependency "//dep%name)
return
end if
call dep%dump_to_toml(ptr, error)
if (allocated(error)) return
end associate
end do
endif
call set_list(table, "link", self%link, error)
if (allocated(error)) return
1 format('UNNAMED_DEPENDENCY_',i0)
end subroutine dump_to_toml
!> Read install config from toml table (no checks made at this stage)
subroutine load_from_toml(self, table, error)
!> Instance of the serializable object
class(executable_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Local variables
type(toml_key), allocatable :: keys(:),dep_keys(:)
type(toml_table), pointer :: ptr_deps,ptr
integer :: ii, jj, ierr
call table%get_keys(keys)
call get_value(table, "name", self%name)
if (allocated(error)) return
call get_value(table, "source-dir", self%source_dir)
if (allocated(error)) return
call get_value(table, "main", self%main)
if (allocated(error)) return
call get_list(table, "link", self%link, error)
find_deps_table: do ii = 1, size(keys)
if (keys(ii)%key=="dependencies") then
call get_value(table, keys(ii), ptr_deps)
if (.not.associated(ptr_deps)) then
call fatal_error(error,class_name//': error retrieving dependency table from TOML table')
return
end if
!> Read all dependencies
call ptr_deps%get_keys(dep_keys)
call resize(self%dependency, size(dep_keys))
do jj = 1, size(dep_keys)
call get_value(ptr_deps, dep_keys(jj), ptr)
call self%dependency(jj)%load_from_toml(ptr, error)
if (allocated(error)) return
end do
exit find_deps_table
endif
end do find_deps_table
end subroutine load_from_toml
end module fpm_manifest_executable
fortran-lang-fpm-90bb83a/src/fpm/manifest/preprocess.f90 0000664 0001750 0001750 00000025174 15145116760 023365 0 ustar alastair alastair !> Implementation of the meta data for preprocessing.
!>
!> A preprocess table can currently have the following fields
!>
!> ```toml
!> [preprocess]
!> [preprocess.cpp]
!> suffixes = ["F90", "f90"]
!> directories = ["src/feature1", "src/models"]
!> macros = []
!> ```
module fpm_manifest_preprocess
use fpm_error, only : error_t, syntax_error
use fpm_strings, only : string_t, operator(==), add_strings
use tomlf, only : toml_table, toml_key, toml_stat
use fpm_toml, only : get_value, get_list, serializable_t, set_value, set_list, &
set_string
use,intrinsic :: iso_fortran_env, only : stderr=>error_unit
implicit none
private
public :: preprocess_config_t, new_preprocessors, operator(==)
!> Configuration meta data for a preprocessor
type, extends(serializable_t) :: preprocess_config_t
!> Name of the preprocessor
character(len=:), allocatable :: name
!> Suffixes of the files to be preprocessed
type(string_t), allocatable :: suffixes(:)
!> Directories to search for files to be preprocessed
type(string_t), allocatable :: directories(:)
!> Macros to be defined for the preprocessor
type(string_t), allocatable :: macros(:)
contains
!> Print information on this instance
procedure :: info
!> Initialization
procedure, private :: new_cpp_config_with_macros
procedure, private :: new_preprocess_config
generic :: new => new_cpp_config_with_macros, new_preprocess_config
!> Serialization interface
procedure :: serializable_is_same => preprocess_is_same
procedure :: dump_to_toml
procedure :: load_from_toml
!> Operations
procedure :: destroy
procedure :: add_config
!> Properties
procedure :: is_cpp
procedure :: is_fypp
end type preprocess_config_t
character(*), parameter, private :: class_name = 'preprocess_config_t'
contains
!> Construct a new cpp preprocessor configuration with a list of macros
subroutine new_cpp_config_with_macros(self, macros)
!> Instance of the preprocess configuration
class(preprocess_config_t), intent(out) :: self
!> List of macros
type(string_t), intent(in) :: macros(:)
call self%destroy()
!> Set cpp
self%name = "cpp"
!> Set macros
if (size(macros)<=0) then
allocate(self%macros(0))
else
allocate(self%macros, source=macros)
end if
end subroutine new_cpp_config_with_macros
!> Construct a new preprocess configuration from TOML data structure
subroutine new_preprocess_config(self, table, error)
!> Instance of the preprocess configuration
class(preprocess_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 table%get_key(self%name)
call get_list(table, "suffixes", self%suffixes, error)
if (allocated(error)) return
call get_list(table, "directories", self%directories, error)
if (allocated(error)) return
call get_list(table, "macros", self%macros, error)
if (allocated(error)) return
end subroutine new_preprocess_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(inout) :: error
character(len=:), allocatable :: name
type(toml_key), allocatable :: list(:)
integer :: ikey
call table%get_key(name)
call table%get_keys(list)
do ikey = 1, size(list)
select case(list(ikey)%key)
!> Valid keys.
case("suffixes", "directories", "macros")
case default
call syntax_error(error, "Key '"//list(ikey)%key//"' not allowed in preprocessor '"//name//"'."); exit
end select
end do
end subroutine check
!> Construct new preprocess array from a TOML data structure.
subroutine new_preprocessors(preprocessors, table, error)
!> Instance of the preprocess configuration
type(preprocess_config_t), allocatable, intent(out) :: preprocessors(:)
!> Instance of the 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 :: iprep, stat
call table%get_keys(list)
! An empty table is not allowed
if (size(list) == 0) then
call syntax_error(error, "No preprocessors defined")
end if
allocate(preprocessors(size(list)))
do iprep = 1, size(list)
call get_value(table, list(iprep)%key, node, stat=stat)
if (stat /= toml_stat%success) then
call syntax_error(error, "Preprocessor "//list(iprep)%key//" must be a table entry")
exit
end if
call preprocessors(iprep)%new(node, error)
if (allocated(error)) exit
end do
end subroutine new_preprocessors
!> Write information on this instance
subroutine info(self, unit, verbosity)
!> Instance of the preprocess configuration
class(preprocess_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) "Preprocessor"
if (allocated(self%name)) then
write(unit, fmt) "- name", self%name
end if
if (allocated(self%suffixes)) then
write(unit, fmt) " - suffixes"
do ilink = 1, size(self%suffixes)
write(unit, fmt) " - " // self%suffixes(ilink)%s
end do
end if
if (allocated(self%directories)) then
write(unit, fmt) " - directories"
do ilink = 1, size(self%directories)
write(unit, fmt) " - " // self%directories(ilink)%s
end do
end if
if (allocated(self%macros)) then
write(unit, fmt) " - macros"
do ilink = 1, size(self%macros)
write(unit, fmt) " - " // self%macros(ilink)%s
end do
end if
end subroutine info
logical function preprocess_is_same(this,that)
class(preprocess_config_t), intent(in) :: this
class(serializable_t), intent(in) :: that
integer :: istr
preprocess_is_same = .false.
select type (other=>that)
type is (preprocess_config_t)
if (allocated(this%name).neqv.allocated(other%name)) return
if (allocated(this%name)) then
if (.not.(this%name==other%name)) return
endif
if (.not.(this%suffixes==other%suffixes)) return
if (.not.(this%directories==other%directories)) return
if (.not.(this%macros==other%macros)) return
class default
! Not the same type
return
end select
!> All checks passed!
preprocess_is_same = .true.
end function preprocess_is_same
!> Dump install config to toml table
subroutine dump_to_toml(self, table, error)
!> Instance of the serializable object
class(preprocess_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call set_string(table, "name", self%name, error)
if (allocated(error)) return
call set_list(table, "suffixes", self%suffixes, error)
if (allocated(error)) return
call set_list(table, "directories", self%directories, error)
if (allocated(error)) return
call set_list(table, "macros", self%macros, error)
if (allocated(error)) return
end subroutine dump_to_toml
!> Read install config from toml table (no checks made at this stage)
subroutine load_from_toml(self, table, error)
!> Instance of the serializable object
class(preprocess_config_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
call get_value(table, "name", self%name)
call get_list(table, "suffixes", self%suffixes, error)
if (allocated(error)) return
call get_list(table, "directories", self%directories, error)
if (allocated(error)) return
call get_list(table, "macros", self%macros, error)
if (allocated(error)) return
end subroutine load_from_toml
!> Clean preprocessor structure
elemental subroutine destroy(this)
class(preprocess_config_t), intent(inout) :: this
if (allocated(this%name))deallocate(this%name)
if (allocated(this%suffixes))deallocate(this%suffixes)
if (allocated(this%directories))deallocate(this%directories)
if (allocated(this%macros))deallocate(this%macros)
end subroutine destroy
!> Add preprocessor settings
subroutine add_config(this,that)
class(preprocess_config_t), intent(inout) :: this
type(preprocess_config_t), intent(in) :: that
if (.not.that%is_cpp()) then
write(stderr, '(a)') 'Warning: Preprocessor ' // that%name // &
' is not supported; will ignore it'
return
end if
if (.not.allocated(this%name)) this%name = that%name
! Add macros
if (allocated(that%macros)) &
call add_strings(this%macros, that%macros)
! Add suffixes
if (allocated(that%suffixes)) &
call add_strings(this%suffixes, that%suffixes)
! Add directories
if (allocated(that%directories)) &
call add_strings(this%directories, that%directories)
end subroutine add_config
! Check cpp
elemental logical function is_cpp(this)
class(preprocess_config_t), intent(in) :: this
is_cpp = .false.
if (allocated(this%name)) is_cpp = this%name == "cpp"
end function is_cpp
! Check cpp
logical function is_fypp(this)
class(preprocess_config_t), intent(in) :: this
is_fypp = .false.
if (allocated(this%name)) is_fypp = this%name == "fypp"
end function is_fypp
end module fpm_manifest_preprocess
fortran-lang-fpm-90bb83a/src/fpm/manifest/meta.f90 0000664 0001750 0001750 00000042673 15145116760 022131 0 ustar alastair alastair !> Implementation of the metapackage configuration data.
!>
!> A metapackage table can currently have the following fields
!>
!>```toml
!>[metapackages]
!>fpm = "0.1.0"
!>openmp = bool
!>stdlib = bool
!>```
module fpm_manifest_metapackages
use fpm_error, only: error_t, fatal_error, syntax_error
use tomlf, only: toml_table, toml_key
use fpm_toml, only: get_value, set_value, set_string, add_table, serializable_t
use fpm_environment
implicit none
private
public :: metapackage_config_t, new_meta_config, is_meta_package
public :: metapackage_request_t, new_meta_request
!> Configuration data for a single metapackage request
type, extends(serializable_t) :: metapackage_request_t
!> Request flag
logical :: on = .false.
!> Metapackage name
character(len=:), allocatable :: name
!> Version Specification string
character(len=:), allocatable :: version
contains
procedure :: serializable_is_same => meta_request_same
procedure :: dump_to_toml => meta_request_dump
procedure :: load_from_toml => meta_request_load
end type metapackage_request_t
!> Configuration data for metapackages
type, extends(serializable_t) :: metapackage_config_t
!> Request MPI support
type(metapackage_request_t) :: mpi
!> Request OpenMP support
type(metapackage_request_t) :: openmp
!> Request stdlib support
type(metapackage_request_t) :: stdlib
!> fortran-lang minpack
type(metapackage_request_t) :: minpack
!> HDF5
type(metapackage_request_t) :: hdf5
!> NetCDF
type(metapackage_request_t) :: netcdf
!> BLAS
type(metapackage_request_t) :: blas
contains
procedure :: get_requests
!> Merge another config into this one (for propagating dependency metapackages)
procedure :: merge => meta_config_merge
! Cleanup configuration; assert package names
final :: meta_config_final
procedure :: reset => meta_config_reset
procedure :: serializable_is_same => meta_config_same
procedure :: dump_to_toml => meta_config_dump
procedure :: load_from_toml => meta_config_load
end type metapackage_config_t
contains
!> Destroy a metapackage request
elemental subroutine request_destroy(self)
class(metapackage_request_t), intent(inout) :: self
self%on = .false.
if (allocated(self%version)) deallocate(self%version)
if (allocated(self%name)) deallocate(self%name)
end subroutine request_destroy
!> Parse version string of a metapackage request
subroutine request_parse(self, version_request, error)
! Instance of this metapackage
type(metapackage_request_t), intent(inout) :: self
! Parse version request
character(len=*), intent(in) :: version_request
! Error message
type(error_t), allocatable, intent(out) :: error
! wildcard = use any versions
if (version_request=="*") then
! Any version is OK
self%on = .true.
self%version = version_request
else
call fatal_error(error,'Value <'//version_request//'> for metapackage '//self%name//&
'is not currently supported. Try "*" instead. ')
return
end if
end subroutine request_parse
!> Construct a new metapackage request from the dependencies table
subroutine new_meta_request(self, key, table, meta_allowed, error)
type(metapackage_request_t), intent(out) :: self
!> The package name
character(len=*), intent(in) :: key
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> List of keys allowed to be metapackages
logical, intent(in), optional :: meta_allowed(:)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i
character(len=:), allocatable :: value
logical, allocatable :: allow_meta(:)
type(toml_key), allocatable :: keys(:)
call request_destroy(self)
!> Set name
self%name = key
if (.not.is_meta_package(key)) then
call fatal_error(error,"Error reading fpm.toml: <"//key//"> is not a valid metapackage name")
return
end if
call table%get_keys(keys)
if (present(meta_allowed)) then
if (size(meta_allowed)/=size(keys)) then
call fatal_error(error,"Internal error: list of metapackage-enable entries does not match table size")
return
end if
allow_meta = meta_allowed
else
allocate(allow_meta(size(keys)),source=.true.)
endif
do i=1,size(keys)
if (.not.allow_meta(i)) cycle
if (keys(i)%key==key) then
call get_value(table, key, value)
if (.not. allocated(value)) then
call syntax_error(error, "Could not retrieve version string for metapackage key <"//key//">. Check syntax")
return
else
call request_parse(self, value, error)
return
endif
end if
end do
! If we reach here, key not present => request remains off
end subroutine new_meta_request
!> Construct a new build configuration from a TOML data structure
subroutine new_meta_config(self, table, meta_allowed, error)
!> Instance of the build configuration
type(metapackage_config_t), intent(out) :: self
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> List of keys allowed to be metapackages
logical, intent(in) :: meta_allowed(:)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: stat
!> The toml table is not checked here because it already passed
!> the "new_dependencies" check
call new_meta_request(self%openmp, "openmp", table, meta_allowed, error)
if (allocated(error)) return
call new_meta_request(self%stdlib, "stdlib", table, meta_allowed, error)
if (allocated(error)) return
call new_meta_request(self%minpack, "minpack", table, meta_allowed, error)
if (allocated(error)) return
call new_meta_request(self%mpi, "mpi", table, meta_allowed, error)
if (allocated(error)) return
call new_meta_request(self%hdf5, "hdf5", table, meta_allowed, error)
if (allocated(error)) return
call new_meta_request(self%netcdf, "netcdf", table, meta_allowed, error)
if (allocated(error)) return
call new_meta_request(self%blas, "blas", table, meta_allowed, error)
if (allocated(error)) return
end subroutine new_meta_config
!> Check local schema for allowed entries
logical function is_meta_package(key)
character(*), intent(in) :: key
select case (key)
case ("openmp","stdlib","mpi","minpack","hdf5","netcdf","blas")
is_meta_package = .true.
case default
is_meta_package = .false.
end select
end function is_meta_package
!> Return a list of metapackages requested for the current build
function get_requests(meta) result(requests)
class(metapackage_config_t), intent(in) :: meta
type(metapackage_request_t), allocatable :: requests(:)
integer :: nreq
nreq = count([ meta%mpi%on, &
meta%openmp%on, &
meta%stdlib%on, &
meta%minpack%on, &
meta%hdf5%on, &
meta%netcdf%on, &
meta%blas%on ])
allocate(requests(nreq)); if (nreq <= 0) return
nreq = 0
call add_if_active(meta%mpi ,requests,nreq)
call add_if_active(meta%openmp ,requests,nreq)
call add_if_active(meta%stdlib ,requests,nreq)
call add_if_active(meta%minpack,requests,nreq)
call add_if_active(meta%hdf5 ,requests,nreq)
call add_if_active(meta%netcdf ,requests,nreq)
call add_if_active(meta%blas ,requests,nreq)
contains
subroutine add_if_active(req,list,count)
type(metapackage_request_t), intent(in) :: req
type(metapackage_request_t), intent(inout) :: list(:)
integer, intent(inout) :: count
if (.not.req%on) return
count = count+1
list(count) = req
end subroutine add_if_active
end function get_requests
!> Merge another metapackage configuration into this one
!> This is used to propagate metapackage requests from dependencies to the main package
subroutine meta_config_merge(self, other)
class(metapackage_config_t), intent(inout) :: self
type(metapackage_config_t), intent(in) :: other
! Merge each metapackage request: if 'other' has it on, enable it in self
call merge_request(self%openmp, other%openmp)
call merge_request(self%stdlib, other%stdlib)
call merge_request(self%minpack, other%minpack)
call merge_request(self%mpi, other%mpi)
call merge_request(self%hdf5, other%hdf5)
call merge_request(self%netcdf, other%netcdf)
call merge_request(self%blas, other%blas)
contains
subroutine merge_request(self_req, other_req)
type(metapackage_request_t), intent(inout) :: self_req
type(metapackage_request_t), intent(in) :: other_req
! If other request is on and self is off, copy the request
if (other_req%on .and. .not. self_req%on) then
self_req%on = .true.
if (allocated(other_req%version)) self_req%version = other_req%version
end if
end subroutine merge_request
end subroutine meta_config_merge
logical function meta_request_same(this, that)
class(metapackage_request_t), intent(in) :: this
class(serializable_t), intent(in) :: that
meta_request_same = .false.
select type (other => that)
type is (metapackage_request_t)
if (this%on .neqv. other%on) return
if (allocated(this%name) .neqv. allocated(other%name)) return
if (allocated(this%version).neqv. allocated(other%version))return
if (allocated(this%name)) then; if (this%name /= other%name) return; end if
if (allocated(this%version)) then; if (this%version/= other%version)return; end if
class default
return
end select
meta_request_same = .true.
end function meta_request_same
subroutine meta_request_dump(self, table, error)
class(metapackage_request_t), intent(inout) :: self
type(toml_table), intent(inout) :: table
type(error_t), allocatable, intent(out) :: error
call set_value (table, "on", self%on, error, 'metapackage_request_t')
if (allocated(error)) return
call set_string(table, "name", self%name, error)
if (allocated(error)) return
call set_string(table, "version", self%version,error)
if (allocated(error)) return
end subroutine meta_request_dump
subroutine meta_request_load(self, table, error)
class(metapackage_request_t), intent(inout) :: self
type(toml_table), intent(inout) :: table
type(error_t), allocatable, intent(out) :: error
call get_value(table, "on", self%on)
call get_value(table, "name", self%name)
call get_value(table, "version", self%version)
end subroutine meta_request_load
logical function meta_config_same(this, that)
class(metapackage_config_t), intent(in) :: this
class(serializable_t), intent(in) :: that
meta_config_same = .false.
select type (other => that)
type is (metapackage_config_t)
if (.not. this%mpi == other%mpi) return
if (.not. this%openmp == other%openmp) return
if (.not. this%stdlib == other%stdlib) return
if (.not. this%minpack == other%minpack)return
if (.not. this%hdf5 == other%hdf5) return
if (.not. this%netcdf == other%netcdf) return
if (.not. this%blas == other%blas) return
meta_config_same = .true.
class default
return
end select
end function meta_config_same
subroutine meta_config_dump(self, table, error)
class(metapackage_config_t), intent(inout) :: self
type(toml_table), intent(inout) :: table
type(error_t), allocatable, intent(out) :: error
type(toml_table), pointer :: ptr
! openmp
call add_table(table, "openmp", ptr); if (.not.associated(ptr)) then
call fatal_error(error, "metapackage_config_t: cannot create 'openmp' table"); return
end if
call self%openmp%dump_to_toml(ptr, error); if (allocated(error)) return
! stdlib
call add_table(table, "stdlib", ptr); if (.not.associated(ptr)) then
call fatal_error(error, "metapackage_config_t: cannot create 'stdlib' table"); return
end if
call self%stdlib%dump_to_toml(ptr, error); if (allocated(error)) return
! minpack
call add_table(table, "minpack", ptr); if (.not.associated(ptr)) then
call fatal_error(error, "metapackage_config_t: cannot create 'minpack' table"); return
end if
call self%minpack%dump_to_toml(ptr, error); if (allocated(error)) return
! mpi
call add_table(table, "mpi", ptr); if (.not.associated(ptr)) then
call fatal_error(error, "metapackage_config_t: cannot create 'mpi' table"); return
end if
call self%mpi%dump_to_toml(ptr, error); if (allocated(error)) return
! hdf5
call add_table(table, "hdf5", ptr); if (.not.associated(ptr)) then
call fatal_error(error, "metapackage_config_t: cannot create 'hdf5' table"); return
end if
call self%hdf5%dump_to_toml(ptr, error); if (allocated(error)) return
! netcdf
call add_table(table, "netcdf", ptr); if (.not.associated(ptr)) then
call fatal_error(error, "metapackage_config_t: cannot create 'netcdf' table"); return
end if
call self%netcdf%dump_to_toml(ptr, error); if (allocated(error)) return
! blas
call add_table(table, "blas", ptr); if (.not.associated(ptr)) then
call fatal_error(error, "metapackage_config_t: cannot create 'blas' table"); return
end if
call self%blas%dump_to_toml(ptr, error); if (allocated(error)) return
end subroutine meta_config_dump
! Ensure the names of all packages are always defined
subroutine meta_config_final(self)
type(metapackage_config_t), intent(inout) :: self
call meta_config_reset(self)
end subroutine meta_config_final
! Ensure the names of all packages are always defined
subroutine meta_config_reset(self)
class(metapackage_config_t), intent(inout) :: self
call request_destroy(self%openmp); self%openmp%name = "openmp"
call request_destroy(self%stdlib); self%stdlib%name = "stdlib"
call request_destroy(self%minpack);self%minpack%name= "minpack"
call request_destroy(self%mpi); self%mpi%name = "mpi"
call request_destroy(self%hdf5); self%hdf5%name = "hdf5"
call request_destroy(self%netcdf); self%netcdf%name = "netcdf"
call request_destroy(self%blas); self%blas%name = "blas"
end subroutine meta_config_reset
subroutine meta_config_load(self, table, error)
class(metapackage_config_t), intent(inout) :: self
type(toml_table), intent(inout) :: table
type(error_t), allocatable, intent(out) :: error
type(toml_table), pointer :: ptr
! openmp
call get_value(table, "openmp", ptr)
if (associated(ptr)) call self%openmp%load_from_toml(ptr, error); if (allocated(error)) return
! stdlib
call get_value(table, "stdlib", ptr)
if (associated(ptr)) call self%stdlib%load_from_toml(ptr, error); if (allocated(error)) return
! minpack
call get_value(table, "minpack", ptr)
if (associated(ptr)) call self%minpack%load_from_toml(ptr, error); if (allocated(error)) return
! mpi
call get_value(table, "mpi", ptr)
if (associated(ptr)) call self%mpi%load_from_toml(ptr, error); if (allocated(error)) return
! hdf5
call get_value(table, "hdf5", ptr)
if (associated(ptr)) call self%hdf5%load_from_toml(ptr, error); if (allocated(error)) return
! netcdf
call get_value(table, "netcdf", ptr)
if (associated(ptr)) call self%netcdf%load_from_toml(ptr, error); if (allocated(error)) return
! blas
call get_value(table, "blas", ptr)
if (associated(ptr)) call self%blas%load_from_toml(ptr, error); if (allocated(error)) return
end subroutine meta_config_load
end module fpm_manifest_metapackages
fortran-lang-fpm-90bb83a/src/fpm/error.f90 0000664 0001750 0001750 00000011572 15145116760 020520 0 ustar alastair alastair !> Implementation of basic error handling.
module fpm_error
use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit
use fpm_strings, only : is_fortran_name, to_fortran_name
implicit none
private
public :: error_t
public :: fatal_error, syntax_error, file_not_found_error
public :: file_parse_error
public :: bad_name_error
public :: fpm_stop
!> Data type defining an error
type :: error_t
!> Error message
character(len=:), allocatable :: message
end type error_t
contains
!> Generic fatal runtime error
subroutine fatal_error(error, message)
!> Instance of the error data
type(error_t), allocatable, intent(out) :: error
!> Error message
character(len=*), intent(in) :: message
allocate(error)
error%message = message
end subroutine fatal_error
subroutine syntax_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 syntax_error
function bad_name_error(error, label,name)
!> Instance of the error data
type(error_t), allocatable, intent(out) :: error
!> Error message label to add to message
character(len=*), intent(in) :: label
!> name value to check
character(len=*), intent(in) :: name
logical :: bad_name_error
if(.not.is_fortran_name(to_fortran_name(name)))then
bad_name_error=.true.
allocate(error)
error%message = 'manifest file syntax error: '//label//' name must be composed only of &
&alphanumerics, "-" and "_" and start with a letter ::'//name
else
bad_name_error=.false.
endif
end function bad_name_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
subroutine fpm_stop(value,message)
! TODO: if verbose mode, call ERROR STOP instead of STOP
! TODO: if M_escape is used, add color
! to work with older compilers might need a case statement for values
!> value to use on STOP
integer, intent(in) :: value
!> Error message
character(len=*), intent(in) :: message
integer :: iostat
if(message/='')then
flush(unit=stderr,iostat=iostat)
flush(unit=stdout,iostat=iostat)
if(value>0)then
write(stderr,'(" ",a)')trim(message)
else
write(stderr,'(" ",a)')trim(message)
endif
flush(unit=stderr,iostat=iostat)
endif
stop value
end subroutine fpm_stop
end module fpm_error
fortran-lang-fpm-90bb83a/src/fpm/fpm_release.F90 0000664 0001750 0001750 00000002767 15145116760 021617 0 ustar alastair alastair !># Release parameters
!> Module fpm_release contains public constants storing this build's unique version IDs
module fpm_release
use fpm_versioning, only: version_t,new_version
use fpm_error, only: error_t, fpm_stop
implicit none
private
public :: fpm_version
public :: version_t
contains
!> Return the current fpm version from fpm_version_ID as a version type
type(version_t) function fpm_version()
type(error_t), allocatable :: error
! Fallback to last known version in case of undefined macro
#ifndef FPM_RELEASE_VERSION
# define FPM_RELEASE_VERSION 0.13.0
#endif
! Accept solution from https://stackoverflow.com/questions/31649691/stringify-macro-with-gnu-gfortran
! which provides the "easiest" way to pass a macro to a string in Fortran complying with both
! gfortran's "traditional" cpp and the standard cpp syntaxes
#ifdef __GFORTRAN__ /* traditional-cpp stringification */
# define STRINGIFY_START(X) "&
# define STRINGIFY_END(X) &X"
#else /* default stringification */
# define STRINGIFY_(X) #X
# define STRINGIFY_START(X) &
# define STRINGIFY_END(X) STRINGIFY_(X)
#endif
character (len=:), allocatable :: ver_string
ver_string = STRINGIFY_START(FPM_RELEASE_VERSION)
STRINGIFY_END(FPM_RELEASE_VERSION)
call new_version(fpm_version,ver_string,error)
if (allocated(error)) call fpm_stop(1,'*fpm*:internal error: cannot get version - '//error%message)
end function fpm_version
end module fpm_release
fortran-lang-fpm-90bb83a/src/fpm/dependency.f90 0000664 0001750 0001750 00000176605 15145116760 021516 0 ustar alastair alastair !> # 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, os_is_unix
use fpm_error, only: error_t, fatal_error
use fpm_filesystem, only: exists, join_path, mkdir, canon_path, windows_path, list_files, is_dir, basename, &
os_delete_dir, get_temp_filename, parent_dir
use fpm_git, only: git_target_revision, git_target_default, git_revision, serializable_t
use fpm_manifest, only: package_config_t, dependency_config_t, get_package_data, get_package_dependencies
use fpm_manifest_dependency, only: manifest_has_changed, dependency_destroy
use fpm_manifest_preprocess, only: operator(==)
use fpm_strings, only: string_t, operator(.in.), operator(==), str
use tomlf, only: toml_table, toml_key, toml_error, toml_load, toml_stat, toml_array, len, add_array
use fpm_toml, only: toml_serialize, get_value, set_value, add_table, set_string, get_list, set_list
use fpm_versioning, only: version_t, new_version
use fpm_settings, only: fpm_global_settings, get_global_settings, official_registry_base_url
use fpm_downloader, only: downloader_t
use jonquil, only: json_object
implicit none
private
public :: dependency_tree_t, new_dependency_tree, dependency_node_t, new_dependency_node, resize, &
& check_and_read_pkg_data, destroy_dependency_node
!> 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.
!> Dependency was loaded from a cache
logical :: cached = .false.
!> Internal: package dependencies of this node
type(string_t), allocatable :: package_dep(:)
contains
!> Update dependency from project manifest.
procedure :: register
!> Get dependency from the registry.
procedure :: get_from_registry
procedure, private :: get_from_local_registry
!> Print information on this instance
procedure :: info
!> Serialization interface
procedure :: serializable_is_same => dependency_node_is_same
procedure :: dump_to_toml => node_dump_to_toml
procedure :: load_from_toml => node_load_from_toml
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, extends(serializable_t) :: 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
!> Custom path to the global config file
character(len=:), allocatable :: path_to_config
contains
!> Overload procedure to add new dependencies to the tree
generic :: add => add_project, add_project_dependencies, add_dependencies, &
add_dependency, add_dependency_node
!> 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
!> Add a single dependency node to the dependency tree
procedure, private :: add_dependency_node
!> Resolve dependencies
generic :: resolve => resolve_dependencies, resolve_dependency
!> Resolve dependencies
procedure, private :: resolve_dependencies
!> Resolve dependency
procedure, private :: resolve_dependency
!> True if entity can be found
generic :: has => has_dependency
!> True if dependency is part of the tree
procedure, private :: has_dependency
!> Find a dependency in the tree
generic :: find => find_name
!> Find a dependency by its name
procedure, private :: find_name
!> Establish local link order for a node's package dependencies
procedure :: local_link_order
!> Depedendncy resolution finished
procedure :: finished
!> Reading of dependency tree
generic :: load_cache => load_cache_from_file, load_cache_from_unit, load_cache_from_toml
!> Read dependency tree from file
procedure, private :: load_cache_from_file
!> Read dependency tree from formatted unit
procedure, private :: load_cache_from_unit
!> Read dependency tree from TOML data structure
procedure, private :: load_cache_from_toml
!> Writing of dependency tree
generic :: dump_cache => dump_cache_to_file, dump_cache_to_unit, dump_cache_to_toml
!> Write dependency tree to file
procedure, private :: dump_cache_to_file
!> Write dependency tree to formatted unit
procedure, private :: dump_cache_to_unit
!> Write dependency tree to TOML data structure
procedure, private :: dump_cache_to_toml
!> Update dependency tree
generic :: update => update_dependency, update_tree
!> Update a list of dependencies
procedure, private :: update_dependency
!> Update all dependencies in the tree
procedure, private :: update_tree
!> Serialization interface
procedure :: serializable_is_same => dependency_tree_is_same
procedure :: dump_to_toml => tree_dump_to_toml
procedure :: load_from_toml => tree_load_from_toml
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, path_to_config, build_dir)
!> 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
!> Path to the global config file.
character(len=*), intent(in), optional :: path_to_config
!> Custom build directory
character(len=*), intent(in), optional :: build_dir
call resize(self%dep)
if (present(build_dir)) then
self%dep_dir = join_path(build_dir, "dependencies")
else
self%dep_dir = join_path("build", "dependencies")
end if
if (present(verbosity)) self%verbosity = verbosity
if (present(cache)) self%cache = cache
if (present(path_to_config)) self%path_to_config = path_to_config
end subroutine new_dependency_tree
!> Create a new dependency node from a configuration
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
!> Write information on instance
subroutine info(self, unit, verbosity)
!> Instance of the dependency configuration
class(dependency_node_t), intent(in) :: self
!> Unit for IO
integer, intent(in) :: unit
!> Verbosity of the printout
integer, intent(in), optional :: verbosity
integer :: pr, i
character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)'
if (present(verbosity)) then
pr = verbosity
else
pr = 1
end if
!> Call base object info
call self%dependency_config_t%info(unit, pr)
if (allocated(self%version)) then
write (unit, fmt) "- version", self%version%s()
end if
if (allocated(self%proj_dir)) then
write (unit, fmt) "- dir", self%proj_dir
end if
if (allocated(self%revision)) then
write (unit, fmt) "- revision", self%revision
end if
write (unit, fmt) "- done", merge('YES', 'NO ', self%done)
write (unit, fmt) "- update", merge('YES', 'NO ', self%update)
if (allocated(self%package_dep)) then
write(unit, fmt) " - package_dep "
do i = 1, size(self%package_dep)
write(unit, fmt) " - " // self%package_dep(i)%s
end do
end if
end subroutine info
!> 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
type(dependency_tree_t) :: cached
character(len=*), parameter :: root = '.'
integer :: id
if (.not. exists(self%dep_dir)) then
call mkdir(self%dep_dir)
end if
! 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
! After resolving all dependencies, check if we have cached ones to avoid updates
if (allocated(self%cache)) then
call new_dependency_tree(cached, verbosity=self%verbosity,cache=self%cache)
call cached%load_cache(self%cache, error)
if (allocated(error)) return
! Skip root node
do id = 2, cached%ndep
cached%dep(id)%cached = .true.
call self%add(cached%dep(id), error)
if (allocated(error)) return
end do
end if
! 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
! Resolve internal dependency graph and remove temporary package storage
call resolve_dependency_graph(self, package, error)
if (allocated(error)) return
if (allocated(self%cache)) then
call self%dump_cache(self%cache, error)
if (allocated(error)) return
end if
end subroutine add_project
subroutine resolve_dependency_graph(self, main, error)
!> Instance of the dependency tree
class(dependency_tree_t), intent(inout) :: self
!> Main project configuration
type(package_config_t), intent(in) :: main
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i,nit
integer, parameter :: MAXIT = 50
logical, allocatable :: finished(:)
type(string_t), allocatable :: old_package_dep(:)
if (self%ndep<1) then
call fatal_error(error, "Trying to compute the dependency graph of an empty tree")
return
end if
nit = 0
allocate(finished(self%ndep),source=.false.)
do while (.not.all(finished) .and. nit=MAXIT) call fatal_error(error, "Infinite loop detected computing the dependency graph")
contains
pure logical function all_alloc(this,that)
type(string_t), intent(in), allocatable :: this(:),that(:)
all_alloc = .false.
if (allocated(this).neqv.allocated(that)) return
if (.not.allocated(this)) then
all_alloc = .true.
else
if (size(this)/=size(that)) return
if (.not.(this==that)) return
all_alloc = .true.
end if
end function all_alloc
end subroutine resolve_dependency_graph
!> 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
!> Ensure allocation fits
call resize(self%dep,self%ndep)
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
!> Ensure allocation fits ndep
call resize(self%dep,self%ndep)
end subroutine add_dependencies
!> Add a single dependency node to the dependency tree
!> Dependency nodes contain additional information (version, git, revision)
subroutine add_dependency_node(self, dependency, error)
!> Instance of the dependency tree
class(dependency_tree_t), intent(inout) :: self
!> Dependency configuration to add
type(dependency_node_t), intent(in) :: dependency
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: id
if (self%has_dependency(dependency)) then
! A dependency with this same name is already in the dependency tree.
! Check if it needs to be updated
id = self%find(dependency%name)
! If this dependency was in the cache, and we're now requesting a different version
! in the manifest, ensure it is marked for update. Otherwise, if we're just querying
! the same dependency from a lower branch of the dependency tree, the existing one from
! the manifest has priority
if (dependency%cached) then
if (dependency_has_changed(dependency, self%dep(id), self%verbosity, self%unit)) then
if (self%verbosity > 0) write (self%unit, out_fmt) "Dependency change detected:", dependency%name
self%dep(id)%update = .true.
else
! Store the cached one
self%dep(id) = dependency
self%dep(id)%update = .false.
end if
end if
else
!> Safety: reallocate if necessary
if (size(self%dep)==self%ndep) call resize(self%dep,self%ndep+1)
! New dependency: add from scratch
self%ndep = self%ndep + 1
self%dep(self%ndep) = dependency
self%dep(self%ndep)%update = .false.
end if
end subroutine add_dependency_node
!> Add a single dependency to the dependency tree
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
type(dependency_node_t) :: node
call new_dependency_node(node, dependency)
call add_dependency_node(self, node, error)
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
character(len=:), allocatable :: proj_dir, 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 > 0) write (self%unit, out_fmt) "Update:", dep%name
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
!> Update whole dependency tree
subroutine update_tree(self, error)
!> Instance of the dependency tree
class(dependency_tree_t), intent(inout) :: self
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i
! Update dependencies where needed
do i = 1, self%ndep
call self%update(self%dep(i)%name, error)
if (allocated(error)) return
end do
end subroutine update_tree
!> 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
type(fpm_global_settings) :: global_settings
character(:), allocatable :: parent_directory
integer :: ii
! Register path to global config file if it was entered via the command line.
if (allocated(self%path_to_config)) then
if (len_trim(self%path_to_config) > 0) then
parent_directory = parent_dir(self%path_to_config)
if (len_trim(parent_directory) == 0) then
global_settings%path_to_config_folder = "."
else
global_settings%path_to_config_folder = parent_directory
end if
global_settings%config_file_name = basename(self%path_to_config)
end if
end if
call get_global_settings(global_settings, error)
if (allocated(error)) return
do ii = 1, self%ndep
call self%resolve(self%dep(ii), global_settings, 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, global_settings, 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
!> Global configuration settings.
type(fpm_global_settings), intent(in) :: global_settings
!> 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
else
call dependency%get_from_registry(proj_dir, global_settings, error)
if (allocated(error)) return
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", dependency%version%s(), &
"at", dependency%proj_dir
end if
call self%add(package, proj_dir, .false., error)
if (allocated(error)) return
end subroutine resolve_dependency
!> Get a dependency from the registry. Whether the dependency is fetched
!> from a local, a custom remote or the official registry is determined
!> by the global configuration settings.
subroutine get_from_registry(self, target_dir, global_settings, error, downloader_)
!> Instance of the dependency configuration.
class(dependency_node_t), intent(in) :: self
!> The target directory of the dependency.
character(:), allocatable, intent(out) :: target_dir
!> Global configuration settings.
type(fpm_global_settings), intent(in) :: global_settings
!> Error handling.
type(error_t), allocatable, intent(out) :: error
!> Downloader instance.
class(downloader_t), optional, intent(in) :: downloader_
character(:), allocatable :: cache_path, target_url, tmp_file
type(version_t) :: version
integer :: stat, unit
type(json_object) :: json
class(downloader_t), allocatable :: downloader
if (present(downloader_)) then
downloader = downloader_
else
allocate (downloader)
end if
! Use local registry if it was specified in the global config file.
if (allocated(global_settings%registry_settings%path)) then
call self%get_from_local_registry(target_dir, global_settings%registry_settings%path, error); return
end if
! Include namespace and package name in the cache path.
cache_path = join_path(global_settings%registry_settings%cache_path, self%namespace, self%name)
! Check cache before downloading from the remote registry if a specific version was requested. When no specific
! version was requested, do network request first to check which is the newest version.
if (allocated(self%requested_version)) then
if (exists(join_path(cache_path, self%requested_version%s(), 'fpm.toml'))) then
print *, "Using cached version of '", join_path(self%namespace, self%name, self%requested_version%s()), "'."
target_dir = join_path(cache_path, self%requested_version%s()); return
end if
end if
tmp_file = get_temp_filename()
open (newunit=unit, file=tmp_file, action='readwrite', iostat=stat)
if (stat /= 0) then
call fatal_error(error, "Error creating temporary file for downloading package '"//self%name//"'."); return
end if
! Include namespace and package name in the target url and download package data.
target_url = global_settings%registry_settings%url//'/packages/'//self%namespace//'/'//self%name
call downloader%get_pkg_data(target_url, self%requested_version, tmp_file, json, error)
close (unit, status='delete')
if (allocated(error)) return
! Verify package data and read relevant information.
call check_and_read_pkg_data(json, self, target_url, version, error)
if (allocated(error)) return
! Open new tmp file for downloading the actual package.
open (newunit=unit, file=tmp_file, action='readwrite', iostat=stat)
if (stat /= 0) then
call fatal_error(error, "Error creating temporary file for downloading package '"//self%name//"'."); return
end if
! Include version number in the cache path. If no cached version exists, download it.
cache_path = join_path(cache_path, version%s())
if (.not. exists(join_path(cache_path, 'fpm.toml'))) then
if (is_dir(cache_path)) call os_delete_dir(os_is_unix(), cache_path)
call mkdir(cache_path)
call downloader%get_file(target_url, tmp_file, error)
if (allocated(error)) then
close (unit, status='delete'); return
end if
! Unpack the downloaded package to the final location.
call downloader%unpack(tmp_file, cache_path, error)
close (unit, status='delete')
if (allocated(error)) return
end if
target_dir = cache_path
end subroutine get_from_registry
subroutine check_and_read_pkg_data(json, node, download_url, version, error)
type(json_object), intent(inout) :: json
class(dependency_node_t), intent(in) :: node
character(:), allocatable, intent(out) :: download_url
type(version_t), intent(out) :: version
type(error_t), allocatable, intent(out) :: error
integer :: code, stat
type(json_object), pointer :: p, q
character(:), allocatable :: version_key, version_str, error_message, namespace, name
namespace = ""
name = "UNNAMED_NODE"
if (allocated(node%namespace)) namespace = node%namespace
if (allocated(node%name)) name = node%name
if (.not. json%has_key('code')) then
call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': No status code."); return
end if
call get_value(json, 'code', code, stat=stat)
if (stat /= 0) then
call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': "// &
& "Failed to read status code."); return
end if
if (code /= 200) then
if (.not. json%has_key('message')) then
call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': No error message."); return
end if
call get_value(json, 'message', error_message, stat=stat)
if (stat /= 0) then
call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': "// &
& "Failed to read error message."); return
end if
call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"'. Status code: '"// &
& str(code)//"'. Error message: '"//error_message//"'."); return
end if
if (.not. json%has_key('data')) then
call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': No data."); return
end if
call get_value(json, 'data', p, stat=stat)
if (stat /= 0) then
call fatal_error(error, "Failed to read package data for '"//join_path(namespace, name)//"'."); return
end if
if (allocated(node%requested_version)) then
version_key = 'version_data'
else
version_key = 'latest_version_data'
end if
if (.not. p%has_key(version_key)) then
call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': No version data."); return
end if
call get_value(p, version_key, q, stat=stat)
if (stat /= 0) then
call fatal_error(error, "Failed to retrieve version data for '"//join_path(namespace, name)//"'."); return
end if
if (.not. q%has_key('download_url')) then
call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': No download url."); return
end if
call get_value(q, 'download_url', download_url, stat=stat)
if (stat /= 0) then
call fatal_error(error, "Failed to read download url for '"//join_path(namespace, name)//"'."); return
end if
download_url = official_registry_base_url//download_url
if (.not. q%has_key('version')) then
call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': No version found."); return
end if
call get_value(q, 'version', version_str, stat=stat)
if (stat /= 0) then
call fatal_error(error, "Failed to read version data for '"//join_path(namespace, name)//"'."); return
end if
call new_version(version, version_str, error)
if (allocated(error)) then
call fatal_error(error, "'"//version_str//"' is not a valid version for '"// &
& join_path(namespace, name)//"'."); return
end if
end subroutine
!> Get the dependency from a local registry.
subroutine get_from_local_registry(self, target_dir, registry_path, error)
!> Instance of the dependency configuration.
class(dependency_node_t), intent(in) :: self
!> The target directory to download the dependency to.
character(:), allocatable, intent(out) :: target_dir
!> The path to the local registry.
character(*), intent(in) :: registry_path
!> Error handling.
type(error_t), allocatable, intent(out) :: error
character(:), allocatable :: path_to_name
type(string_t), allocatable :: files(:)
type(version_t), allocatable :: versions(:)
type(version_t) :: version
integer :: i
path_to_name = join_path(registry_path, self%namespace, self%name)
if (.not. exists(path_to_name)) then
call fatal_error(error, "Dependency resolution of '"//self%name// &
& "': Directory '"//path_to_name//"' doesn't exist."); return
end if
call list_files(path_to_name, files)
if (size(files) == 0) then
call fatal_error(error, "No versions of '"//self%name//"' found in '"//path_to_name//"'."); return
end if
! Version requested, find it in the cache.
if (allocated(self%requested_version)) then
do i = 1, size(files)
! Identify directory that matches the version number.
if (files(i)%s == join_path(path_to_name, self%requested_version%s()) .and. is_dir(files(i)%s)) then
if (.not. exists(join_path(files(i)%s, 'fpm.toml'))) then
call fatal_error(error, "'"//files(i)%s//"' is missing an 'fpm.toml' file."); return
end if
target_dir = files(i)%s; return
end if
end do
call fatal_error(error, "Version '"//self%requested_version%s()//"' not found in '"//path_to_name//"'")
return
end if
! No specific version requested, therefore collect available versions.
allocate (versions(0))
do i = 1, size(files)
if (is_dir(files(i)%s)) then
call new_version(version, basename(files(i)%s), error)
if (allocated(error)) return
versions = [versions, version]
end if
end do
if (size(versions) == 0) then
call fatal_error(error, "No versions found in '"//path_to_name//"'"); return
end if
! Find the latest version.
version = versions(1)
do i = 1, size(versions)
if (versions(i) > version) version = versions(i)
end do
path_to_name = join_path(path_to_name, version%s())
if (.not. exists(join_path(path_to_name, 'fpm.toml'))) then
call fatal_error(error, "'"//path_to_name//"' is missing an 'fpm.toml' file."); return
end if
target_dir = path_to_name
end subroutine get_from_local_registry
!> True if dependency is part of the tree
pure logical function has_dependency(self, dependency)
!> Instance of the dependency tree
class(dependency_tree_t), intent(in) :: self
!> Dependency configuration to check
class(dependency_node_t), intent(in) :: dependency
has_dependency = self%find(dependency%name) /= 0
end function has_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
finished = all(self%dep(:self%ndep)%done)
end function finished
!> Update dependency from project manifest
subroutine register(node, package, root, fetch, revision, error)
!> Instance of the dependency node
class(dependency_node_t), intent(inout) :: node
!> 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
logical :: update
update = .false.
if (node%name /= package%name) then
call fatal_error(error, "Dependency name '"//package%name// &
& "' found, but expected '"//node%name//"' instead")
return
end if
node%version = package%version
node%proj_dir = root
if (allocated(node%git) .and. present(revision)) then
node%revision = revision
if (.not. fetch) then
! Change in revision ID was checked already. Only update if ALL git information is missing
update = .not. allocated(node%git%url)
end if
end if
if (update) node%update = update
node%done = .true.
end subroutine register
!> Capture the list of "required" packages while the manifest is loaded.
!> This subroutine should be called during the "resolve" phase, i.e. when the whole
!> dependency tree has been built already
subroutine get_required_packages(tree, node_ID, error)
!> Instance of the dependency tree
class(dependency_tree_t), intent(inout) :: tree
!> Instance of the dependency node
integer, intent(in) :: node_ID
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: nreq,k,id
type(dependency_config_t), allocatable :: dependency(:)
type(package_config_t) :: manifest
logical :: required(tree%ndep),main
associate(node => tree%dep(node_ID))
! Is the main project
main = node_ID==1
! Get manifest
call get_package_data(manifest, join_path(node%proj_dir,"fpm.toml"), error)
if (allocated(error)) return
call get_package_dependencies(manifest, main, dependency)
nreq = size(dependency)
! Translate names -> indices
required = .false.
do k = 1, nreq
id = tree%find(dependency(k)%name)
if (id<=0) then
! Shouldn't happen because tree already contains every dep
call fatal_error(error, "Internal error: "//trim(node%name)// &
& " cannot find resolved dependency "//trim(dependency(k)%name)//" in tree")
return
end if
! Recurse dependencies
call recurse_deps(tree, id, required)
end do
! Recursed list
nreq = count(required)
if (allocated(node%package_dep)) deallocate(node%package_dep)
allocate(node%package_dep(nreq))
k = 0
do id=1,tree%ndep
if (.not.required(id)) cycle
k = k+1
node%package_dep(k) = string_t(tree%dep(id)%name)
end do
endassociate
contains
recursive subroutine recurse_deps(tree, id, required)
class(dependency_tree_t), intent(in) :: tree
integer, intent(in) :: id
logical, intent(inout) :: required(:)
integer :: j,dep_id
if (required(id)) return
required(id) = .true.
if (allocated(tree%dep(id)%package_dep)) then
do j = 1, size(tree%dep(id)%package_dep)
dep_id = tree%find(tree%dep(id)%package_dep(j)%s)
call recurse_deps(tree, dep_id, required)
end do
end if
end subroutine recurse_deps
end subroutine get_required_packages
!> Build a correct topological link order for a given dependency node.
!>
!> This routine returns the list of dependencies required to build `root_id`,
!> sorted such that each dependency appears *before* any node that depends on it.
!> This is suitable for correct linker ordering: `-lA -lB` means B can use symbols from A.
!>
!> The returned list includes both the transitive dependencies and the node itself.
!> Example: if node 3 requires [5, 7, 9, 2] and 9 also requires 2,
!> then the result will ensure that 2 appears before 9, etc.
subroutine local_link_order(tree, root_id, order, error)
!> The full dependency graph
class(dependency_tree_t), intent(in) :: tree
!> Index of the node for which to compute link order (e.g., the target being linked)
integer, intent(in) :: root_id
!> Ordered list of dependency indices (subset of tree%dep(:)) in link-safe order
integer, allocatable, intent(out) :: order(:)
!> Optional fatal error if a cycle is detected (not expected)
type(error_t), allocatable, intent(out) :: error
!> Track which nodes have been visited
logical, allocatable :: visited(:)
!> Work stack holding post-order DFS traversal
integer, allocatable :: stack(:)
!> Total number of nodes and current stack position
integer :: n, top
n = tree%ndep
allocate(visited(n), source=.false.)
allocate(stack(n), source=0)
top = 0
!> Depth-First Search from root node
call dfs(root_id,visited,stack,top,error)
if (allocated(error)) return
!> The final link order is the reverse of the DFS post-order
allocate(order(top))
if (top>0) order(:) = stack(:top)
contains
!> Recursive depth-first search, post-order
recursive subroutine dfs(i,visited,stack,top,error)
integer, intent(in) :: i
logical, intent(inout) :: visited(:)
integer, intent(inout) :: stack(:),top
type(error_t), allocatable, intent(out) :: error
integer :: k, id
if (.not.(i>0 .and. i<=tree%ndep)) then
call fatal_error(error,'package graph failed: invalid dependency ID')
return
end if
if (visited(i)) return
visited(i) = .true.
! Visit all required dependencies before this node
if (allocated(tree%dep(i)%package_dep)) then
do k = 1, size(tree%dep(i)%package_dep)
id = tree%find(tree%dep(i)%package_dep(k)%s)
if (.not.(id>0 .and. id<=tree%ndep)) then
call fatal_error(error,'package graph failed: cannot find '//tree%dep(i)%package_dep(k)%s)
return
end if
call dfs(id, visited, stack, top, error)
if (allocated(error)) return
end do
end if
! Now that all dependencies are handled, record this node
top = top + 1
stack(top) = i
end subroutine dfs
end subroutine local_link_order
!> Read dependency tree from file
subroutine load_cache_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_cache(unit, error)
close (unit)
end subroutine load_cache_from_file
!> Read dependency tree from file
subroutine load_cache_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_load(table, unit, error=parse_error)
if (allocated(parse_error)) then
allocate (error)
call move_alloc(parse_error%message, error%message)
return
end if
call self%load_cache(table, error)
if (allocated(error)) return
end subroutine load_cache_from_unit
!> Read dependency tree from TOML data structure
subroutine load_cache_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 :: is_unix
character(len=:), allocatable :: version, url, obj, rev, proj_dir
type(toml_key), allocatable :: list(:)
type(toml_table), pointer :: ptr
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
is_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 (is_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(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_cache_from_toml
!> Write dependency tree to file
subroutine dump_cache_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_cache(unit, error)
close (unit)
if (allocated(error)) return
end subroutine dump_cache_to_file
!> Write dependency tree to file
subroutine dump_cache_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
table = toml_table()
call self%dump_cache(table, error)
write (unit, '(a)') toml_serialize(table)
end subroutine dump_cache_to_unit
!> Write dependency tree to TOML datastructure
subroutine dump_cache_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", dep%version%s())
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_cache_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
!> Check if a dependency node has changed
logical function dependency_has_changed(cached, manifest, verbosity, iunit) result(has_changed)
!> Two instances of the same dependency to be compared
type(dependency_node_t), intent(in) :: cached, manifest
!> Log verbosity
integer, intent(in) :: verbosity, iunit
integer :: ip
has_changed = .true.
!> All the following entities must be equal for the dependency to not have changed
if (manifest_has_changed(cached=cached, manifest=manifest, verbosity=verbosity, iunit=iunit)) return
!> For now, only perform the following checks if both are available. A dependency in cache.toml
!> will always have this metadata; a dependency from fpm.toml which has not been fetched yet
!> may not have it
if (allocated(cached%version) .and. allocated(manifest%version)) then
if (cached%version /= manifest%version) then
if (verbosity > 1) write (iunit, out_fmt) "VERSION has changed: "//cached%version%s()//" vs. "//manifest%version%s()
return
end if
else
if (verbosity > 1) write (iunit, out_fmt) "VERSION has changed presence "
end if
if (allocated(cached%revision) .and. allocated(manifest%revision)) then
if (cached%revision /= manifest%revision) then
if (verbosity > 1) write (iunit, out_fmt) "REVISION has changed: "//cached%revision//" vs. "//manifest%revision
return
end if
else
if (verbosity > 1) write (iunit, out_fmt) "REVISION has changed presence "
end if
if (allocated(cached%proj_dir) .and. allocated(manifest%proj_dir)) then
if (cached%proj_dir /= manifest%proj_dir) then
if (verbosity > 1) write (iunit, out_fmt) "PROJECT DIR has changed: "//cached%proj_dir//" vs. "//manifest%proj_dir
return
end if
else
if (verbosity > 1) write (iunit, out_fmt) "PROJECT DIR has changed presence "
end if
if (allocated(cached%preprocess) .eqv. allocated(manifest%preprocess)) then
if (allocated(cached%preprocess)) then
if (size(cached%preprocess) /= size(manifest%preprocess)) then
if (verbosity > 1) write (iunit, out_fmt) "PREPROCESS has changed size"
return
end if
do ip=1,size(cached%preprocess)
if (.not.(cached%preprocess(ip) == manifest%preprocess(ip))) then
if (verbosity > 1) write (iunit, out_fmt) "PREPROCESS config has changed"
return
end if
end do
endif
else
if (verbosity > 1) write (iunit, out_fmt) "PREPROCESS has changed presence "
return
end if
!> All checks passed: the two dependencies have no differences
has_changed = .false.
end function dependency_has_changed
!> Check that two dependency nodes are equal
logical function dependency_node_is_same(this,that)
class(dependency_node_t), intent(in) :: this
class(serializable_t), intent(in) :: that
dependency_node_is_same = .false.
select type (other=>that)
type is (dependency_node_t)
! Base class must match
if (.not.(this%dependency_config_t==other%dependency_config_t)) return
! Extension must match
if (.not.(this%done .eqv.other%done)) return
if (.not.(this%update.eqv.other%update)) return
if (.not.(this%cached.eqv.other%cached)) return
if (allocated(this%proj_dir) .neqv. allocated(other%proj_dir)) return
if (allocated(this%proj_dir)) then
if (.not.(this%proj_dir==other%proj_dir)) return
endif
if (allocated(this%revision) .neqv. allocated(other%revision)) return
if (allocated(this%revision)) then
if (.not.(this%revision==other%revision)) return
endif
if (allocated(this%version).neqv.allocated(other%version)) return
if (allocated(this%version)) then
if (.not.(this%version==other%version)) return
endif
if (allocated(this%package_dep).neqv.allocated(other%package_dep)) return
if (allocated(this%package_dep)) then
if (.not.size(this%package_dep)==size(other%package_dep)) return
if (.not.(this%package_dep==other%package_dep)) return
endif
class default
! Not the same type
return
end select
!> All checks passed!
dependency_node_is_same = .true.
end function dependency_node_is_same
!> Dump dependency to toml table
subroutine node_dump_to_toml(self, table, error)
!> Instance of the serializable object
class(dependency_node_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: i,n,ierr
type(toml_array), pointer :: array
! Dump parent class
call self%dependency_config_t%dump_to_toml(table, error)
if (allocated(error)) return
if (allocated(self%version)) then
call set_string(table, "version", self%version%s(), error,'dependency_node_t')
if (allocated(error)) return
endif
call set_string(table, "proj-dir", self%proj_dir, error, 'dependency_node_t')
if (allocated(error)) return
call set_string(table, "revision", self%revision, error, 'dependency_node_t')
if (allocated(error)) return
call set_value(table, "done", self%done, error, 'dependency_node_t')
if (allocated(error)) return
call set_value(table, "update", self%update, error, 'dependency_node_t')
if (allocated(error)) return
call set_value(table, "cached", self%cached, error, 'dependency_node_t')
if (allocated(error)) return
call set_list(table, "package-dep",self%package_dep, error)
if (allocated(error)) return
end subroutine node_dump_to_toml
!> Read dependency from toml table (no checks made at this stage)
subroutine node_load_from_toml(self, table, error)
!> Instance of the serializable object
class(dependency_node_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Local variables
character(len=:), allocatable :: version
integer :: ierr,i,n
type(toml_array), pointer :: array
call destroy_dependency_node(self)
! Load parent class
call self%dependency_config_t%load_from_toml(table, error)
if (allocated(error)) return
call get_value(table, "done", self%done, error, 'dependency_node_t')
if (allocated(error)) return
call get_value(table, "update", self%update, error, 'dependency_node_t')
if (allocated(error)) return
call get_value(table, "cached", self%cached, error, 'dependency_node_t')
if (allocated(error)) return
call get_value(table, "proj-dir", self%proj_dir)
call get_value(table, "revision", self%revision)
call get_value(table, "version", version)
if (allocated(version)) then
allocate(self%version)
call new_version(self%version, version, error)
if (allocated(error)) then
error%message = 'dependency_node_t: version error from TOML table - '//error%message
return
endif
end if
call get_list(table,"package-dep",self%package_dep, error)
if (allocated(error)) return
end subroutine node_load_from_toml
!> Destructor
elemental subroutine destroy_dependency_node(self)
class(dependency_node_t), intent(inout) :: self
integer :: ierr
call dependency_destroy(self)
deallocate(self%version,stat=ierr)
deallocate(self%proj_dir,stat=ierr)
deallocate(self%revision,stat=ierr)
deallocate(self%package_dep,stat=ierr)
self%done = .false.
self%update = .false.
self%cached = .false.
end subroutine destroy_dependency_node
!> Check that two dependency trees are equal
logical function dependency_tree_is_same(this,that)
class(dependency_tree_t), intent(in) :: this
class(serializable_t), intent(in) :: that
integer :: ii
dependency_tree_is_same = .false.
select type (other=>that)
type is (dependency_tree_t)
if (.not.(this%unit==other%unit)) return
if (.not.(this%verbosity==other%verbosity)) return
if (allocated(this%dep_dir) .neqv. allocated(other%dep_dir)) return
if (allocated(this%dep_dir)) then
if (.not.(this%dep_dir==other%dep_dir)) return
endif
if (.not.(this%ndep==other%ndep)) return
if (.not.(allocated(this%dep).eqv.allocated(other%dep))) return
if (allocated(this%dep)) then
if (.not.(size(this%dep)==size(other%dep))) return
do ii = 1, size(this%dep)
if (.not.(this%dep(ii)==other%dep(ii))) return
end do
endif
if (allocated(this%cache) .neqv. allocated(other%cache)) return
if (allocated(this%cache)) then
if (.not.(this%cache==other%cache)) return
endif
class default
! Not the same type
return
end select
!> All checks passed!
dependency_tree_is_same = .true.
end function dependency_tree_is_same
!> Dump dependency to toml table
subroutine tree_dump_to_toml(self, table, error)
!> Instance of the serializable object
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 :: ierr, ii
type(toml_table), pointer :: ptr_deps,ptr
character(27) :: unnamed
call set_value(table, "unit", self%unit, error, 'dependency_tree_t')
if (allocated(error)) return
call set_value(table, "verbosity", self%verbosity, error, 'dependency_tree_t')
if (allocated(error)) return
call set_string(table, "dep-dir", self%dep_dir, error, 'dependency_tree_t')
if (allocated(error)) return
call set_string(table, "cache", self%cache, error, 'dependency_tree_t')
if (allocated(error)) return
call set_value(table, "ndep", self%ndep, error, 'dependency_tree_t')
if (allocated(error)) return
if (allocated(self%dep)) then
! Create dependency table
call add_table(table, "dependencies", ptr_deps)
if (.not. associated(ptr_deps)) then
call fatal_error(error, "dependency_tree_t cannot create dependency table ")
return
end if
do ii = 1, size(self%dep)
associate (dep => self%dep(ii))
!> Because dependencies are named, fallback if this has no name
!> So, serialization will work regardless of size(self%dep) == self%ndep
if (.not. allocated(dep%name)) then
write(unnamed,1) ii
call add_table(ptr_deps, trim(unnamed), ptr)
else if (len_trim(dep%name)==0) then
write(unnamed,1) ii
call add_table(ptr_deps, trim(unnamed), ptr)
else
call add_table(ptr_deps, dep%name, ptr)
end if
if (.not. associated(ptr)) then
call fatal_error(error, "dependency_tree_t cannot create entry for dependency "//dep%name)
return
end if
call dep%dump_to_toml(ptr, error)
if (allocated(error)) return
end associate
end do
endif
1 format('UNNAMED_DEPENDENCY_',i0)
end subroutine tree_dump_to_toml
!> Read dependency from toml table (no checks made at this stage)
subroutine tree_load_from_toml(self, table, error)
!> Instance of the serializable object
class(dependency_tree_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Local variables
type(toml_key), allocatable :: keys(:),dep_keys(:)
type(toml_table), pointer :: ptr_deps,ptr
integer :: ii, jj, ierr
call table%get_keys(keys)
call get_value(table, "unit", self%unit, error, 'dependency_tree_t')
if (allocated(error)) return
call get_value(table, "verbosity", self%verbosity, error, 'dependency_tree_t')
if (allocated(error)) return
call get_value(table, "ndep", self%ndep, error, 'dependency_tree_t')
if (allocated(error)) return
call get_value(table, "dep-dir", self%dep_dir)
call get_value(table, "cache", self%cache)
find_deps_table: do ii = 1, size(keys)
if (keys(ii)%key=="dependencies") then
call get_value(table, keys(ii), ptr_deps)
if (.not.associated(ptr_deps)) then
call fatal_error(error,'dependency_tree_t: error retrieving dependency table from TOML table')
return
end if
!> Read all dependencies
call ptr_deps%get_keys(dep_keys)
call resize(self%dep, size(dep_keys))
do jj = 1, size(dep_keys)
call get_value(ptr_deps, dep_keys(jj), ptr)
call self%dep(jj)%load_from_toml(ptr, error)
if (allocated(error)) return
end do
exit find_deps_table
endif
end do find_deps_table
end subroutine tree_load_from_toml
end module fpm_dependency
fortran-lang-fpm-90bb83a/src/fpm/versioning.f90 0000664 0001750 0001750 00000027114 15145116760 021551 0 ustar alastair alastair !> Implementation of versioning data for comparing packages
module fpm_versioning
use fpm_error, only : error_t, syntax_error
use fpm_strings, only: string_t
use regex_module, only: regex
implicit none
private
public :: version_t, new_version
public :: regex_version_from_text
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 :: s
end type version_t
!> Arbitrary internal limit of the version parser
integer, parameter :: max_limit = 3
interface new_version
module procedure :: new_version_from_string
module procedure :: new_version_from_int
end interface new_version
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
integer :: istart, iend, stat, nn
integer :: num(max_limit)
logical :: is_number
nn = 0
iend = 0
istart = 0
is_number = .false.
do while(iend < len(string))
call next(string, istart, iend, is_number, error)
if (allocated(error)) exit
if (is_number) then
if (nn >= max_limit) then
call token_error(error, string, istart, iend, &
& "Too many subversions found")
exit
end if
nn = nn + 1
read(string(istart:iend), *, iostat=stat) num(nn)
if (stat /= 0) then
call token_error(error, string, istart, iend, &
& "Failed to parse version number")
exit
end if
end if
end do
if (allocated(error)) return
if (.not.is_number) then
call token_error(error, string, istart, iend, &
& "Expected version number, but no characters are left")
return
end if
call new_version(self, num(:nn))
end subroutine new_version_from_string
!> 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
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
pure function s(self) result(string)
!> Version number
class(version_t), intent(in) :: self
!> Character representation of the version
character(len=:), allocatable :: string
integer, parameter :: buffersize = 64
character(len=buffersize) :: buffer
integer :: ii
do ii = 1, ndigits(self)
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 function s
!> 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, lhs_size, rhs_size
do ii = 1, min(ndigits(lhs),ndigits(rhs))
if (lhs%num(ii) /= rhs%num(ii)) then
is_greater = lhs%num(ii) > rhs%num(ii)
return
end if
end do
is_greater = ndigits(lhs) > ndigits(rhs)
if (is_greater) then
do ii = ndigits(rhs) + 1, ndigits(lhs)
is_greater = lhs%num(ii) > 0
if (is_greater) return
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
!> Number of digits
elemental integer function ndigits(self)
class(version_t), intent(in) :: self
if (allocated(self%num)) then
ndigits = size(self%num)
else
ndigits = 0
end if
end function ndigits
! Extract canonical version flags "1.0.0" or "1.0" as the first instance inside a text
! (whatever long) using regex
type(string_t) function regex_version_from_text(text,what,error) result(ver)
character(*), intent(in) :: text
character(*), intent(in) :: what
type(error_t), allocatable, intent(out) :: error
integer :: ire, length
if (len_trim(text)<=0) then
call syntax_error(error,'cannot retrieve '//what//' version: empty input string')
return
end if
! Extract 3-sized version "1.0.4"
ire = regex(text,'\d+\.\d+\.\d+',length=length)
if (ire>0 .and. length>0) then
! Parse version into the object (this should always work)
ver = string_t(text(ire:ire+length-1))
else
! Try 2-sized version "1.0"
ire = regex(text,'\d+\.\d+',length=length)
if (ire>0 .and. length>0) then
ver = string_t(text(ire:ire+length-1))
else
call syntax_error(error,'cannot retrieve '//what//' version.')
end if
end if
end function regex_version_from_text
end module fpm_versioning
fortran-lang-fpm-90bb83a/src/fpm/cmd/ 0000775 0001750 0001750 00000000000 15145116760 017604 5 ustar alastair alastair fortran-lang-fpm-90bb83a/src/fpm/cmd/export.f90 0000664 0001750 0001750 00000005277 15145116760 021460 0 ustar alastair alastair module fpm_cmd_export
use fpm_command_line, only : fpm_export_settings
use fpm_dependency, only : dependency_tree_t, new_dependency_tree
use fpm_error, only : error_t, fpm_stop
use fpm_filesystem, only : join_path
use fpm_manifest, only : package_config_t, get_package_data
use fpm_toml, only: name_is_json
use fpm_model, only: fpm_model_t
use fpm, only: build_model
implicit none
private
public :: cmd_export
contains
!> Entry point for the export subcommand
subroutine cmd_export(settings)
!> Representation of the command line arguments
type(fpm_export_settings), intent(inout) :: settings
type(package_config_t) :: package
type(dependency_tree_t) :: deps
type(fpm_model_t) :: model
type(error_t), allocatable :: error
character(len=:), allocatable :: filename
if (len_trim(settings%dump_manifest)<=0 .and. &
len_trim(settings%dump_model)<=0 .and. &
len_trim(settings%dump_dependencies)<=0) then
call fpm_stop(0,'*cmd_export* exiting: no manifest/model/dependencies keyword provided')
end if
!> Read in manifest
call get_package_data(package, "fpm.toml", error, apply_defaults=.true.)
call handle_error(error)
!> Export manifest
if (len_trim(settings%dump_manifest)>0) then
filename = trim(settings%dump_manifest)
call package%dump(filename, error, json=name_is_json(filename))
end if
!> Export dependency tree
if (len_trim(settings%dump_dependencies)>0) then
!> Generate dependency tree
filename = join_path(settings%build_dir, "cache.toml")
call new_dependency_tree(deps, cache=filename, verbosity=merge(2, 1, settings%verbose), build_dir=settings%build_dir)
call deps%add(package, error)
call handle_error(error)
!> Export dependency tree
filename = settings%dump_dependencies
call deps%dump(filename, error, json=name_is_json(filename))
call handle_error(error)
end if
!> Export full model
if (len_trim(settings%dump_model)>0) then
call build_model(model, settings%fpm_build_settings, package, error)
if (allocated(error)) then
call fpm_stop(1,'*cmd_export* Model error: '//error%message)
end if
filename = settings%dump_model
call model%dump(filename, error, json=name_is_json(filename))
call handle_error(error)
end if
end subroutine cmd_export
!> Error handling for this command
subroutine handle_error(error)
!> Potential error
type(error_t), intent(in), optional :: error
if (present(error)) then
call fpm_stop(1, '*cmd_export* error: '//error%message)
end if
end subroutine handle_error
end module fpm_cmd_export
fortran-lang-fpm-90bb83a/src/fpm/cmd/install.f90 0000664 0001750 0001750 00000016002 15145116760 021571 0 ustar alastair alastair module fpm_cmd_install
use, intrinsic :: iso_fortran_env, only : output_unit
use fpm, only : build_model
use fpm_backend, only : build_package
use fpm_command_line, only : fpm_install_settings
use fpm_error, only : error_t, fatal_error, fpm_stop
use fpm_filesystem, only : join_path, list_files
use fpm_installer, only : installer_t, new_installer
use fpm_manifest, only : package_config_t, get_package_data
use fpm_model, only : fpm_model_t, FPM_SCOPE_APP, FPM_SCOPE_TEST
use fpm_targets, only: targets_from_sources, build_target_t, &
build_target_ptr, FPM_TARGET_EXECUTABLE, &
filter_library_targets, filter_executable_targets, filter_modules
use fpm_strings, only : string_t, resize
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(inout) :: settings
type(package_config_t) :: package
type(error_t), allocatable :: error
type(fpm_model_t) :: model
type(build_target_ptr), allocatable :: targets(:), libraries(:)
type(installer_t) :: installer
type(string_t), allocatable :: list(:)
logical :: installable, has_install, with_library, with_tests
logical :: has_library, has_executables
character(len=:), allocatable :: module_dir
integer :: ntargets,i
call get_package_data(package, "fpm.toml", error, apply_defaults=.true.)
call handle_error(error)
call build_model(model, settings, package, error)
call handle_error(error)
! Set up logical variables to avoid repetitive conditions
has_install = allocated(package%install)
has_library = allocated(package%library)
has_executables = allocated(package%executable)
if (has_install) then
with_library = has_install .and. package%install%library
with_tests = has_install .and. package%install%test
! Set module directory (or leave unallocated because `optional`)
if (allocated(package%install%module_dir)) module_dir = package%install%module_dir
else
with_library = .false.
with_tests = .false.
endif
! ifx bug: does not resolve allocatable -> optional
if (has_library) then
call targets_from_sources(targets, model, settings%prune, package%library, error)
else
call targets_from_sources(targets, model, settings%prune, error=error)
endif
call handle_error(error)
call install_info(output_unit, settings%list, targets, ntargets)
if (settings%list) return
installable = (has_library .and. with_library) .or. has_executables .or. ntargets>0
if (.not.installable) then
call fatal_error(error, "Project does not contain any installable targets")
call handle_error(error)
end if
if (.not.settings%no_rebuild) then
call build_package(targets,model,verbose=settings%verbose,dry_run=settings%list)
end if
call new_installer(installer, prefix=settings%prefix, &
bindir=settings%bindir, libdir=settings%libdir, testdir=settings%testdir, &
includedir=settings%includedir, moduledir=module_dir, &
verbosity=merge(2, 1, settings%verbose))
if (has_library .and. with_library) then
call filter_library_targets(targets, libraries)
if (size(libraries) > 0) then
do i=1,size(libraries)
call installer%install_library(libraries(i)%ptr, error)
call handle_error(error)
end do
call install_module_files(installer, targets, error)
call handle_error(error)
end if
end if
if (has_executables .or. ntargets>0) then
call install_executables(installer, targets, error)
call handle_error(error)
end if
if (allocated(package%test) .and. (with_tests .or. model%include_tests)) then
call install_tests(installer, targets, error)
call handle_error(error)
end if
end subroutine cmd_install
subroutine install_info(unit, verbose, targets, ntargets)
integer, intent(in) :: unit
logical, intent(in) :: verbose
type(build_target_ptr), intent(in) :: targets(:)
integer, intent(out) :: ntargets
integer :: ii
type(string_t), allocatable :: install_target(:), apps(:), tests(:)
type(build_target_ptr), allocatable :: libs(:)
call filter_library_targets(targets, libs)
call filter_executable_targets(targets, FPM_SCOPE_APP, apps)
call filter_executable_targets(targets, FPM_SCOPE_TEST, tests)
ntargets = size(libs) + size(apps) + size(tests)
allocate(install_target(ntargets))
do ii = 1, size(libs)
install_target(ii) = string_t(libs(ii)%ptr%output_file)
end do
do ii = 1, size(apps)
install_target(size(libs) + ii) = string_t(apps(ii)%s)
end do
do ii = 1, size(tests)
install_target(size(libs) + size(apps) + ii) = string_t(tests(ii)%s)
end do
if (verbose) then
write(unit, '("#", *(1x, g0))') &
"total number of installable targets:", ntargets
do ii = 1, ntargets
write(unit, '("-", *(1x, g0))') install_target(ii)%s
end do
endif
end subroutine install_info
subroutine install_module_files(installer, targets, error)
type(installer_t), intent(inout) :: installer
type(build_target_ptr), intent(in) :: targets(:)
type(error_t), allocatable, intent(out) :: error
type(string_t), allocatable :: modules(:)
integer :: ii
call filter_modules(targets, modules)
do ii = 1, size(modules)
call installer%install_module(modules(ii)%s//".mod", error)
if (allocated(error)) exit
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 (targets(ii)%ptr%is_executable_target(FPM_SCOPE_APP)) 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
subroutine install_tests(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 (targets(ii)%ptr%is_executable_target(FPM_SCOPE_TEST)) then
call installer%install_test(targets(ii)%ptr%output_file, error)
if (allocated(error)) exit
end if
end do
if (allocated(error)) return
end subroutine install_tests
subroutine handle_error(error)
type(error_t), intent(in), optional :: error
if (present(error)) then
call fpm_stop(1,'*cmd_install* error: '//error%message)
end if
end subroutine handle_error
end module fpm_cmd_install
fortran-lang-fpm-90bb83a/src/fpm/cmd/new.f90 0000664 0001750 0001750 00000142362 15145116760 020725 0 ustar alastair alastair 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 : OS_LINUX, OS_MACOS, OS_WINDOWS
use fpm_filesystem, only : join_path, exists, basename, mkdir, is_dir
use fpm_filesystem, only : fileopen, fileclose, warnwrite, which, run
use fpm_strings, only : join, to_fortran_name
use fpm_error, only : fpm_stop
use,intrinsic :: iso_fortran_env, only : stderr=>error_unit
implicit none
private
public :: cmd_new
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)
littlefile=[character(len=80) :: '# '//bname, 'My cool new project!']
! create NAME/README.md
call warnwrite(join_path(settings%name, 'README.md'), littlefile)
! start building NAME/fpm.toml
if(settings%with_full)then
tomlfile=[character(len=80) :: &
&' # This is your fpm(Fortran Package Manager) manifest file ',&
&' # ("fpm.toml"). It is heavily annotated to help guide you though ',&
&' # customizing a package build, although the defaults are sufficient ',&
&' # for many basic packages. ',&
&' # ',&
&' # The manifest file is not only used to provide metadata identifying ',&
&' # your project (so it can be used by others as a dependency). It can ',&
&' # specify where your library and program sources live, what the name ',&
&' # of the executable(s) will be, what files to build, dependencies on ',&
&' # other fpm packages, and what external libraries are required. ',&
&' # ',&
&' # The manifest format must conform to the TOML configuration file ',&
&' # standard. ',&
&' # ',&
&' # TOML files support flexible use of white-space and commenting of the ',&
&' # configuration data, but for clarity in this sample active directives ',&
&' # begin in column one. Inactive example directives are commented ',&
&' # out with a pound character ("#") but begin in column one as well. ',&
&' # Commentary begins with a pound character in column three. ',&
&' # ',&
&' # This file draws heavily upon the following references: ',&
&' # ',&
&' # The fpm home page at ',&
&' # https://github.com/fortran-lang/fpm ',&
&' # A complete list of keys and their attributes at ',&
&' # https://github.com/fortran-lang/fpm/blob/main/manifest-reference.md ',&
&' # examples of fpm project packaging at ',&
&' # https://github.com/fortran-lang/fpm/blob/main/PACKAGING.md ',&
&' # The Fortran TOML file interface and it''s references at ',&
&' # https://github.com/toml-f/toml-f ',&
&' # ',&
&' #----------------------- ',&
&' # project Identification ',&
&' #----------------------- ',&
&' # We begin with project metadata at the manifest root. This data is designed ',&
&' # to aid others when searching for the project in a repository and to ',&
&' # identify how and when to contact the package supporters. ',&
&' ',&
&'name = "'//bname//'"',&
&' # The project name (required) is how the project will be referred to. ',&
&' # The name is used by other packages using it as a dependency. It also ',&
&' # is used as the default name of any library built and the optional ',&
&' # default executable built from app/main.f90. It must conform to the rules ',&
&' # for a Fortran variable name. ',&
&' ',&
&'version = "0.1.0" ',&
&' # The project version number is a string. A recommended scheme for ',&
&' # specifying versions is the Semantic Versioning scheme. ',&
&' ',&
&'license = "license" ',&
&' # Licensing information specified using SPDX identifiers is preferred ',&
&' # (eg. "Apache-2.0 OR MIT" or "LGPL-3.0-or-later"). ',&
&' ',&
&'maintainer = "jane.doe@example.com" ',&
&' # Information on the project maintainer and means to reach out to them. ',&
&' ',&
&'author = "Jane Doe" ',&
&' # Information on the project author. ',&
&' ',&
&'copyright = "Copyright 2020 Jane Doe" ',&
&' # A statement clarifying the Copyright status of the project. ',&
&' ',&
&'#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. ',&
&' ',&
&' # If your project sets `[library] type = "shared"`, enabling this option ',&
&' # will install the compiled `.so`, `.dylib`, or `.dll` files into the ',&
&' # appropriate `lib/` folder. This applies equally to static archives. ',&
&' # ',&
&' # For shared libraries, installing is typically required for runtime usage. ',&
&' ',&
&'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. ',&
&' ',&
&' ### Library type ',&
&' # Set `type = "shared"` to build dynamic libraries (.so/.dylib/.dll) ',&
&' # instead of a static archive. You can also set `type = "static"` to ',&
&' # generate per-package archives, or use `type = "monolithic"` (default) ',&
&' # to bundle all sources and dependencies into a single archive. ',&
&' # ',&
&' # Supported types: ',&
&' # ',&
&' # + "monolithic": Single archive with used sources and dependencies. ',&
&' # + "static": One full archive per package (for external integration). ',&
&' # + "shared": One shared library per package, for dynamic linking. ',&
&' # ',&
&' # Shared libraries are useful for plugin systems, dynamic linking, or ',&
&' # language bindings. Static per-package archives may aid external reuse. ',&
&' # ',&
&' # When running with `fpm run`, shared library paths are automatically ',&
&' # added to the environment (e.g. `LD_LIBRARY_PATH`, `PATH`) at runtime. ',&
&' # ',&
&' # Note: library files are not installed unless `[install] library=true` ',&
&' # is also enabled. ',&
&' # ',&
&' # Example: ',&
&' ',&
&'type = "shared" ',&
&' ',&
&'']
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 default branch is used. You can ',&
&' # optionally specify a branch, a tag or a commit value. ',&
&' # ',&
&' # So here are several alternates for specifying a remote dependency (you ',&
&' # can have at most one of "branch", "rev" or "tag" present): ',&
&' ',&
&'#stdlib = { git = "https://github.com/LKedward/stdlib-fpm.git" } ',&
&'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git",branch = "master" },',&
&'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git", tag = "v0.1.0" }, ',&
&'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git", rev = "5a9b7a8" }. ',&
&' ',&
&' # There may be multiple packages listed: ',&
&' ',&
&'#M_strings = { git = "https://github.com/urbanjost/M_strings.git" } ',&
&'#M_time = { git = "https://github.com/urbanjost/M_time.git" } ',&
&' ',&
&' # ',&
&' # You can even specify the local path to another project if it is in ',&
&' # a sub-folder (If for example you have got another fpm package **in ',&
&' # the same repository**) like this: ',&
&' ',&
&'#M_strings = { path = "M_strings" } ',&
&' ',&
&' # This tells fpm that we depend on a crate called M_strings which is found ',&
&' # in the M_strings folder (relative to the fpm.toml it’s written in). ',&
&' # ',&
&' # For a more verbose layout use normal tables rather than inline tables ',&
&' # to specify dependencies: ',&
&' ',&
&'#[dependencies.toml-f] ',&
&'#git = "https://github.com/toml-f/toml-f" ',&
&'#rev = "2f5eaba864ff630ba0c3791126a3f811b6e437f3" ',&
&' ',&
&' # Now you can use any modules from these libraries anywhere in your ',&
&' # code -- whether is in your library source or a program source. ',&
&' ',&
&'[dev-dependencies] ',&
&' ',&
&' ## Dependencies Only for Development ',&
&' # ',&
&' # You can specify dependencies your library or application does not ',&
&' # depend on in a similar way. The difference is that these will not ',&
&' # be exported as part of your project to those using it as a remote ',&
&' # dependency. ',&
&' # ',&
&' # Currently, like a global dependency it will still be available for ',&
&' # all codes. It is up to the developer to ensure that nothing except ',&
&' # developer test programs rely upon it. ',&
&' ',&
&'#M_msg = { git = "https://github.com/urbanjost/M_msg.git" } ',&
&'#M_verify = { git = "https://github.com/urbanjost/M_verify.git" } ',&
&'']
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
if(which('git')/='')then
call run('git init ' // settings%name)
endif
contains
function git_metadata(what) result(returned)
!> get metadata values such as email address and git name from git(1) or return appropriate default
use fpm_filesystem, only : get_temp_filename, getline
character(len=*), intent(in) :: what ! keyword designating what git metatdata to query
character(len=:), allocatable :: returned ! value to return for requested keyword
character(len=:), allocatable :: command
character(len=:), allocatable :: temp_filename
character(len=:), allocatable :: iomsg
character(len=:), allocatable :: temp_value
integer :: stat, unit
temp_filename = get_temp_filename()
! for known keywords set default value for RETURNED and associated git(1) command for query
select case(what)
case('uname')
returned = "Jane Doe"
command = "git config --get user.name > " // temp_filename
case('email')
returned = "jane.doe@example.com"
command = "git config --get user.email > " // temp_filename
case default
write(stderr,'(*(g0,1x))')&
& ' *git_metadata* unknown metadata name ',trim(what)
returned=''
return
end select
! Execute command if git(1) is in command path
if(which('git')/='')then
call run(command, exitstat=stat)
if (stat /= 0) then ! If command failed just return default
return
else ! Command did not return an error so try to read expected output file
open(file=temp_filename, newunit=unit,iostat=stat)
if(stat == 0)then
! Read file into a scratch variable until status of doing so is checked
call getline(unit, temp_value, stat, iomsg)
if (stat == 0 .and. temp_value /= '') then
! Return output from successful command
returned=temp_value
endif
endif
! Always do the CLOSE because a failed open has unpredictable results.
! Add IOSTAT so a failed close does not cause program to stop
close(unit, status="delete",iostat=stat)
endif
endif
end function git_metadata
subroutine create_verified_basic_manifest(filename)
!> create a basic but verified default manifest file
use tomlf, only : toml_table, toml_serialize
use fpm_toml, only : 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(package_config_t) :: package
type(error_t), allocatable :: error
integer :: lun
character(len=8) :: date
character(:), allocatable :: output
if(exists(filename))then
write(stderr,'(*(g0,1x))')' ',filename,&
& 'already exists. Not overwriting'
return
endif
!> get date to put into metadata in manifest file "fpm.toml"
call date_and_time(DATE=date)
table = toml_table()
call fileopen(filename,lun) ! fileopen stops on error
call set_value(table, "name", BNAME)
call set_value(table, "version", "0.1.0")
call set_value(table, "license", "license")
call set_value(table, "author", git_metadata('uname'))
call set_value(table, "maintainer", git_metadata('email'))
call set_value(table, "copyright", 'Copyright '//date(1:4)//', '//git_metadata('uname'))
! continue building of manifest
! ...
call new_package(package, table, error=error)
if (allocated(error)) call fpm_stop( 3,'')
output = toml_serialize(table)
if(settings%verbose)then
print '(a)', output
endif
write(lun, '(a)') output
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_table, toml_load, toml_serialize
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
! 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_load(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 by `toml_serialize` to the standard output
print '(a)', toml_serialize(table)
endif
call table%destroy
endif
end subroutine validate_toml_data
end subroutine cmd_new
end module fpm_cmd_new
fortran-lang-fpm-90bb83a/src/fpm/cmd/publish.f90 0000664 0001750 0001750 00000011674 15145116760 021603 0 ustar alastair alastair !> Upload a package to the registry using the `publish` command.
!>
!> To upload a package you need to provide a token that will be linked to your username and created for a namespace.
!> The token can be obtained from the registry website. It can be used as `fpm publish --token `.
module fpm_cmd_publish
use fpm_command_line, only: fpm_publish_settings
use fpm_manifest, only: package_config_t, get_package_data
use fpm_model, only: fpm_model_t
use fpm_error, only: error_t, fpm_stop
use fpm_versioning, only: version_t
use fpm_filesystem, only: exists, join_path, get_temp_filename, delete_file
use fpm_git, only: git_archive
use fpm_downloader, only: downloader_t
use fpm_strings, only: string_t
use fpm_settings, only: official_registry_base_url
use fpm, only: build_model
implicit none
private
public :: cmd_publish
contains
!> The `publish` command first builds the root package to obtain all the relevant information such as the
!> package version. It then creates a tarball of the package and uploads it to the registry.
subroutine cmd_publish(settings)
type(fpm_publish_settings), intent(inout) :: settings
type(package_config_t) :: package
type(fpm_model_t) :: model
type(error_t), allocatable :: error
type(version_t), allocatable :: version
type(string_t), allocatable :: upload_data(:)
character(len=:), allocatable :: tmp_file
type(downloader_t) :: downloader
integer :: i
! Get package data to determine package version.
call get_package_data(package, 'fpm.toml', error, apply_defaults=.true.)
if (allocated(error)) call fpm_stop(1, '*cmd_build* Package error: '//error%message)
version = package%version
if (settings%show_package_version) then
print *, version%s(); return
end if
!> Checks before uploading the package.
if (.not. allocated(package%license)) call fpm_stop(1, 'No license specified in fpm.toml.')
if (.not. package%build%module_naming) call fpm_stop(1, 'The package does not meet the module naming requirements. '// &
& 'Please set "module-naming = true" in fpm.toml [build] or specify a custom module prefix.')
if (.not. allocated(version)) call fpm_stop(1, 'No version specified in fpm.toml.')
if (version%s() == '0') call fpm_stop(1, 'Invalid version: "'//version%s()//'".')
if (.not. exists('fpm.toml')) call fpm_stop(1, "Cannot find 'fpm.toml' file. Are you in the project root?")
! Build model to obtain dependency tree.
call build_model(model, settings%fpm_build_settings, package, error)
if (allocated(error)) call fpm_stop(1, '*cmd_build* Model error: '//error%message)
! Check if package contains git dependencies. Only publish packages without git dependencies.
do i = 1, model%deps%ndep
if (allocated(model%deps%dep(i)%git)) then
call fpm_stop(1, 'Do not publish packages containing git dependencies. '// &
& "Please upload '"//model%deps%dep(i)%name//"' to the registry first.")
end if
end do
tmp_file = get_temp_filename()
call git_archive('.', tmp_file, 'HEAD', additional_files=['fpm_model.json'], verbose=settings%verbose, error=error)
if (allocated(error)) call fpm_stop(1, '*cmd_publish* Archive error: '//error%message)
call model%dump('fpm_model.json', error, json=.true.)
if (allocated(error)) call fpm_stop(1, '*cmd_publish* Model dump error: '//error%message)
upload_data = [ &
& string_t('package_name="'//package%name//'"'), &
& string_t('package_license="'//package%license//'"'), &
& string_t('package_version="'//version%s()//'"'), &
& string_t('tarball=@"'//tmp_file//'"') &
& ]
if (allocated(settings%token)) upload_data = [upload_data, string_t('upload_token="'//settings%token//'"')]
if (settings%show_upload_data) then
call print_upload_data(upload_data); return
end if
! Make sure a token is provided for publishing.
if (allocated(settings%token)) then
if (settings%token == '') then
call delete_file(tmp_file); call fpm_stop(1, 'No token provided.')
end if
else
call delete_file(tmp_file); call fpm_stop(1, 'No token provided.')
end if
if (settings%verbose) then
call print_upload_data(upload_data)
print *, ''
end if
! Perform network request and validate package, token etc. on the backend once
! https://github.com/fortran-lang/registry/issues/41 is resolved.
if (settings%is_dry_run) then
print *, 'Dry run successful. Generated tarball: ', tmp_file; return
end if
call downloader%upload_form(official_registry_base_url//'/packages', upload_data, settings%verbose, error)
call delete_file(tmp_file)
if (allocated(error)) call fpm_stop(1, '*cmd_publish* Upload error: '//error%message)
end
subroutine print_upload_data(upload_data)
type(string_t), intent(in) :: upload_data(:)
integer :: i
print *, 'Upload data:'
do i = 1, size(upload_data)
print *, upload_data(i)%s
end do
end
end
fortran-lang-fpm-90bb83a/src/fpm/cmd/update.f90 0000664 0001750 0001750 00000004642 15145116760 021414 0 ustar alastair alastair module fpm_cmd_update
use fpm_command_line, only : fpm_update_settings, get_fpm_env
use fpm_dependency, only : dependency_tree_t, new_dependency_tree
use fpm_error, only : error_t, fpm_stop
use fpm_filesystem, only : exists, mkdir, join_path, delete_file, filewrite
use fpm_manifest, only : package_config_t, get_package_data
use fpm_toml, only: name_is_json
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, build_dir
call get_package_data(package, "fpm.toml", error, apply_defaults=.true.)
call handle_error(error)
! Get build directory from environment variable or use default
build_dir = get_fpm_env("BUILD_DIR", "build")
if (.not. exists(build_dir)) then
call mkdir(build_dir)
call filewrite(join_path(build_dir, ".gitignore"),["*"])
end if
cache = join_path(build_dir, "cache.toml")
if (settings%clean) call delete_file(cache)
call new_dependency_tree(deps, cache=cache, verbosity=merge(2, 1, settings%verbose), &
& path_to_config=settings%path_to_config, build_dir=build_dir)
call deps%add(package, error)
call handle_error(error)
! Force-update all dependencies if `--clean`
if (settings%clean) then
do ii = 1, deps%ndep
deps%dep(ii)%update = .true.
end do
end if
if (settings%fetch_only) return
if (size(settings%name) == 0) then
call deps%update(error)
call handle_error(error)
else
do ii = 1, size(settings%name)
call deps%update(trim(settings%name(ii)), error)
call handle_error(error)
end do
end if
if (len_trim(settings%dump)>0) then
call deps%dump(trim(settings%dump), error, json=name_is_json(trim(settings%dump)))
call handle_error(error)
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
call fpm_stop(1, '*cmd_update* error: '//error%message)
end if
end subroutine handle_error
end module fpm_cmd_update
fortran-lang-fpm-90bb83a/src/fpm/toml.f90 0000664 0001750 0001750 00000065740 15145116760 020350 0 ustar alastair alastair !># 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, str_ends_with, lower
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_serialize, len, toml_load, toml_value
use tomlf_de_parser, only: parse
use jonquil, only: json_serialize, json_error, json_value, json_object, json_load, &
cast_to_object
use iso_fortran_env, only: int64
implicit none
private
public :: read_package_file, toml_table, toml_array, toml_key, toml_stat, &
get_value, set_value, get_list, new_table, add_table, add_array, len, &
toml_error, toml_serialize, toml_load, check_keys, set_list, set_string, &
name_is_json, has_list
!> An abstract interface for any fpm class that should be fully serializable to/from TOML/JSON
type, abstract, public :: serializable_t
contains
!> Dump to TOML table, unit, file
procedure(to_toml), deferred :: dump_to_toml
procedure, non_overridable, private :: dump_to_file
procedure, non_overridable, private :: dump_to_unit
generic :: dump => dump_to_toml, dump_to_file, dump_to_unit
!> Load from TOML table, unit, file
procedure(from_toml), deferred :: load_from_toml
procedure, non_overridable, private :: load_from_file
procedure, non_overridable, private :: load_from_unit
generic :: load => load_from_toml, load_from_file, load_from_unit
!> Serializable entities need a way to check that they're equal
procedure(is_equal), deferred :: serializable_is_same
generic :: operator(==) => serializable_is_same
!> Test load/write roundtrip
procedure, non_overridable :: test_serialization
end type serializable_t
!> add_table: fpm interface
interface add_table
module procedure add_table_fpm
end interface add_table
!> set_value: fpm interface
interface set_value
module procedure set_logical
module procedure set_integer
module procedure set_integer_64
end interface set_value
interface set_string
module procedure set_character
module procedure set_string_type
end interface set_string
!> get_value: fpm interface
interface get_value
module procedure get_logical
module procedure get_integer
module procedure get_integer_64
module procedure get_char
module procedure get_string
end interface get_value
abstract interface
!> Write object to TOML datastructure
subroutine to_toml(self, table, error)
import serializable_t,toml_table,error_t
implicit none
!> Instance of the serializable object
class(serializable_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
end subroutine to_toml
!> Read dependency tree from TOML data structure
subroutine from_toml(self, table, error)
import serializable_t,toml_table,error_t
implicit none
!> Instance of the serializable object
class(serializable_t), intent(inout) :: self
!> Data structure
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
end subroutine from_toml
!> Compare two serializable objects
logical function is_equal(this,that)
import serializable_t
class(serializable_t), intent(in) :: this,that
end function is_equal
end interface
contains
!> Test serialization of a serializable object
subroutine test_serialization(self, message, error)
class(serializable_t), intent(inout) :: self
character(len=*), intent(in) :: message
type(error_t), allocatable, intent(out) :: error
integer :: iunit, ii
class(serializable_t), allocatable :: copy
character(len=4), parameter :: formats(2) = ['TOML','JSON']
all_formats: do ii = 1, 2
open(newunit=iunit,form='formatted',action='readwrite',status='scratch')
!> Dump to scratch file
call self%dump(iunit, error, json=ii==2)
if (allocated(error)) then
error%message = formats(ii)//': '//error%message
return
endif
!> Load from scratch file
rewind(iunit)
allocate(copy,mold=self)
call copy%load(iunit,error, json=ii==2)
if (allocated(error)) then
error%message = formats(ii)//': '//error%message
return
endif
close(iunit)
!> Check same
if (.not.(self==copy)) then
call fatal_error(error,'serializable object failed '//formats(ii)//&
' write/reread test: '//trim(message))
return
end if
deallocate(copy)
end do all_formats
end subroutine test_serialization
!> Write serializable object to a formatted Fortran unit
subroutine dump_to_unit(self, unit, error, json)
!> Instance of the dependency tree
class(serializable_t), intent(inout) :: self
!> Formatted unit
integer, intent(in) :: unit
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional JSON format requested?
logical, optional, intent(in) :: json
type(toml_table) :: table
logical :: is_json
is_json = .false.; if (present(json)) is_json = json
table = toml_table()
call self%dump(table, error)
if (is_json) then
! !> Deactivate JSON serialization for now
! call fatal_error(error, 'JSON serialization option is not yet available')
! return
write (unit, '(a)') json_serialize(table)
else
write (unit, '(a)') toml_serialize(table)
end if
call table%destroy()
end subroutine dump_to_unit
!> Write serializable object to file
subroutine dump_to_file(self, file, error, json)
!> Instance of the dependency tree
class(serializable_t), intent(inout) :: self
!> File name
character(len=*), intent(in) :: file
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional JSON format
logical, optional, intent(in) :: json
integer :: unit
open (file=file, newunit=unit)
call self%dump(unit, error, json)
close (unit)
if (allocated(error)) return
end subroutine dump_to_file
!> Read dependency tree from file
subroutine load_from_file(self, file, error, json)
!> Instance of the dependency tree
class(serializable_t), intent(inout) :: self
!> File name
character(len=*), intent(in) :: file
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional JSON format
logical, optional, intent(in) :: json
integer :: unit
logical :: exist
inquire (file=file, exist=exist)
if (.not. exist) return
open (file=file, newunit=unit)
call self%load(unit, error, json)
close (unit)
end subroutine load_from_file
!> Read dependency tree from file
subroutine load_from_unit(self, unit, error, json)
!> Instance of the dependency tree
class(serializable_t), intent(inout) :: self
!> File name
integer, intent(in) :: unit
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional JSON format
logical, optional, intent(in) :: json
type(toml_error), allocatable :: local_error
type(toml_table), allocatable :: table
type(toml_table), pointer :: jtable
class(toml_value), allocatable :: object
logical :: is_json
is_json = .false.; if (present(json)) is_json = json
if (is_json) then
!> init JSON interpreter
call json_load(object, unit, error=local_error)
if (allocated(local_error)) then
allocate (error)
call move_alloc(local_error%message, error%message)
return
end if
jtable => cast_to_object(object)
if (.not.associated(jtable)) then
call fatal_error(error,'cannot initialize JSON table ')
return
end if
!> Read object from TOML table
call self%load(jtable, error)
else
!> use default TOML parser
call toml_load(table, unit, error=local_error)
if (allocated(local_error)) then
allocate (error)
call move_alloc(local_error%message, error%message)
return
end if
!> Read object from TOML table
call self%load(table, error)
endif
if (allocated(error)) return
end subroutine load_from_unit
!> 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_load(table, unit, error=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
!> Check if an instance of the TOML data structure contains a list
logical function has_list(table, key)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> Key to read from
character(len=*), intent(in) :: key
type(toml_array), pointer :: children
has_list = .false.
if (.not.table%has_key(key)) return
call get_value(table, key, children, requested=.false.)
! There is an allocated list
has_list = associated(children)
end function has_list
subroutine get_list(table, key, list, error)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> Key to read from
character(len=*), intent(in) :: key
!> List of strings to read
type(string_t), allocatable, intent(out) :: list(:)
!> Error handling
type(error_t), allocatable, intent(out) :: error
integer :: stat, ilist, nlist
type(toml_array), pointer :: children
character(len=:), allocatable :: str
if (.not.table%has_key(key)) return
call get_value(table, key, children, requested=.false.)
if (associated(children)) then
nlist = len(children)
allocate (list(nlist))
do ilist = 1, nlist
call get_value(children, ilist, str, stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Entry in "//key//" field cannot be read")
exit
end if
call move_alloc(str, list(ilist)%s)
end do
if (allocated(error)) return
else
call get_value(table, key, str, stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Entry in "//key//" field cannot be read")
return
end if
if (allocated(str)) then
allocate (list(1))
call move_alloc(str, list(1)%s)
end if
end if
end subroutine get_list
! Set string array
subroutine set_list(table, key, list, error)
!> Instance of the string array
type(string_t), allocatable, intent(in) :: list(:)
!> Key to save to
character(len=*), intent(in) :: key
!> Instance of the toml table
type(toml_table), intent(inout) :: table
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Local variables
integer :: stat, ilist
type(toml_array), pointer :: children
character(len=:), allocatable :: str
!> Set no key if array is not present
if (.not.allocated(list)) return
!> Check the key is not empty
if (len_trim(key)<=0) then
call fatal_error(error, 'key is empty dumping string array to TOML table')
return
end if
if (size(list)/=1) then ! includes empty list case
!> String array
call add_array(table, key, children, stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Cannot set array table in "//key//" field")
return
end if
do ilist = 1, size(list)
call set_value(children, ilist, list(ilist)%s, stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Cannot store array entry in "//key//" field")
return
end if
end do
else
! Single value: set string
call set_value(table, key, list(1)%s, stat=stat)
if (stat /= toml_stat%success) &
call fatal_error(error, "Cannot store entry in "//key//" field")
return
end if
end subroutine set_list
!> Function wrapper to set a character(len=:), allocatable variable to a toml table
subroutine set_character(table, key, var, error, whereAt)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> List of keys to check.
character(len=*), intent(in) :: key
!> The character variable
character(len=*), optional, intent(in) :: var
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional description
character(len=*), intent(in), optional :: whereAt
integer :: ierr
!> Check the key is not empty
if (len_trim(key)<=0) then
call fatal_error(error, 'key is empty setting character string to TOML table')
if (present(whereAt)) error%message = whereAt//': '//error%message
return
end if
if (present(var)) then
call set_value(table, key, var, ierr)
if (ierr/=toml_stat%success) then
call fatal_error(error,'cannot set character key <'//key//'> in TOML table')
if (present(whereAt)) error%message = whereAt//': '//error%message
return
end if
endif
end subroutine set_character
!> Function wrapper to set a logical variable to a toml table, returning an fpm error
subroutine set_logical(table, key, var, error, whereAt)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> The key
character(len=*), intent(in) :: key
!> The variable
logical, intent(in) :: var
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional description
character(len=*), intent(in), optional :: whereAt
integer :: ierr
call set_value(table, key, var, stat=ierr)
if (ierr/=toml_stat%success) then
call fatal_error(error,'cannot set logical key <'//key//'> in TOML table')
if (present(whereAt)) error%message = whereAt//': '//error%message
return
end if
end subroutine set_logical
!> Function wrapper to set a default integer variable to a toml table, returning an fpm error
subroutine set_integer(table, key, var, error, whereAt)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> The key
character(len=*), intent(in) :: key
!> The variable
integer, intent(in) :: var
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional description
character(len=*), intent(in), optional :: whereAt
integer :: ierr
call set_value(table, key, var, stat=ierr)
if (ierr/=toml_stat%success) then
call fatal_error(error,'cannot set integer key <'//key//'> in TOML table')
if (present(whereAt)) error%message = whereAt//': '//error%message
return
end if
end subroutine set_integer
!> Function wrapper to set a default integer variable to a toml table, returning an fpm error
subroutine set_integer_64(table, key, var, error, whereAt)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> The key
character(len=*), intent(in) :: key
!> The variable
integer(int64), intent(in) :: var
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional description
character(len=*), intent(in), optional :: whereAt
integer :: ierr
call set_value(table, key, var, stat=ierr)
if (ierr/=toml_stat%success) then
call fatal_error(error,'cannot set integer(int64) key <'//key//'> in TOML table')
if (present(whereAt)) error%message = whereAt//': '//error%message
return
end if
end subroutine set_integer_64
!> Function wrapper to set a character(len=:), allocatable variable to a toml table
subroutine set_string_type(table, key, var, error, whereAt)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> List of keys to check.
character(len=*), intent(in) :: key
!> The character variable
type(string_t), intent(in) :: var
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional description
character(len=*), intent(in), optional :: whereAt
call set_character(table, key, var%s, error, whereAt)
end subroutine set_string_type
!> Function wrapper to add a toml table and return an fpm error
subroutine add_table_fpm(table, key, ptr, error, whereAt)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> Table key
character(len=*), intent(in) :: key
!> The character variable
type(toml_table), pointer, intent(out) :: ptr
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional description
character(len=*), intent(in), optional :: whereAt
integer :: ierr
!> Nullify pointer
nullify(ptr)
call add_table(table, key, ptr, ierr)
if (ierr/=toml_stat%success) then
call fatal_error(error,'cannot add <'//key//'> table in TOML table')
if (present(whereAt)) error%message = whereAt//': '//error%message
return
end if
end subroutine add_table_fpm
!> Function wrapper to get a logical variable from a toml table, returning an fpm error
subroutine get_logical(table, key, var, error, whereAt)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> The key
character(len=*), intent(in) :: key
!> The variable
logical, intent(inout) :: var
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional description
character(len=*), intent(in), optional :: whereAt
integer :: ierr
call get_value(table, key, var, stat=ierr)
if (ierr/=toml_stat%success) then
call fatal_error(error,'cannot get logical key <'//key//'> from TOML table')
if (present(whereAt)) error%message = whereAt//': '//error%message
return
end if
end subroutine get_logical
!> Function wrapper to get a default integer variable from a toml table, returning an fpm error
subroutine get_integer(table, key, var, error, whereAt)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> The key
character(len=*), intent(in) :: key
!> The variable
integer, intent(inout) :: var
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional description
character(len=*), intent(in), optional :: whereAt
integer :: ierr
call get_value(table, key, var, stat=ierr)
if (ierr/=toml_stat%success) then
call fatal_error(error,'cannot get integer key <'//key//'> from TOML table')
if (present(whereAt)) error%message = whereAt//': '//error%message
return
end if
end subroutine get_integer
!> Function wrapper to get a default string variable from a toml table, returning an fpm error
subroutine get_string(table, key, var, error, whereAt)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> The key
character(len=*), intent(in) :: key
!> The variable
type(string_t), intent(inout) :: var
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional description
character(len=*), intent(in), optional :: whereAt
call get_char(table, key, var%s, error, whereAt)
end subroutine get_string
!> Function wrapper to get a default character variable from a toml table, returning an fpm error
subroutine get_char(table, key, var, error, whereAt)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> The key
character(len=*), intent(in) :: key
!> The variable
character(len=:), allocatable, intent(inout) :: var
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional description
character(len=*), intent(in), optional :: whereAt
integer :: ierr
call get_value(table, key, var, stat=ierr)
if (ierr/=toml_stat%success) then
call fatal_error(error,'cannot get string key <'//key//'> from TOML table')
if (present(whereAt)) error%message = whereAt//': '//error%message
return
end if
end subroutine get_char
!> Function wrapper to get a integer(int64) variable from a toml table, returning an fpm error
subroutine get_integer_64(table, key, var, error, whereAt)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> The key
character(len=*), intent(in) :: key
!> The variable
integer(int64), intent(inout) :: var
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Optional description
character(len=*), intent(in), optional :: whereAt
integer :: ierr
call get_value(table, key, var, stat=ierr)
if (ierr/=toml_stat%success) then
call fatal_error(error,'cannot get integer(int64) key <'//key//'> from TOML table')
if (present(whereAt)) error%message = whereAt//': '//error%message
return
end if
end subroutine get_integer_64
!> Check if table contains only keys that are part of the list. If a key is
!> found that is not part of the list, an error is allocated.
subroutine check_keys(table, valid_keys, error)
!> Instance of the TOML data structure
type(toml_table), intent(inout) :: table
!> List of keys to check.
character(len=*), intent(in) :: valid_keys(:)
!> Error handling
type(error_t), allocatable, intent(out) :: error
type(toml_key), allocatable :: keys(:)
type(toml_table), pointer :: child
character(:), allocatable :: name, value, valid_keys_string
integer :: ikey, ivalid
call table%get_key(name)
call table%get_keys(keys)
do ikey = 1, size(keys)
if (.not. any(keys(ikey)%key == valid_keys)) then
! Generate error message
valid_keys_string = new_line('a')//new_line('a')
do ivalid = 1, size(valid_keys)
valid_keys_string = valid_keys_string//trim(valid_keys(ivalid))//new_line('a')
end do
allocate (error)
error%message = "Key '"//keys(ikey)%key//"' not allowed in the '"// &
& name//"' table."//new_line('a')//new_line('a')//'Valid keys: '//valid_keys_string
return
end if
! Check if value can be mapped or else (wrong type) show error message with the error location.
! Right now, it can only be mapped to a string or to a list or a child node, but this can be
! extended in the future.
if (has_list(table, keys(ikey)%key)) cycle
call get_value(table, keys(ikey)%key, value)
if (.not. allocated(value)) then
! If value is not a string, check if it is a child node
call get_value(table, keys(ikey)%key, child)
if (.not.associated(child)) then
allocate (error)
error%message = "'"//name//"' has an invalid '"//keys(ikey)%key//"' entry."
return
endif
end if
end do
end subroutine check_keys
!> Choose between JSON or TOML based on a file name
logical function name_is_json(filename)
character(*), intent(in) :: filename
character(*), parameter :: json_identifier = ".json"
name_is_json = .false.
if (len_trim(filename) Manages global settings which are defined in the global config file.
module fpm_settings
use fpm_filesystem, only: exists, join_path, get_local_prefix, is_absolute_path, mkdir
use fpm_environment, only: os_is_unix
use fpm_error, only: error_t, fatal_error
use tomlf, only: toml_table, toml_error, toml_stat, toml_load
use fpm_toml, only: get_value, check_keys
use fpm_os, only: get_current_directory, change_directory, get_absolute_path, convert_to_absolute_path
implicit none
private
public :: fpm_global_settings, get_global_settings, get_registry_settings, official_registry_base_url
character(*), parameter :: official_registry_base_url = 'https://fpm-registry.vercel.app'
character(*), parameter :: default_config_file_name = 'config.toml'
type :: fpm_global_settings
!> Path to the global config file excluding the file name.
character(len=:), allocatable :: path_to_config_folder
!> Name of the global config file. The default is `config.toml`.
character(len=:), allocatable :: config_file_name
!> Registry configs.
type(fpm_registry_settings), allocatable :: registry_settings
contains
procedure :: has_custom_location, full_path, path_to_config_folder_or_empty
end type
type :: fpm_registry_settings
!> The path to the local registry. If allocated, the local registry
!> will be used instead of the remote registry and replaces the
!> local cache.
character(len=:), allocatable :: path
!> The URL to the remote registry. Can be used to get packages
!> from the official or a custom registry.
character(len=:), allocatable :: url
!> The path to the cache folder. If not specified, the default cache
!> folders are `~/.local/share/fpm/dependencies` on Unix and
!> `%APPDATA%\local\fpm\dependencies` on Windows.
!> Cannot be used together with `path`.
character(len=:), allocatable :: cache_path
end type
contains
!> Obtain global settings from the global config file.
subroutine get_global_settings(global_settings, error)
!> Global settings to be obtained.
type(fpm_global_settings), intent(inout) :: global_settings
!> Error reading config file.
type(error_t), allocatable, intent(out) :: error
!> TOML table to be filled with global config settings.
type(toml_table), allocatable :: table
!> Error parsing to TOML table.
type(toml_error), allocatable :: parse_error
type(toml_table), pointer :: registry_table
integer :: stat
! Use custom path to the config file if it was specified.
if (global_settings%has_custom_location()) then
! Throw error if folder doesn't exist.
if (.not. exists(global_settings%path_to_config_folder)) then
call fatal_error(error, "Folder not found: '"//global_settings%path_to_config_folder//"'."); return
end if
! Throw error if the file doesn't exist.
if (.not. exists(global_settings%full_path())) then
call fatal_error(error, "File not found: '"//global_settings%full_path()//"'."); return
end if
! Make sure that the path to the global config file is absolute.
call convert_to_absolute_path(global_settings%path_to_config_folder, error)
if (allocated(error)) return
else
! Use default path if it wasn't specified.
if (os_is_unix()) then
global_settings%path_to_config_folder = join_path(get_local_prefix(), 'share', 'fpm')
else
global_settings%path_to_config_folder = join_path(get_local_prefix(), 'fpm')
end if
! Use default file name.
global_settings%config_file_name = default_config_file_name
! Apply default registry settings and return if config file doesn't exist.
if (.not. exists(global_settings%full_path())) then
call use_default_registry_settings(global_settings); return
end if
end if
! Load into TOML table.
call toml_load(table, global_settings%full_path(), error=parse_error)
if (allocated(parse_error)) then
allocate (error); call move_alloc(parse_error%message, error%message); return
end if
call get_value(table, 'registry', registry_table, requested=.false., stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Error reading registry from config file '"// &
& global_settings%full_path()//"'."); return
end if
! A registry table was found.
if (associated(registry_table)) then
call get_registry_settings(registry_table, global_settings, error)
else
call use_default_registry_settings(global_settings)
end if
end
!> Default registry settings are typically applied if the config file doesn't exist or no registry table was found in
!> the global config file.
subroutine use_default_registry_settings(global_settings)
type(fpm_global_settings), intent(inout) :: global_settings
if (.not. allocated(global_settings%registry_settings)) allocate (global_settings%registry_settings)
global_settings%registry_settings%url = official_registry_base_url
global_settings%registry_settings%cache_path = join_path(global_settings%path_to_config_folder_or_empty(), &
& 'dependencies')
end
!> Read registry settings from the global config file.
subroutine get_registry_settings(table, global_settings, error)
!> The [registry] subtable from the global config file.
type(toml_table), target, intent(inout) :: table
!> The global settings which can be filled with the registry settings.
type(fpm_global_settings), intent(inout) :: global_settings
!> Error handling.
type(error_t), allocatable, intent(out) :: error
character(:), allocatable :: path, url, cache_path
integer :: stat
!> List of valid keys for the dependency table.
character(*), dimension(*), parameter :: valid_keys = [character(10) :: &
& 'path', &
& 'url', &
& 'cache_path' &
& ]
call check_keys(table, valid_keys, error)
if (allocated(error)) return
allocate (global_settings%registry_settings)
if (table%has_key('path')) then
call get_value(table, 'path', path, stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Error reading registry path: '"//path//"'."); return
end if
end if
if (allocated(path)) then
if (is_absolute_path(path)) then
global_settings%registry_settings%path = path
else
! Get canonical, absolute path on both Unix and Windows.
call get_absolute_path(join_path(global_settings%path_to_config_folder_or_empty(), path), &
& global_settings%registry_settings%path, error)
if (allocated(error)) return
! Check if the path to the registry exists.
if (.not. exists(global_settings%registry_settings%path)) then
call fatal_error(error, "Directory '"//global_settings%registry_settings%path// &
& "' doesn't exist."); return
end if
end if
end if
if (table%has_key('url')) then
call get_value(table, 'url', url, stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Error reading registry url: '"//url//"'."); return
end if
end if
if (allocated(url)) then
! Throw error when both path and url were provided.
if (allocated(path)) then
call fatal_error(error, 'Do not provide both path and url to the registry.'); return
end if
global_settings%registry_settings%url = url
else if (.not. allocated(path)) then
global_settings%registry_settings%url = official_registry_base_url
end if
if (table%has_key('cache_path')) then
call get_value(table, 'cache_path', cache_path, stat=stat)
if (stat /= toml_stat%success) then
call fatal_error(error, "Error reading path to registry cache: '"//cache_path//"'."); return
end if
end if
if (allocated(cache_path)) then
! Throw error when both path and cache_path were provided.
if (allocated(path)) then
call fatal_error(error, "Do not provide both 'path' and 'cache_path'."); return
end if
if (is_absolute_path(cache_path)) then
if (.not. exists(cache_path)) call mkdir(cache_path)
global_settings%registry_settings%cache_path = cache_path
else
cache_path = join_path(global_settings%path_to_config_folder_or_empty(), cache_path)
if (.not. exists(cache_path)) call mkdir(cache_path)
! Get canonical, absolute path on both Unix and Windows.
call get_absolute_path(cache_path, global_settings%registry_settings%cache_path, error)
if (allocated(error)) return
end if
else if (.not. allocated(path)) then
global_settings%registry_settings%cache_path = &
join_path(global_settings%path_to_config_folder_or_empty(), 'dependencies')
end if
end
!> True if the global config file is not at the default location.
elemental logical function has_custom_location(self)
class(fpm_global_settings), intent(in) :: self
has_custom_location = allocated(self%path_to_config_folder) .and. allocated(self%config_file_name)
if (.not. has_custom_location) return
has_custom_location = len_trim(self%path_to_config_folder) > 0 .and. len_trim(self%config_file_name) > 0
end
!> The full path to the global config file.
function full_path(self) result(result)
class(fpm_global_settings), intent(in) :: self
character(len=:), allocatable :: result
result = join_path(self%path_to_config_folder_or_empty(), self%config_file_name)
end
!> The path to the global config directory.
pure function path_to_config_folder_or_empty(self)
class(fpm_global_settings), intent(in) :: self
character(len=:), allocatable :: path_to_config_folder_or_empty
if (allocated(self%path_to_config_folder)) then
path_to_config_folder_or_empty = self%path_to_config_folder
else
path_to_config_folder_or_empty = ""
end if
end
end
fortran-lang-fpm-90bb83a/src/fpm_source_parsing.f90 0000664 0001750 0001750 00000132516 15145116760 022474 0 ustar alastair alastair !># 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, file_not_found_error
use fpm_strings, only: string_t, string_cat, len_trim, split, lower, str_ends_with, fnv_1a, &
is_fortran_name, operator(.in.), operator(==)
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_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST, FPM_UNIT_CPPSOURCE
use fpm_manifest_preprocess, only: preprocess_config_t
use fpm_filesystem, only: read_lines, read_lines_expanded, exists, join_path, parent_dir
implicit none
private
public :: parse_f_source, parse_c_source, parse_use_statement
type :: cpp_block
! Nested block total depth
integer :: depth = 0
! Whether currently inside an inactive conditional block
logical :: inside_inactive_block = .false.
! Depth at which we became inactive (0 if active)
integer :: inactive_depth = 0
! Current macro
character(:), allocatable :: name
end type cpp_block
contains
!> Check if macro_name is defined in the macros list (case-sensitive, per CPP)
!> Handles both "NAME" (defined without value) and "NAME=VALUE" formats
logical function macro_in_list(macro_name, macros)
character(*), intent(in) :: macro_name
type(string_t), optional, intent(in) :: macros(:)
integer :: i, eq_pos
macro_in_list = .false.
if (.not.present(macros)) return
! Fast path: exact match (handles macros defined without values)
macro_in_list = macro_name .in. macros
if (macro_in_list) return
! Slow path: check for NAME=VALUE format macros
do i = 1, size(macros)
eq_pos = index(macros(i)%s, '=')
if (eq_pos > 0) then
! Macro with value: "NAME=VALUE" - extract just the name part
if (macros(i)%s(1:eq_pos-1) == macro_name) then
macro_in_list = .true.
return
end if
end if
end do
end function macro_in_list
!> Check if a line is a CPP #include or Fortran include statement
!> Returns true if it's an include, and sets include_name to the file name
subroutine is_include_line(line, is_include, include_name)
character(*), intent(in) :: line
logical, intent(out) :: is_include
character(:), allocatable, intent(out) :: include_name
character(:), allocatable :: line_lower
integer :: stat, ic
is_include = .false.
include_name = ""
line_lower = adjustl(lower(line))
! Check for CPP #include directive: #include "file"
if (index(line_lower, '#include') == 1 .and. index(line, '"') > 0) then
include_name = split_n(line, n=2, delims='"', stat=stat)
if (stat == 0 .and. len_trim(include_name) > 0) is_include = .true.
return
end if
! Check for Fortran include statement: include "file" or include 'file'
if (index(line_lower, 'include') == 1) then
ic = verify(line, ' ') ! Position of first non-space (where 'include' starts)
if (ic == 0) return
stat = verify(line(ic+7:), ' ') ! Find first non-space after 'include'
if (stat == 0) return ! Nothing after 'include'
ic = ic + 6 + stat ! Position of first non-space after 'include'
if (line(ic:ic) == '"' .or. line(ic:ic) == "'") then
include_name = split_n(line, n=2, delims="'"//'"', stat=stat)
if (stat == 0 .and. len_trim(include_name) > 0) is_include = .true.
end if
end if
end subroutine is_include_line
!> Find include file in standard locations
!> Searches: source directory first, then package's include directory
function find_include_file(name, src_dir, pkg_dir) result(path)
character(*), intent(in) :: name, src_dir, pkg_dir
character(:), allocatable :: path
! Try source directory first
path = join_path(src_dir, name)
if (exists(path)) return
! Try package's include directory (../include from source dir)
path = join_path(pkg_dir, join_path("include", name))
if (exists(path)) return
! Not found
path = ""
end function find_include_file
!> Get the value of a macro from the macros list
!> Returns empty string if macro is not defined
!> Macros are stored as "NAME" (defined, no value) or "NAME=VALUE"
function get_macro_value(macro_name, macros, found) result(value)
character(*), intent(in) :: macro_name
type(string_t), intent(in), optional :: macros(:)
logical, intent(out), optional :: found
character(:), allocatable :: value
integer :: i, eq_pos
character(:), allocatable :: name_part
value = ""
if (present(found)) found = .false.
if (.not. present(macros)) return
do i = 1, size(macros)
eq_pos = index(macros(i)%s, '=')
if (eq_pos > 0) then
! Macro with value: "NAME=VALUE"
name_part = macros(i)%s(1:eq_pos-1)
if (name_part == macro_name) then
value = macros(i)%s(eq_pos+1:)
if (present(found)) found = .true.
return
end if
else
! Macro without value: "NAME" (treated as defined but empty value)
if (macros(i)%s == macro_name) then
value = ""
if (present(found)) found = .true.
return
end if
end if
end do
end function get_macro_value
!> Parse a macro comparison condition (MACRO == VALUE or MACRO != VALUE)
!> Returns is_active based on comparison result, macro_name is set to the LHS
subroutine parse_macro_comparison(condition, preprocess_macros, defined_macros, is_active, macro_name)
character(*), intent(in) :: condition
type(string_t), optional, intent(in) :: preprocess_macros(:)
type(string_t), optional, intent(in) :: defined_macros(:)
logical, intent(out) :: is_active
character(:), allocatable, intent(out) :: macro_name
integer :: eq_pos, neq_pos
logical :: is_equality, macro_found
character(:), allocatable :: lhs, rhs, macro_value
eq_pos = index(condition, '==')
neq_pos = index(condition, '!=')
is_equality = eq_pos > 0 .and. (neq_pos == 0 .or. eq_pos < neq_pos)
if (is_equality) then
lhs = trim(adjustl(condition(1:eq_pos-1)))
rhs = trim(adjustl(condition(eq_pos+2:)))
else
lhs = trim(adjustl(condition(1:neq_pos-1)))
rhs = trim(adjustl(condition(neq_pos+2:)))
end if
macro_name = lhs
! Get macro value - first check defined_macros, then preprocess_macros
macro_value = get_macro_value(lhs, defined_macros, macro_found)
if (.not. macro_found) then
macro_value = get_macro_value(lhs, preprocess_macros, macro_found)
end if
! Undefined macros evaluate to 0 per CPP behavior
if (.not. macro_found) macro_value = "0"
! Compare values (case-sensitive, per CPP)
if (is_equality) then
is_active = macro_value == rhs
else
is_active = macro_value /= rhs
end if
end subroutine parse_macro_comparison
!> Check if condition contains a comparison operator (== or !=)
logical function has_comparison_operator(condition)
character(*), intent(in) :: condition
has_comparison_operator = index(condition, '==') > 0 .or. index(condition, '!=') > 0
end function has_comparison_operator
!> Parse #if or #elif condition (handles defined(), !defined(), comparisons, and simple macros)
subroutine parse_if_condition(lower_line, line, offset, heading_blanks, preprocess_macros, defined_macros, is_active, macro_name)
character(*), intent(in) :: lower_line, line
integer, intent(in) :: offset, heading_blanks
type(string_t), optional, intent(in) :: preprocess_macros(:), defined_macros(:)
logical, intent(out) :: is_active
character(:), allocatable, intent(out) :: macro_name
integer :: start_pos, end_pos, defined_pos
character(:), allocatable :: condition
logical :: negated
! Check for defined() with parentheses: defined(MACRO) or !defined(MACRO)
if (index(lower_line, 'defined(') > 0) then
start_pos = index(lower_line, 'defined(') + 8
end_pos = index(lower_line(start_pos:), ')') - 1
start_pos = start_pos + heading_blanks
end_pos = end_pos + heading_blanks
if (end_pos > 0) then
macro_name = line(start_pos:start_pos + end_pos - 1)
is_active = macro_in_list(macro_name, preprocess_macros) .or. &
macro_in_list(macro_name, defined_macros)
if (index(lower_line, '!defined(') > 0) is_active = .not. is_active
else
is_active = .false.
macro_name = ""
end if
! Check for defined without parentheses: defined MACRO or !defined MACRO
elseif (index(lower_line, 'defined ') > 0) then
negated = index(lower_line, '!defined ') > 0
if (negated) then
defined_pos = index(lower_line, '!defined ') + 9
else
defined_pos = index(lower_line, 'defined ') + 8
end if
! Extract macro name (everything after 'defined ' until end of line or next space/operator)
start_pos = defined_pos + heading_blanks
macro_name = trim(adjustl(line(start_pos:)))
! Remove any trailing content after first word
end_pos = scan(macro_name, ' &')
if (end_pos > 0) macro_name = macro_name(1:end_pos-1)
is_active = macro_in_list(macro_name, preprocess_macros) .or. &
macro_in_list(macro_name, defined_macros)
if (negated) is_active = .not. is_active
else
condition = trim(adjustl(lower_line(offset:)))
if (has_comparison_operator(condition)) then
call parse_macro_comparison(line(offset+heading_blanks:), preprocess_macros, defined_macros, is_active, macro_name)
else
! Simple macro check: #if MACRO
! Per CPP semantics: true if macro is defined with non-zero value
start_pos = offset + heading_blanks
end_pos = len_trim(lower_line) + heading_blanks
macro_name = trim(adjustl(line(start_pos:end_pos)))
is_active = macro_is_truthy(macro_name, preprocess_macros, locally_defined=.false.) .or. &
macro_is_truthy(macro_name, defined_macros, locally_defined=.true.)
end if
end if
end subroutine parse_if_condition
!> Check if a macro evaluates to a truthy (non-zero) value
!> Per CPP semantics: undefined macros = 0, "0" = false, non-zero = true
!> locally_defined: if true, macro comes from #define in source (empty = false per CPP)
!> if false, macro comes from command line/fpm.toml (empty = true, like -DMACRO)
logical function macro_is_truthy(macro_name, macros, locally_defined)
character(*), intent(in) :: macro_name
type(string_t), optional, intent(in) :: macros(:)
logical, intent(in) :: locally_defined
character(:), allocatable :: value
logical :: found
integer :: int_value, ios
macro_is_truthy = .false.
value = get_macro_value(macro_name, macros, found)
if (.not. found) return ! Undefined macro = false
! Empty value behavior depends on source:
! - Command line/fpm.toml (-DMACRO): treated as -DMACRO=1, so truthy
! - #define MACRO in source: empty expression, would be CPP error, treat as false
if (len_trim(value) == 0) then
macro_is_truthy = .not. locally_defined
return
end if
! Try to parse as integer
read(value, *, iostat=ios) int_value
if (ios == 0) then
macro_is_truthy = (int_value /= 0)
else
! Non-numeric value: treat as truthy if non-empty
macro_is_truthy = .true.
end if
end function macro_is_truthy
!> Replace a single line with a chunk of lines (in-place)
!> Replaces array(at_line) with chunk(:)
pure subroutine insert_lines(array, chunk, at_line)
type(string_t), allocatable, intent(inout) :: array(:)
type(string_t), intent(in) :: chunk(:)
integer, intent(in) :: at_line
type(string_t), allocatable :: new_array(:)
integer :: n, m, new_size
n = size(array)
m = size(chunk)
! Bounds check: at_line must be in valid range [1, n]
if (at_line < 1 .or. at_line > n) return
new_size = n - 1 + m ! Remove 1 line, add m lines
allocate(new_array(new_size))
! Copy lines before at_line
if (at_line > 1) new_array(1:at_line-1) = array(1:at_line-1)
! Insert chunk
if (m > 0) new_array(at_line:at_line+m-1) = chunk
! Copy lines after at_line
if (at_line < n) new_array(at_line+m:new_size) = array(at_line+1:n)
call move_alloc(new_array, array)
end subroutine insert_lines
!> Read source file lines with include files embedded inline
!> Replaces both CPP `#include "file"` and Fortran `include "file"` with file contents
!> Searches in: source directory, ../include (default fpm include dir)
function read_lines_with_includes(filename) result(lines)
character(*), intent(in) :: filename
type(string_t), allocatable :: lines(:)
type(string_t), allocatable :: include_lines(:)
character(:), allocatable :: include_name, include_path, source_dir, pkg_dir
integer :: i
logical :: found_include
lines = read_lines_expanded(filename)
if (.not. allocated(lines) .or. size(lines) == 0) then
allocate(lines(0))
return
end if
source_dir = parent_dir(filename)
pkg_dir = parent_dir(source_dir)
! Process in reverse order so indices don't shift for unprocessed lines
do i = size(lines), 1, -1
call is_include_line(lines(i)%s, found_include, include_name)
if (found_include) then
include_path = find_include_file(include_name, source_dir, pkg_dir)
if (len_trim(include_path) > 0) then
include_lines = read_lines(include_path)
if (allocated(include_lines) .and. size(include_lines) > 0) then
call insert_lines(lines, include_lines, i)
end if
end if
end if
end do
end function read_lines_with_includes
!> Parse a #define directive and extract macro name and optional value
!> Returns macro in "NAME=VALUE" or "NAME" format, empty string if not a #define
function parse_define_directive(line) result(macro)
character(*), intent(in) :: line
character(:), allocatable :: macro
character(:), allocatable :: line_lower, macro_name, macro_value
integer :: start_pos, end_pos
macro = ""
line_lower = adjustl(lower(line))
if (index(line_lower, '#define') /= 1) return
! Extract macro name and optional value
! Format: #define NAME or #define NAME VALUE
! Note: bounds checks are short-circuited to avoid out-of-bounds access (issue #1222)
start_pos = 8
do while (start_pos <= len(line))
if (line(start_pos:start_pos) /= ' ') exit
start_pos = start_pos + 1
end do
! Find end of macro name (space or end of line)
end_pos = start_pos
do while (end_pos <= len(line))
if (line(end_pos:end_pos) == ' ') exit
end_pos = end_pos + 1
end do
end_pos = end_pos - 1
if (end_pos < start_pos) return
macro_name = line(start_pos:end_pos)
! Check for value after the name
start_pos = end_pos + 1
do while (start_pos <= len(line))
if (line(start_pos:start_pos) /= ' ') exit
start_pos = start_pos + 1
end do
if (start_pos <= len(line)) then
macro_value = trim(line(start_pos:))
macro = macro_name // '=' // macro_value
else
macro = macro_name
end if
end function parse_define_directive
!> Add a macro to a macros array (grows the array)
subroutine add_macro(macros, macro)
type(string_t), allocatable, intent(inout) :: macros(:)
character(*), intent(in) :: macro
type(string_t), allocatable :: new_macros(:)
integer :: n
if (.not. allocated(macros)) then
allocate(macros(1))
macros(1)%s = macro
else
n = size(macros)
allocate(new_macros(n + 1))
new_macros(1:n) = macros
new_macros(n + 1)%s = macro
call move_alloc(new_macros, macros)
end if
end subroutine add_macro
!> Start a CPP conditional block (active or inactive)
subroutine start_cpp_block(blk, lower_line, line, preprocess, defined_macros)
type(cpp_block), intent(inout) :: blk
character(*), intent(in) :: lower_line, line
type(preprocess_config_t), optional, intent(in) :: preprocess
type(string_t), optional, intent(in) :: defined_macros(:)
logical :: is_active
character(:), allocatable :: macro_name
call parse_cpp_condition(lower_line, line, preprocess, is_active, macro_name, defined_macros)
blk%depth = blk%depth + 1
! If we're not already in an inactive block, check this condition
enter_inactive: if (.not. blk%inside_inactive_block) then
blk%name = macro_name
if (.not. is_active) then
! This condition is false, so we enter an inactive block
blk%inside_inactive_block = .true.
blk%inactive_depth = blk%depth
end if
end if enter_inactive
! If we're already in an inactive block, stay inactive regardless of this condition
end subroutine start_cpp_block
!> End a CPP conditional block
subroutine end_cpp_block(blk)
type(cpp_block), intent(inout) :: blk
! If we're ending the block where we became inactive, reactivate
if (blk%inside_inactive_block .and. blk%depth == blk%inactive_depth) then
blk%inside_inactive_block = .false.
blk%inactive_depth = 0
end if
blk%depth = max(0, blk%depth - 1)
end subroutine end_cpp_block
!> Handle #else directive by flipping the current condition
subroutine handle_else_block(blk)
type(cpp_block), intent(inout) :: blk
! #else only matters if we're at the same level where we became inactive
if (blk%inside_inactive_block .and. blk%depth == blk%inactive_depth) then
! We're in an inactive block at this level, #else makes it active
blk%inside_inactive_block = .false.
blk%inactive_depth = 0
elseif (.not. blk%inside_inactive_block .and. blk%depth > 0) then
! We're in an active block at this level, #else makes it inactive
blk%inside_inactive_block = .true.
blk%inactive_depth = blk%depth
end if
end subroutine handle_else_block
!> Parse CPP conditional directive and determine if block should be active
!> defined_macros: optional additional macros from #define directives in source/includes
subroutine parse_cpp_condition(lower_line, line, preprocess, is_active, macro_name, defined_macros)
character(*), intent(in) :: lower_line, line
type(preprocess_config_t), optional, intent(in) :: preprocess
character(:), allocatable, intent(out) :: macro_name
logical, intent(out) :: is_active
type(string_t), optional, intent(in) :: defined_macros(:)
integer :: start_pos, heading_blanks, i
! Always active if CPP preprocessor is not active
if (.not. present(preprocess)) then
is_active = .true.
macro_name = ""
return
endif
! If CPP is not enabled, always active
if (.not. preprocess%is_cpp()) then
is_active = .true.
macro_name = ""
return
endif
! Find offset between lowercase adjustl and standard line
heading_blanks = 0
do i=1,len(line)
if (line(i:i)==' ') then
heading_blanks = heading_blanks+1
else
exit
end if
end do
! There are macros: test if active
if (index(lower_line, '#ifdef') == 1) then
start_pos = index(lower_line, ' ') + heading_blanks + 1
macro_name = trim(adjustl(line(start_pos:)))
is_active = macro_in_list(macro_name, preprocess%macros) .or. &
macro_in_list(macro_name, defined_macros)
elseif (index(lower_line, '#ifndef') == 1) then
start_pos = index(lower_line, ' ') + heading_blanks + 1
macro_name = trim(adjustl(line(start_pos:)))
is_active = .not. (macro_in_list(macro_name, preprocess%macros) .or. &
macro_in_list(macro_name, defined_macros))
elseif (index(lower_line, '#if ') == 1) then
call parse_if_condition(lower_line, line, 4, heading_blanks, &
preprocess%macros, defined_macros, is_active, macro_name)
elseif (index(lower_line, '#elif') == 1) then
call parse_if_condition(lower_line, line, 6, heading_blanks, &
preprocess%macros, defined_macros, is_active, macro_name)
else
is_active = .false.
macro_name = ""
end if
end subroutine parse_cpp_condition
!> 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,preprocess) result(f_source)
character(*), intent(in) :: f_filename
type(error_t), allocatable, intent(out) :: error
type(preprocess_config_t), optional, intent(in) :: preprocess
type(srcfile_t) :: f_source
logical :: inside_module, inside_interface, using, intrinsic_module
logical :: cpp_conditional_parsing
integer :: stat
integer :: fh, n_use, n_include, n_mod, n_parent, i, j, ic, pass
type(cpp_block) :: cpp_blk
type(string_t), allocatable :: file_lines(:), file_lines_lower(:)
type(string_t), allocatable :: defined_macros(:)
character(:), allocatable :: temp_string, mod_name, string_parts(:)
character(:), allocatable :: parsed_macro
if (.not. exists(f_filename)) then
call file_not_found_error(error, f_filename)
return
end if
f_source%file_name = f_filename
! Only use conditional parsing if preprocessing is enabled with CPP
cpp_conditional_parsing = .false.
if (present(preprocess)) cpp_conditional_parsing = preprocess%is_cpp()
! Read file with #include directives expanded inline (for CPP parsing)
if (cpp_conditional_parsing) then
file_lines = read_lines_with_includes(f_filename)
else
file_lines = read_lines_expanded(f_filename)
end if
! for efficiency in parsing make a lowercase left-adjusted copy of the file
! Need a copy because INCLUDE (and #include) file arguments are case-sensitive
file_lines_lower=file_lines
do i=1,size(file_lines_lower)
file_lines_lower(i)%s=adjustl(lower(file_lines_lower(i)%s))
enddo
! fnv_1a can only be applied to non-zero-length arrays
if (len_trim(file_lines_lower) > 0) f_source%digest = fnv_1a(file_lines)
do pass = 1,2
n_use = 0
n_include = 0
n_mod = 0
n_parent = 0
inside_module = .false.
inside_interface = .false.
cpp_blk = cpp_block() ! Initialize with default values
if (allocated(defined_macros)) deallocate(defined_macros) ! Reset macros each pass
file_loop: do i=1,size(file_lines_lower)
! Skip comment lines and empty lines
if (index(file_lines_lower(i)%s,'!') == 1 .or. &
len_trim(file_lines_lower(i)%s) < 1) then
cycle
end if
! Handle preprocessor directives
if (index(file_lines_lower(i)%s,'#') == 1) then
! If conditional parsing is enabled, track preprocessor blocks
if (cpp_conditional_parsing) then
! Check for conditional compilation directives
if (index(file_lines_lower(i)%s,'#ifdef') == 1 .or. &
index(file_lines_lower(i)%s,'#ifndef') == 1 .or. &
index(file_lines_lower(i)%s,'#if ') == 1) then
! Determine if this conditional block should be active
call start_cpp_block(cpp_blk, file_lines_lower(i)%s, file_lines(i)%s, preprocess, defined_macros)
elseif (index(file_lines_lower(i)%s,'#endif') == 1) then
call end_cpp_block(cpp_blk)
elseif (index(file_lines_lower(i)%s,'#else') == 1) then
call handle_else_block(cpp_blk)
elseif (index(file_lines_lower(i)%s,'#elif') == 1) then
! Treat #elif as #else followed by #if
call handle_else_block(cpp_blk)
call start_cpp_block(cpp_blk, file_lines_lower(i)%s, file_lines(i)%s, preprocess, defined_macros)
elseif (index(file_lines_lower(i)%s,'#define') == 1) then
! Parse #define and add to defined_macros (only if not in inactive block)
if (.not. cpp_blk%inside_inactive_block) then
parsed_macro = parse_define_directive(file_lines(i)%s)
if (len_trim(parsed_macro) > 0) then
call add_macro(defined_macros, parsed_macro)
end if
end if
end if
end if
! Skip all preprocessor directive lines (both old and new behavior)
cycle
end if
! Skip content inside conditional blocks when conditional parsing is enabled
if (cpp_conditional_parsing .and. cpp_blk%inside_inactive_block) cycle
! Detect exported C-API via bind(C)
if (.not.inside_interface .and. &
parse_subsequence(file_lines_lower(i)%s,'bind','(','c')) then
do j=i,1,-1
if (index(file_lines_lower(j)%s,'function') > 0 .or. &
index(file_lines_lower(j)%s,'subroutine') > 0) then
f_source%unit_type = FPM_UNIT_SUBPROGRAM
exit
end if
if (j>1) then
ic = index(file_lines_lower(j-1)%s,'!')
if (ic < 1) then
ic = len(file_lines_lower(j-1)%s)
end if
temp_string = trim(file_lines_lower(j-1)%s(1:ic))
if (index(temp_string,'&') /= len(temp_string)) then
exit
end if
end if
end do
end if
! Skip lines that are continued: not statements
if (i > 1) then
ic = index(file_lines_lower(i-1)%s,'!')
if (ic < 1) then
ic = len(file_lines_lower(i-1)%s)
end if
temp_string = trim(file_lines_lower(i-1)%s(1:ic))
if (len(temp_string) > 0 .and. index(temp_string,'&') == len(temp_string)) then
cycle
end if
end if
! Detect beginning of interface block
if (index(file_lines_lower(i)%s,'interface') == 1 &
.or. parse_sequence(file_lines_lower(i)%s,'abstract','interface')) then
inside_interface = .true.
cycle
end if
! Detect end of interface block
if (parse_sequence(file_lines_lower(i)%s,'end','interface')) then
inside_interface = .false.
cycle
end if
! Process 'USE' statements
call parse_use_statement(f_filename,i,file_lines_lower(i)%s,using,intrinsic_module,mod_name,error)
if (allocated(error)) return
if (using) then
! Not a valid module name?
if (.not.is_fortran_name(mod_name)) cycle
! Valid intrinsic module: not a dependency
if (intrinsic_module) cycle
n_use = n_use + 1
if (pass == 2) f_source%modules_used(n_use)%s = mod_name
cycle
endif
! Process 'INCLUDE' statements
if (index(file_lines_lower(i)%s,'include') == 1) then
ic = verify(file_lines(i)%s, ' ') ! Position of first non-space (where 'include' starts)
if (ic == 0) cycle
j = verify(file_lines(i)%s(ic+7:), ' ') ! Find first non-space after 'include'
if (j == 0) cycle ! Nothing after 'include'
ic = ic + 6 + j ! Position of first non-space after 'include'
if (file_lines(i)%s(ic:ic) == '"' .or. file_lines(i)%s(ic:ic) == "'") then
n_include = n_include + 1
if (pass == 2) then
f_source%include_dependencies(n_include)%s = &
& split_n(file_lines(i)%s,n=2,delims="'"//'"',stat=stat)
if (stat /= 0) then
call file_parse_error(error,f_filename, &
'unable to find include file name',i, &
file_lines(i)%s)
return
end if
end if
cycle
end if
end if
! Extract name of module if is module
if (index(file_lines_lower(i)%s,'module ') == 1) then
! Remove any trailing comments
ic = index(file_lines_lower(i)%s,'!')-1
if (ic < 1) then
ic = len(file_lines_lower(i)%s)
end if
temp_string = trim(file_lines_lower(i)%s(1:ic))
! R1405 module-stmt := "MODULE" module-name
! module-stmt has two space-delimited parts only
! (no line continuations)
call split(temp_string,string_parts,' ')
if (size(string_parts) /= 2) then
cycle
end if
mod_name = trim(adjustl(string_parts(2)))
if (scan(mod_name,'=(&')>0 ) then
! Ignore these cases:
! module &
! module =*
! module (i)
cycle
end if
if (.not.is_fortran_name(mod_name)) then
call file_parse_error(error,f_filename, &
'empty or invalid name for module',i, &
file_lines_lower(i)%s, index(file_lines_lower(i)%s,mod_name))
return
end if
n_mod = n_mod + 1
if (pass == 2) then
f_source%modules_provided(n_mod) = string_t(mod_name)
end if
if (f_source%unit_type == FPM_UNIT_UNKNOWN) then
f_source%unit_type = FPM_UNIT_MODULE
end if
if (.not.inside_module) then
inside_module = .true.
else
! Must have missed an end module statement (can't assume a pure module)
if (f_source%unit_type /= FPM_UNIT_PROGRAM) then
f_source%unit_type = FPM_UNIT_SUBPROGRAM
end if
end if
cycle
end if
! Extract name of submodule if is submodule
if (index(file_lines_lower(i)%s,'submodule') == 1) then
mod_name = split_n(file_lines_lower(i)%s,n=3,delims='()',stat=stat)
if (stat /= 0) then
call file_parse_error(error,f_filename, &
'unable to get submodule name',i, &
file_lines_lower(i)%s)
return
end if
if (.not.is_fortran_name(mod_name)) then
call file_parse_error(error,f_filename, &
'empty or invalid name for submodule',i, &
file_lines_lower(i)%s, index(file_lines_lower(i)%s,mod_name))
return
end if
n_mod = n_mod + 1
temp_string = split_n(file_lines_lower(i)%s,n=2,delims='()',stat=stat)
if (stat /= 0) then
call file_parse_error(error,f_filename, &
'unable to get submodule ancestry',i, &
file_lines_lower(i)%s)
return
end if
if (f_source%unit_type /= FPM_UNIT_PROGRAM) then
f_source%unit_type = FPM_UNIT_SUBMODULE
end if
n_use = n_use + 1
inside_module = .true.
n_parent = n_parent + 1
if (pass == 2) then
if (index(temp_string,':') > 0) then
temp_string = temp_string(index(temp_string,':')+1:)
end if
if (.not.is_fortran_name(temp_string)) then
call file_parse_error(error,f_filename, &
'empty or invalid name for submodule parent',i, &
file_lines_lower(i)%s, index(file_lines_lower(i)%s,temp_string))
return
end if
f_source%modules_used(n_use)%s = temp_string
f_source%parent_modules(n_parent)%s = temp_string
f_source%modules_provided(n_mod)%s = mod_name
end if
cycle
end if
! Detect if contains a program
! - no modules allowed after program def
! - program header may be missing (only "end program" statement present)
if (index(file_lines_lower(i)%s,'program ')==1 .or. &
parse_sequence(file_lines_lower(i)%s,'end','program')) then
temp_string = split_n(file_lines_lower(i)%s,n=2,delims=' ',stat=stat)
if (stat == 0) then
if (scan(temp_string,'=(')>0 ) then
! Ignore:
! program =*
! program (i) =*
cycle
end if
end if
f_source%unit_type = FPM_UNIT_PROGRAM
cycle
end if
! Parse end module statement
! (to check for code outside of modules)
if (parse_sequence(file_lines_lower(i)%s,'end','module') .or. &
parse_sequence(file_lines_lower(i)%s,'end','submodule')) then
inside_module = .false.
cycle
end if
! Any statements not yet parsed are assumed to be other code statements
if (.not.inside_module .and. f_source%unit_type /= FPM_UNIT_PROGRAM) then
f_source%unit_type = FPM_UNIT_SUBPROGRAM
end if
end do file_loop
! If unable to parse end of module statement, then can't assume pure module
! (there could be non-module subprograms present)
if (inside_module .and. f_source%unit_type == FPM_UNIT_MODULE) then
f_source%unit_type = FPM_UNIT_SUBPROGRAM
end if
if (pass == 1) then
allocate(f_source%modules_used(n_use))
allocate(f_source%include_dependencies(n_include))
allocate(f_source%modules_provided(n_mod))
allocate(f_source%parent_modules(n_parent))
end if
end do
end function parse_f_source
!> Parsing of c, cpp source files
!>
!> 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
else if (str_ends_with(lower(c_filename), ".h")) then
c_source%unit_type = FPM_UNIT_CHEADER
else if (str_ends_with(lower(c_filename), ".cpp")) then
c_source%unit_type = FPM_UNIT_CPPSOURCE
end if
allocate(c_source%modules_used(0))
allocate(c_source%modules_provided(0))
allocate(c_source%parent_modules(0))
file_lines = read_lines(c_filename)
! Ignore empty files, returned as FPM_UNIT_UNKNOWN
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
allocate(character(len=0) :: substring) ! ifort bus error otherwise
stat = 1
return
end if
else
i = n
end if
if (i>size(string_parts)) then
allocate(character(len=0) :: substring) ! ifort bus error otherwise
stat = 1
return
end if
substring = trim(adjustl(string_parts(i)))
stat = 0
end function split_n
!> Parse a subsequence of blank-separated tokens within a string
!> (see parse_sequence)
function parse_subsequence(string,t1,t2,t3,t4) result(found)
character(*), intent(in) :: string
character(*), intent(in) :: t1
character(*), intent(in), optional :: t2, t3, t4
logical :: found
integer :: offset, i
found = .false.
offset = 1
do
i = index(string(offset:),t1)
if (i == 0) return
offset = offset + i - 1
found = parse_sequence(string(offset:),t1,t2,t3,t4)
if (found) return
offset = offset + len(t1)
if (offset > len(string)) return
end do
end function parse_subsequence
!> Helper utility to parse sequences of tokens
!> that may be optionally separated by zero or more spaces
function parse_sequence(string,t1,t2,t3,t4) result(found)
character(*), intent(in) :: string
character(*), intent(in) :: t1
character(*), intent(in), optional :: t2, t3, t4
logical :: found
integer :: post, n, incr, pos, token_n
logical :: match
n = len(string)
found = .false.
pos = 1
do token_n=1,4
do while (pos <= n)
if (string(pos:pos) /= ' ') then
exit
end if
pos = pos + 1
end do
select case(token_n)
case(1)
incr = len(t1)
if (pos+incr-1>n) return
match = string(pos:pos+incr-1) == t1
case(2)
if (.not.present(t2)) exit
incr = len(t2)
if (pos+incr-1>n) return
match = string(pos:pos+incr-1) == t2
case(3)
if (.not.present(t3)) exit
incr = len(t3)
if (pos+incr-1>n) return
match = string(pos:pos+incr-1) == t3
case(4)
if (.not.present(t4)) exit
incr = len(t4)
if (pos+incr-1>n) return
match = string(pos:pos+incr-1) == t4
case default
exit
end select
if (.not.match) then
return
end if
pos = pos + incr
end do
found = .true.
end function parse_sequence
! USE [, intrinsic] :: module_name [, only: only_list]
! USE [, non_intrinsic] :: module_name [, only: only_list]
subroutine parse_use_statement(f_filename,i,line,use_stmt,is_intrinsic,module_name,error)
!> Current file name and line number (for error messaging)
character(*), intent(in) :: f_filename
integer, intent(in) :: i
!> The line being parsed. MUST BE preprocessed with trim(adjustl()
character(*), intent(in) :: line
!> Does this line contain a `use` statement?
logical, intent(out) :: use_stmt
!> Is the module in this statement intrinsic?
logical, intent(out) :: is_intrinsic
!> used module name
character(:), allocatable, intent(out) :: module_name
!> Error handling
type(error_t), allocatable, intent(out) :: error
character(15), parameter :: INTRINSIC_NAMES(*) = &
['iso_c_binding ', &
'iso_fortran_env', &
'ieee_arithmetic', &
'ieee_exceptions', &
'ieee_features ', &
'omp_lib ']
character(len=:), allocatable :: temp_string
integer :: colons,intr,nonintr,j,stat
logical :: has_intrinsic_name
use_stmt = .false.
is_intrinsic = .false.
if (len_trim(line)<=0) return
! Quick check that the line is preprocessed
if (line(1:1)==' ') then
call fatal_error(error,'internal_error: source file line is not trim(adjustl()) on input to parse_use_statement')
return
end if
! 'use' should be the first string in the adjustl line
use_stmt = index(line,'use ')==1 .or. index(line,'use::')==1 .or. index(line,'use,')==1
if (.not.use_stmt) return
colons = index(line,'::')
nonintr = 0
intr = 0
have_colons: if (colons>3) then
! there may be an intrinsic/non-intrinsic spec
nonintr = index(line(1:colons-1),'non_intrinsic')
if (nonintr==0) intr = index(line(1:colons-1),'intrinsic')
temp_string = split_n(line,delims=':',n=2,stat=stat)
if (stat /= 0) then
call file_parse_error(error,f_filename, &
'unable to find used module name',i, &
line,colons)
return
end if
module_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, &
line)
return
end if
else
module_name = split_n(line,n=2,delims=' ,',stat=stat)
if (stat /= 0) then
call file_parse_error(error,f_filename, &
'unable to find used module name',i, &
line)
return
end if
end if have_colons
! If declared intrinsic, check that it is true
has_intrinsic_name = any([(index(module_name,trim(INTRINSIC_NAMES(j)))>0, &
j=1,size(INTRINSIC_NAMES))])
if (intr>0 .and. .not.has_intrinsic_name) then
! An intrinsic module was not found. Its name could be in the next line,
! in which case, we just skip this check. The compiler will do the job if the name is invalid.
! Module name was not read: it's in the next line
if (index(module_name,'&')<=0) then
call file_parse_error(error,f_filename, &
'module '//module_name//' is declared intrinsic but it is not ',i, &
line)
return
endif
endif
! Should we treat this as an intrinsic module
is_intrinsic = nonintr==0 .and. & ! not declared non-intrinsic
(intr>0 .or. has_intrinsic_name)
end subroutine parse_use_statement
end module fpm_source_parsing
fortran-lang-fpm-90bb83a/src/ptycheck/ 0000775 0001750 0001750 00000000000 15145116760 020071 5 ustar alastair alastair fortran-lang-fpm-90bb83a/src/ptycheck/iscygpty.h 0000664 0001750 0001750 00000002767 15145116760 022131 0 ustar alastair alastair /*
* iscygpty.h -- part of ptycheck
* https://github.com/k-takata/ptycheck
*
* Copyright (c) 2015-2017 K.Takata
*
* You can redistribute it and/or modify it under the terms of either
* the MIT license (as described below) or the Vim license.
*
* Permission is hereby granted, free of charge, to any person obtaining
* a copy of this software and associated documentation files (the
* "Software"), to deal in the Software without restriction, including
* without limitation the rights to use, copy, modify, merge, publish,
* distribute, sublicense, and/or sell copies of the Software, and to
* permit persons to whom the Software is furnished to do so, subject to
* the following conditions:
*
* The above copyright notice and this permission notice shall be
* included in all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
* IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
* CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
* TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
* SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*/
#ifndef _ISCYGPTY_H
#define _ISCYGPTY_H
#ifdef _WIN32
int is_cygpty(int fd);
int is_cygpty_used(void);
#else
#define is_cygpty(fd) 0
#define is_cygpty_used() 0
#endif
#endif /* _ISCYGPTY_H */
fortran-lang-fpm-90bb83a/src/ptycheck/isatty.c 0000664 0001750 0001750 00000001535 15145116760 021556 0 ustar alastair alastair // This file provides a `c_isatty` wrapper function to check if `stdout` is connected
// to a terminal or not. This wrapper is required for better portability, specifically
// for supporting the MS Windows command prompt and the MinTTY terminal used by MSYS2.
#include //for isatty()
#include //for fileno()
#ifdef __MINGW64__
// ptycheck/iscygpty allows us to check if connected to MinTTY in MSYS2 on Windows
#include "iscygpty.h"
#endif
// Check if `stdout` is connected to a terminal
// Returns 1 if is a terminal, and 0 otherwise
int c_isatty(void)
{
if (isatty(fileno(stdout))){
return 1;
} else {
#ifdef __MINGW64__
if (is_cygpty(fileno(stdout))){
return 1;
} else {
return 0;
}
#endif
return 0;
}
} fortran-lang-fpm-90bb83a/src/ptycheck/iscygpty.c 0000664 0001750 0001750 00000011550 15145116760 022112 0 ustar alastair alastair /*
* iscygpty.c -- part of ptycheck
* https://github.com/k-takata/ptycheck
*
* Copyright (c) 2015-2017 K.Takata
*
* You can redistribute it and/or modify it under the terms of either
* the MIT license (as described below) or the Vim license.
*
* Permission is hereby granted, free of charge, to any person obtaining
* a copy of this software and associated documentation files (the
* "Software"), to deal in the Software without restriction, including
* without limitation the rights to use, copy, modify, merge, publish,
* distribute, sublicense, and/or sell copies of the Software, and to
* permit persons to whom the Software is furnished to do so, subject to
* the following conditions:
*
* The above copyright notice and this permission notice shall be
* included in all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
* IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
* CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
* TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
* SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*/
#ifdef _WIN32
#include
#include
#include
#include
#ifdef USE_FILEEXTD
/* VC 7.1 or earlier doesn't support SAL. */
# if !defined(_MSC_VER) || (_MSC_VER < 1400)
# define __out
# define __in
# define __in_opt
# endif
/* Win32 FileID API Library:
* http://www.microsoft.com/en-us/download/details.aspx?id=22599
* Needed for WinXP. */
# include
#else /* USE_FILEEXTD */
/* VC 8 or earlier. */
# if defined(_MSC_VER) && (_MSC_VER < 1500)
# ifdef ENABLE_STUB_IMPL
# define STUB_IMPL
# else
# error "Win32 FileID API Library is required for VC2005 or earlier."
# endif
# endif
#endif /* USE_FILEEXTD */
#include "iscygpty.h"
//#define USE_DYNFILEID
#ifdef USE_DYNFILEID
typedef BOOL (WINAPI *pfnGetFileInformationByHandleEx)(
HANDLE hFile,
FILE_INFO_BY_HANDLE_CLASS FileInformationClass,
LPVOID lpFileInformation,
DWORD dwBufferSize
);
static pfnGetFileInformationByHandleEx pGetFileInformationByHandleEx = NULL;
# ifndef USE_FILEEXTD
static BOOL WINAPI stub_GetFileInformationByHandleEx(
HANDLE hFile,
FILE_INFO_BY_HANDLE_CLASS FileInformationClass,
LPVOID lpFileInformation,
DWORD dwBufferSize
)
{
return FALSE;
}
# endif
static void setup_fileid_api(void)
{
if (pGetFileInformationByHandleEx != NULL) {
return;
}
pGetFileInformationByHandleEx = (pfnGetFileInformationByHandleEx)
GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),
"GetFileInformationByHandleEx");
if (pGetFileInformationByHandleEx == NULL) {
# ifdef USE_FILEEXTD
pGetFileInformationByHandleEx = GetFileInformationByHandleEx;
# else
pGetFileInformationByHandleEx = stub_GetFileInformationByHandleEx;
# endif
}
}
#else
# define pGetFileInformationByHandleEx GetFileInformationByHandleEx
# define setup_fileid_api()
#endif
#define is_wprefix(s, prefix) \
(wcsncmp((s), (prefix), sizeof(prefix) / sizeof(WCHAR) - 1) == 0)
/* Check if the fd is a cygwin/msys's pty. */
int is_cygpty(int fd)
{
#ifdef STUB_IMPL
return 0;
#else
HANDLE h;
int size = sizeof(FILE_NAME_INFO) + sizeof(WCHAR) * (MAX_PATH - 1);
FILE_NAME_INFO *nameinfo;
WCHAR *p = NULL;
setup_fileid_api();
h = (HANDLE) _get_osfhandle(fd);
if (h == INVALID_HANDLE_VALUE) {
return 0;
}
/* Cygwin/msys's pty is a pipe. */
if (GetFileType(h) != FILE_TYPE_PIPE) {
return 0;
}
nameinfo = malloc(size + sizeof(WCHAR));
if (nameinfo == NULL) {
return 0;
}
/* Check the name of the pipe:
* '\{cygwin,msys}-XXXXXXXXXXXXXXXX-ptyN-{from,to}-master' */
if (pGetFileInformationByHandleEx(h, FileNameInfo, nameinfo, size)) {
nameinfo->FileName[nameinfo->FileNameLength / sizeof(WCHAR)] = L'\0';
p = nameinfo->FileName;
if (is_wprefix(p, L"\\cygwin-")) { /* Cygwin */
p += 8;
} else if (is_wprefix(p, L"\\msys-")) { /* MSYS and MSYS2 */
p += 6;
} else {
p = NULL;
}
if (p != NULL) {
while (*p && isxdigit(*p)) /* Skip 16-digit hexadecimal. */
++p;
if (is_wprefix(p, L"-pty")) {
p += 4;
} else {
p = NULL;
}
}
if (p != NULL) {
while (*p && isdigit(*p)) /* Skip pty number. */
++p;
if (is_wprefix(p, L"-from-master")) {
//p += 12;
} else if (is_wprefix(p, L"-to-master")) {
//p += 10;
} else {
p = NULL;
}
}
}
free(nameinfo);
return (p != NULL);
#endif /* STUB_IMPL */
}
/* Check if at least one cygwin/msys pty is used. */
int is_cygpty_used(void)
{
int fd, ret = 0;
for (fd = 0; fd < 3; fd++) {
ret |= is_cygpty(fd);
}
return ret;
}
#endif /* _WIN32 */
/* vim: set ts=4 sw=4: */
fortran-lang-fpm-90bb83a/src/ptycheck/LICENSE 0000664 0001750 0001750 00000002071 15145116760 021076 0 ustar alastair alastair The MIT License (MIT)
Copyright (c) 2015-2016 K.Takata
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
fortran-lang-fpm-90bb83a/install.sh 0000775 0001750 0001750 00000004703 15145116760 017501 0 ustar alastair alastair #!/bin/sh
set -e # exit on error
usage()
{
echo "Fortran Package Manager Bootstrap Script"
echo ""
echo "USAGE:"
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 ""
echo "FC and FFLAGS environment variables can be used to select the"
echo "Fortran compiler and the build flags."
echo ""
}
# Return a download command
get_fetch_command()
{
if command -v curl > /dev/null 2>&1; then
echo "curl -L"
elif command -v wget > /dev/null 2>&1; then
echo "wget -O -"
else
echo "No download mechanism found. Install curl or wget first."
return 1
fi
}
# Return value of the latest published release on GitHub, with no heading "v" (e.g., "0.7.0")
get_latest_release()
{
$2 "https://api.github.com/repos/$1/releases/latest" | # Get latest release from GitHub api
grep '"tag_name":' | # Get tag line
sed -E 's/.*"([^"]+)".*/\1/' | # Pluck JSON value
sed -E 's/^v//' # Remove heading "v" if present
}
PREFIX="$HOME/.local"
while [ "$1" != "" ]; do
PARAM=$(echo "$1" | awk -F= '{print $1}')
VALUE=$(echo "$1" | awk -F= '{print $2}')
case $PARAM in
-h | --help)
usage
exit
;;
--prefix)
PREFIX=$VALUE
;;
*)
echo "ERROR: unknown parameter \"$PARAM\""
usage
exit 1
;;
esac
shift
done
set -u # error on use of undefined variable
# Get download command
FETCH=$(get_fetch_command)
if [ $? -ne 0 ]; then
echo "No download mechanism found. Install curl or wget first."
exit 2
fi
# Use 0.8.0 too bootstrap
BOOTSTRAP_RELEASE="0.8.0"
SOURCE_URL="https://github.com/fortran-lang/fpm/releases/download/v${BOOTSTRAP_RELEASE}/fpm-${BOOTSTRAP_RELEASE}.F90"
BOOTSTRAP_DIR="build/bootstrap"
if [ -z ${FC+x} ]; then
FC="gfortran"
fi
if [ -z ${FFLAGS+x} ]; then
FFLAGS="-g -fbacktrace -O3"
fi
mkdir -p $BOOTSTRAP_DIR
$FETCH $SOURCE_URL > $BOOTSTRAP_DIR/fpm.F90
SAVEDIR="$(pwd)"
cd $BOOTSTRAP_DIR
$FC $FFLAGS fpm.F90 -o fpm
cd "$SAVEDIR"
$BOOTSTRAP_DIR/fpm update
$BOOTSTRAP_DIR/fpm install --compiler "$FC" --flag "$FFLAGS" --prefix "$PREFIX"
rm -r $BOOTSTRAP_DIR
fortran-lang-fpm-90bb83a/ChangeLog.md 0000664 0001750 0001750 00000000053 15145116760 017637 0 ustar alastair alastair # Changelog for fpm
## Unreleased changes
fortran-lang-fpm-90bb83a/example_packages/ 0000775 0001750 0001750 00000000000 15145116760 020761 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/implicit-typing/ 0000775 0001750 0001750 00000000000 15145116760 024103 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/implicit-typing/fpm.toml 0000664 0001750 0001750 00000000070 15145116760 025557 0 ustar alastair alastair name = "implicit-typing"
fortran.implicit-typing = true
fortran-lang-fpm-90bb83a/example_packages/implicit-typing/src/ 0000775 0001750 0001750 00000000000 15145116760 024672 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/implicit-typing/src/impl.f90 0000664 0001750 0001750 00000000054 15145116760 026152 0 ustar alastair alastair module impl
parameter(ijk = 1)
end module
fortran-lang-fpm-90bb83a/example_packages/implicit-typing/app/ 0000775 0001750 0001750 00000000000 15145116760 024663 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/implicit-typing/app/main.f90 0000664 0001750 0001750 00000000077 15145116760 026133 0 ustar alastair alastair program test
use impl
if (ijk /= 1) error stop
end program
fortran-lang-fpm-90bb83a/example_packages/dependency_priority/ 0000775 0001750 0001750 00000000000 15145116760 025040 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/dependency_priority/fpm.toml 0000664 0001750 0001750 00000000551 15145116760 026520 0 ustar alastair alastair name = "dependency_tree"
version = "0.1.0"
[build]
auto-executables=true
[dependencies]
# Request toml-f v0.3.1.
toml-f.git = "https://github.com/toml-f/toml-f"
toml-f.tag = "v0.3.1"
# jonquil 0.2.0 requires toml-f v0.4.0.
# Because 0.4.0 is a derived dependency, it should not be used
jonquil.git = "https://github.com/toml-f/jonquil"
jonquil.tag = "v0.2.0"
fortran-lang-fpm-90bb83a/example_packages/dependency_priority/README.md 0000664 0001750 0001750 00000000400 15145116760 026311 0 ustar alastair alastair # dependency_tree
Check dependency tree cascade. "Standard" fpm dependencies feature that the highest-priority one wins
(i.e., top-level dependencies in the manifest, or the first time it's found down the dependency tree)
Check this behavior is confirmed.
fortran-lang-fpm-90bb83a/example_packages/dependency_priority/app/ 0000775 0001750 0001750 00000000000 15145116760 025620 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/dependency_priority/app/main.f90 0000664 0001750 0001750 00000000407 15145116760 027065 0 ustar alastair alastair program main
use tomlf_version, only: tomlf_version_string
implicit none
print *, 'using version =',tomlf_version_string
print *, 'should be =0.3.1'
if (tomlf_version_string=="0.3.1") then
stop 0
else
stop 1
endif
end program main
fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/ 0000775 0001750 0001750 00000000000 15145116760 024034 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/fpm.toml 0000664 0001750 0001750 00000000156 15145116760 025515 0 ustar alastair alastair name = "hello_complex"
[[executable]]
name="say_hello_world"
source-dir="app/say_hello"
main="say_Hello.f90"
fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/test/ 0000775 0001750 0001750 00000000000 15145116760 025013 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/test/test_mod.f90 0000664 0001750 0001750 00000000064 15145116760 027151 0 ustar alastair alastair module test_mod
implicit none
end module test_mod
fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/test/farewell_test.f90 0000664 0001750 0001750 00000000727 15145116760 030201 0 ustar alastair alastair program farewell_test
use farewell_m, only: make_farewell
use test_mod
use iso_fortran_env, only: error_unit, output_unit
implicit none
character(len=:), allocatable :: farewell
allocate(character(len=0) :: farewell)
farewell = make_farewell("World")
if (farewell == "Goodbye, World!") then
write(output_unit, *) "Passed"
else
write(error_unit, *) "Failed"
call exit(1)
end if
end program farewell_test
fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/test/greet_test.f90 0000664 0001750 0001750 00000000714 15145116760 027502 0 ustar alastair alastair program greet_test
use greet_m, only: make_greeting
use test_mod
use iso_fortran_env, only: error_unit, output_unit
implicit none
character(len=:), allocatable :: greeting
allocate(character(len=0) :: greeting)
greeting = make_greeting("World")
if (greeting == "Hello, World!") then
write(output_unit, *) "Passed"
else
write(error_unit, *) "Failed"
call exit(1)
end if
end program greet_test
fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/src/ 0000775 0001750 0001750 00000000000 15145116760 024623 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/src/greet_m.f90 0000664 0001750 0001750 00000000503 15145116760 026563 0 ustar alastair alastair module greet_m
implicit none
private
public :: make_greeting
contains
function make_greeting(name) result(greeting)
character(len=*), intent(in) :: name
character(len=:), allocatable :: greeting
greeting = "Hello, " // name // "!"
end function make_greeting
end module greet_m
fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/src/farewell_m.f90 0000664 0001750 0001750 00000000513 15145116760 027257 0 ustar alastair alastair module farewell_m
implicit none
private
public :: make_farewell
contains
function make_farewell(name) result(greeting)
character(len=*), intent(in) :: name
character(len=:), allocatable :: greeting
greeting = "Goodbye, " // name // "!"
end function make_farewell
end module farewell_m
fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/.gitignore 0000664 0001750 0001750 00000000010 15145116760 026013 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/app/ 0000775 0001750 0001750 00000000000 15145116760 024614 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/app/say_goodbye.f90 0000664 0001750 0001750 00000000234 15145116760 027437 0 ustar alastair alastair program say_goodbye
use farewell_m, only: make_farewell
use app_mod
implicit none
print *, make_farewell("World")
end program say_goodbye
fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/app/app_mod.f90 0000664 0001750 0001750 00000000062 15145116760 026551 0 ustar alastair alastair module app_mod
implicit none
end module app_mod
fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/app/say_hello/ 0000775 0001750 0001750 00000000000 15145116760 026573 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/app/say_hello/app_hello_mod.f90 0000664 0001750 0001750 00000000176 15145116760 031721 0 ustar alastair alastair module app_hello_mod
use app_extra_mod, only: greet_object
implicit none
integer :: hello_int = 42
end module app_hello_mod
fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/app/say_hello/say_Hello.f90 0000664 0001750 0001750 00000000264 15145116760 031034 0 ustar alastair alastair program say_Hello
use greet_m, only: make_greeting
use app_hello_mod, only: greet_object
implicit none
print *, make_greeting(greet_object)
end program say_Hello
fortran-lang-fpm-90bb83a/example_packages/hello_complex_2/app/say_hello/app_extra_mod.f90 0000664 0001750 0001750 00000000151 15145116760 031732 0 ustar alastair alastair module app_extra_mod
implicit none
character(len=5) :: greet_object = "World"
end module app_extra_mod
fortran-lang-fpm-90bb83a/example_packages/program_with_module/ 0000775 0001750 0001750 00000000000 15145116760 025030 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/program_with_module/fpm.toml 0000664 0001750 0001750 00000000035 15145116760 026505 0 ustar alastair alastair name = "Program_with_module"
fortran-lang-fpm-90bb83a/example_packages/program_with_module/.gitignore 0000664 0001750 0001750 00000000010 15145116760 027007 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/program_with_module/app/ 0000775 0001750 0001750 00000000000 15145116760 025610 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/program_with_module/app/main.f90 0000664 0001750 0001750 00000000350 15145116760 027052 0 ustar alastair alastair module greet_m
implicit none
character(*), parameter :: greeting = 'Hello, fpm!'
end module greet_m
program program_with_module
use greet_m, only: greeting
implicit none
print *, greeting
end program program_with_module
fortran-lang-fpm-90bb83a/example_packages/with_c/ 0000775 0001750 0001750 00000000000 15145116760 022236 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/with_c/fpm.toml 0000664 0001750 0001750 00000000020 15145116760 023705 0 ustar alastair alastair name = "with_c"
fortran-lang-fpm-90bb83a/example_packages/with_c/src/ 0000775 0001750 0001750 00000000000 15145116760 023025 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/with_c/src/c_code.c 0000664 0001750 0001750 00000000462 15145116760 024407 0 ustar alastair alastair #include
/*
* Decides whether a given file name is a directory.
* return 1 if file exists and is a directory
* Source (Public domain): https://github.com/urbanjost/M_system
*/
int my_isdir (const char *path) {
struct stat sb;
return stat(path, &sb) == 0 && S_ISDIR (sb.st_mode);
} fortran-lang-fpm-90bb83a/example_packages/with_c/src/with_c.f90 0000664 0001750 0001750 00000001423 15145116760 024622 0 ustar alastair alastair module with_c
use iso_c_binding, only: c_char, c_int, c_null_char
implicit none
contains
function system_isdir(dirname)
! Source (Public domain): https://github.com/urbanjost/M_system
!
implicit none
character(len=*),intent(in) :: dirname
logical :: system_isdir
interface
function c_isdir(dirname) bind (C,name="my_isdir") result (c_ierr)
import c_char,c_int
character(kind=c_char,len=1),intent(in) :: dirname(*)
integer(kind=c_int) :: c_ierr
end function c_isdir
end interface
system_isdir= c_isdir(trim(dirname)//c_null_char) == 1
end function system_isdir
end module with_c fortran-lang-fpm-90bb83a/example_packages/with_c/.gitignore 0000664 0001750 0001750 00000000010 15145116760 024215 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/with_c/app/ 0000775 0001750 0001750 00000000000 15145116760 023016 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/with_c/app/main.f90 0000664 0001750 0001750 00000000422 15145116760 024260 0 ustar alastair alastair program with_c_app
use with_c
implicit none
write(*,*) "isdir('app') = ", system_isdir('app')
write(*,*) "isdir('src') = ", system_isdir('src')
write(*,*) "isdir('test') = ", system_isdir('test')
write(*,*) "isdir('bench') = ", system_isdir('bench')
end program with_c_app fortran-lang-fpm-90bb83a/example_packages/shared_lib/ 0000775 0001750 0001750 00000000000 15145116760 023055 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/shared_lib/fpm.toml 0000664 0001750 0001750 00000000117 15145116760 024533 0 ustar alastair alastair # Shared library with no executables
name = "shared_lib"
library.type="shared"
fortran-lang-fpm-90bb83a/example_packages/shared_lib/src/ 0000775 0001750 0001750 00000000000 15145116760 023644 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/shared_lib/src/shared_lib.f90 0000664 0001750 0001750 00000000455 15145116760 026264 0 ustar alastair alastair module shared_lib
implicit none
private
public :: say_hello
public :: test_something
contains
subroutine say_hello
print *, "Hello, shared_lib!"
end subroutine say_hello
integer function test_something()
test_something = 123
end function test_something
end module shared_lib
fortran-lang-fpm-90bb83a/example_packages/hello_world/ 0000775 0001750 0001750 00000000000 15145116760 023273 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_world/fpm.toml 0000664 0001750 0001750 00000000025 15145116760 024747 0 ustar alastair alastair name = "hello_world"
fortran-lang-fpm-90bb83a/example_packages/hello_world/.gitignore 0000664 0001750 0001750 00000000010 15145116760 025252 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/hello_world/app/ 0000775 0001750 0001750 00000000000 15145116760 024053 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_world/app/main.f90 0000664 0001750 0001750 00000000111 15145116760 025310 0 ustar alastair alastair program hello_world
print *, "Hello, World!"
end program hello_world
fortran-lang-fpm-90bb83a/example_packages/link_executable/ 0000775 0001750 0001750 00000000000 15145116760 024117 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/link_executable/fpm.toml 0000664 0001750 0001750 00000000161 15145116760 025574 0 ustar alastair alastair name = "link_executable"
[[executable]]
name = "gomp_test"
source-dir = "app"
main = "main.f90"
link = ["gomp"]
fortran-lang-fpm-90bb83a/example_packages/link_executable/include/ 0000775 0001750 0001750 00000000000 15145116760 025542 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/link_executable/include/test.f90 0000664 0001750 0001750 00000000033 15145116760 027035 0 ustar alastair alastair real, parameter :: a = 2.0
fortran-lang-fpm-90bb83a/example_packages/link_executable/.gitignore 0000664 0001750 0001750 00000000010 15145116760 026076 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/link_executable/app/ 0000775 0001750 0001750 00000000000 15145116760 024677 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/link_executable/app/main.f90 0000664 0001750 0001750 00000000266 15145116760 026147 0 ustar alastair alastair program gomp_example
implicit none
interface
integer function omp_get_num_procs()
end function
end interface
print *, omp_get_num_procs()
end program gomp_example
fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi_c/ 0000775 0001750 0001750 00000000000 15145116760 024372 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi_c/fpm.toml 0000664 0001750 0001750 00000000241 15145116760 026046 0 ustar alastair alastair name = "test_mpi_c"
dependencies.mpi = "*"
fortran.implicit-typing=true
fortran.implicit-external=true
[[executable]]
name = "test-mpi-c-main"
main = "main.c"
fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi_c/README.md 0000664 0001750 0001750 00000000105 15145116760 025645 0 ustar alastair alastair # test_mpi
This test program prints the running thread ID using MPI.
fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi_c/app/ 0000775 0001750 0001750 00000000000 15145116760 025152 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi_c/app/main.c 0000664 0001750 0001750 00000001317 15145116760 026244 0 ustar alastair alastair // Test MPI linking from a C main program
#include
#include
int main(int argc, char** argv)
{
int ierror,ncpus,cpuid;
// Initialize MPI argument
ierror = MPI_Init(&argc, &argv);
if (ierror) {
printf("MPI_Init failed with error %d \n",ierror);
return 1;
}
// Get number of processes and current rank
MPI_Comm_size(MPI_COMM_WORLD, &ncpus);
// Get Rank of the current process
MPI_Comm_rank(MPI_COMM_WORLD, &cpuid);
printf("Hello, MPI C World from rank %d of %d! \n",cpuid+1,ncpus);
// Finalize MPI environment.
ierror = MPI_Finalize();
if (ierror) {
printf("MPI_Finalize failed with error %d \n",ierror);
return 1;
} else {
return 0;
}
}
fortran-lang-fpm-90bb83a/example_packages/preprocess_hello_dependency/ 0000775 0001750 0001750 00000000000 15145116760 026527 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_hello_dependency/fpm.toml 0000664 0001750 0001750 00000000045 15145116760 030205 0 ustar alastair alastair name = "preprocess_hello_dependency"
fortran-lang-fpm-90bb83a/example_packages/preprocess_hello_dependency/README.md 0000664 0001750 0001750 00000000063 15145116760 030005 0 ustar alastair alastair # preprocess_hello_dependency
My cool new project!
fortran-lang-fpm-90bb83a/example_packages/preprocess_hello_dependency/src/ 0000775 0001750 0001750 00000000000 15145116760 027316 5 ustar alastair alastair ././@LongLink 0000644 0000000 0000000 00000000152 00000000000 011601 L ustar root root fortran-lang-fpm-90bb83a/example_packages/preprocess_hello_dependency/src/preprocess_hello_dependency.f90 fortran-lang-fpm-90bb83a/example_packages/preprocess_hello_dependency/src/preprocess_hello_dependenc0000664 0001750 0001750 00000000701 15145116760 034614 0 ustar alastair alastair module preprocess_hello_dependency
implicit none
private
public :: say_hello
contains
subroutine say_hello
!> If this build fails, then it implies that macros are getting passed to the dependency.
#ifdef FOO
This breaks the build inside dependency. This implies that macros are getting passed to the dependeny.
#endif
print *, "Hello, preprocess_hello_dependency!"
end subroutine say_hello
end module preprocess_hello_dependency
fortran-lang-fpm-90bb83a/example_packages/nonintrinsic/ 0000775 0001750 0001750 00000000000 15145116760 023476 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/nonintrinsic/fpm.toml 0000664 0001750 0001750 00000000027 15145116760 025154 0 ustar alastair alastair name = "non-intrinsic"
fortran-lang-fpm-90bb83a/example_packages/nonintrinsic/src/ 0000775 0001750 0001750 00000000000 15145116760 024265 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/nonintrinsic/src/iso_fortran_env.f90 0000664 0001750 0001750 00000000152 15145116760 030000 0 ustar alastair alastair module iso_fortran_env
implicit none
integer, parameter :: ijk = 0
end module iso_fortran_env
fortran-lang-fpm-90bb83a/example_packages/nonintrinsic/.gitignore 0000664 0001750 0001750 00000000010 15145116760 025455 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/nonintrinsic/app/ 0000775 0001750 0001750 00000000000 15145116760 024256 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/nonintrinsic/app/main.f90 0000664 0001750 0001750 00000000176 15145116760 025526 0 ustar alastair alastair program test_nonintr
use, non_intrinsic :: iso_fortran_env
! ijk=0 can be read
stop ijk
end program test_nonintr
fortran-lang-fpm-90bb83a/example_packages/static_app_only/ 0000775 0001750 0001750 00000000000 15145116760 024151 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/static_app_only/fpm.toml 0000664 0001750 0001750 00000000457 15145116760 025636 0 ustar alastair alastair # App only, use shared libs from other folder, no provided sources
name = "static_app_only"
library.type="static"
install.library=true
[dependencies]
shared_lib_extra = { path = "../shared_lib_extra" }
[dev-dependencies]
test-drive = { git = "https://github.com/fortran-lang/test-drive", tag="v0.5.0" }
fortran-lang-fpm-90bb83a/example_packages/static_app_only/test/ 0000775 0001750 0001750 00000000000 15145116760 025130 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/static_app_only/test/test.f90 0000664 0001750 0001750 00000002527 15145116760 026435 0 ustar alastair alastair module test_shared_lib
use testdrive, only : new_unittest, unittest_type, error_type, check
use shared_lib, only: test_something
implicit none
public :: collect
contains
!> Collect all exported unit tests
subroutine collect(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ new_unittest("shared_lib", test_shared) ]
end subroutine collect
subroutine test_shared(error)
type(error_type), allocatable, intent(out) :: error
call check(error, test_something(), 123, "Should be test_something==123")
end subroutine test_shared
end module test_shared_lib
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_shared_lib, only : collect
implicit none
integer :: stat
type(testsuite_type), allocatable :: testsuite
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuite = new_testsuite("shared_lib", collect)
write(error_unit, fmt) "Testing:", testsuite%name
call run_testsuite(testsuite%collect, error_unit, stat)
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-fpm-90bb83a/example_packages/static_app_only/app/ 0000775 0001750 0001750 00000000000 15145116760 024731 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/static_app_only/app/main.f90 0000664 0001750 0001750 00000000111 15145116760 026166 0 ustar alastair alastair program main
use testdrive
print *, 'Hello, world!'
end program main
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_deps/ 0000775 0001750 0001750 00000000000 15145116760 025023 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_deps/fpm.toml 0000664 0001750 0001750 00000000116 15145116760 026500 0 ustar alastair alastair name = "preprocess_cpp_deps"
[dependencies]
utils = { path = "crate/utils" }
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_deps/app/ 0000775 0001750 0001750 00000000000 15145116760 025603 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_deps/app/main.f90 0000664 0001750 0001750 00000000136 15145116760 027047 0 ustar alastair alastair program hello_fpm
use utils, only: say_hello
call say_hello()
end program hello_fpm
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_deps/crate/ 0000775 0001750 0001750 00000000000 15145116760 026121 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_deps/crate/utils/ 0000775 0001750 0001750 00000000000 15145116760 027261 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_deps/crate/utils/fpm.toml 0000664 0001750 0001750 00000000077 15145116760 030744 0 ustar alastair alastair name = "utils"
[preprocess]
[preprocess.cpp]
macros = ["X=1"]
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_deps/crate/utils/src/ 0000775 0001750 0001750 00000000000 15145116760 030050 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_deps/crate/utils/src/say_hello.f90 0000664 0001750 0001750 00000000244 15145116760 032347 0 ustar alastair alastair module utils
implicit none
contains
subroutine say_hello()
print '(a,1x,i0)', "Hello, X =", X
end subroutine say_hello
end module utils
fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi/ 0000775 0001750 0001750 00000000000 15145116760 024070 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi/fpm.toml 0000664 0001750 0001750 00000000145 15145116760 025547 0 ustar alastair alastair name = "test_mpi"
dependencies.mpi = "*"
fortran.implicit-external=true
fortran.implicit-typing=true
fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi/README.md 0000664 0001750 0001750 00000000615 15145116760 025351 0 ustar alastair alastair # test_mpi
This test program prints the running thread ID using MPI.
PLEASE NOTE:
- Test app uses 'mpif.h' and not 'use mpi' or 'use mpi_f08' because the latter are compiler-dependent,
and the MPI implementation on the local machine may not offer an implementation for them with the same
compiler that fpm is using.
- Using mpif.h will be the most backward compatible and platform agnostic
fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi/app/ 0000775 0001750 0001750 00000000000 15145116760 024650 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi/app/main.f90 0000664 0001750 0001750 00000001250 15145116760 026112 0 ustar alastair alastair program with_mpi
implicit none
include 'mpif.h'
integer, parameter :: INIT_ERROR = 1
integer, parameter :: RANK_ERROR = 2
integer :: ierror,ncpus,cpuid
! Initialize MPI argument
call MPI_INIT(ierror);
if (ierror/=0) stop INIT_ERROR
! Get number of processes and current rank
call MPI_Comm_size(MPI_COMM_WORLD, ncpus, ierror)
if (ierror/=0) stop RANK_ERROR
call MPI_Comm_rank(MPI_COMM_WORLD, cpuid, ierror)
if (ierror/=0) stop RANK_ERROR
print "('Hello, mpi world from rank ',i0,' of ',i0,'!')", cpuid+1,ncpus
! Finalize MPI environment.
call MPI_FINALIZE(ierror)
if (ierror/=0) stop INIT_ERROR
stop 0
end program with_mpi
fortran-lang-fpm-90bb83a/example_packages/static_lib_empty/ 0000775 0001750 0001750 00000000000 15145116760 024314 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/static_lib_empty/fpm.toml 0000664 0001750 0001750 00000000231 15145116760 025767 0 ustar alastair alastair name = "static_lib_empty"
library.type="static"
[dependencies]
shared_lib = { path = "../shared_lib" }
shared_app_only = { path = "../shared_app_only" }
fortran-lang-fpm-90bb83a/example_packages/metapackage_dep_parent/ 0000775 0001750 0001750 00000000000 15145116760 025424 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_dep_parent/fpm.toml 0000664 0001750 0001750 00000000421 15145116760 027100 0 ustar alastair alastair name = "metapackage_dep_parent"
version = "0.1.0"
# Note: This package does NOT directly declare openmp as a dependency.
# The openmp metapackage should be propagated from metapackage_dep_child.
[dependencies]
metapackage_dep_child = { path = "../metapackage_dep_child" }
fortran-lang-fpm-90bb83a/example_packages/metapackage_dep_parent/app/ 0000775 0001750 0001750 00000000000 15145116760 026204 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_dep_parent/app/main.f90 0000664 0001750 0001750 00000000722 15145116760 027451 0 ustar alastair alastair program main
use metapackage_dep_child, only: get_num_threads
use omp_lib
implicit none
integer :: n
! This uses the child module which requires openmp
n = get_num_threads()
print '(a,i0)', "Threads from child module: ", n
! This also uses omp_lib directly - should work because openmp
! metapackage is propagated from the child dependency
print '(a,i0)', "Max threads available: ", omp_get_max_threads()
end program main
fortran-lang-fpm-90bb83a/example_packages/cpp_files/ 0000775 0001750 0001750 00000000000 15145116760 022725 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/cpp_files/fpm.toml 0000664 0001750 0001750 00000000023 15145116760 024377 0 ustar alastair alastair name = "cpp_files"
fortran-lang-fpm-90bb83a/example_packages/cpp_files/README.md 0000664 0001750 0001750 00000000041 15145116760 024177 0 ustar alastair alastair # cpp_files
My cool new project!
fortran-lang-fpm-90bb83a/example_packages/cpp_files/test/ 0000775 0001750 0001750 00000000000 15145116760 023704 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/cpp_files/test/check.f90 0000664 0001750 0001750 00000000653 15145116760 025305 0 ustar alastair alastair program check
use iso_c_binding, only: c_size_t
use cpp_files
implicit none
integer :: i, max_element
integer, parameter :: array(*) = [(i,i=-50,10)]
max_element = intvec_maxval(array,size(array,1,c_size_t))
if (max_element == maxval(array)) then
write(*,*) ' PASSED: Max element is ',max_element
else
write(*,*) ' (!) FAILED: Incorrect max element returned'
stop 1
end if
end program check
fortran-lang-fpm-90bb83a/example_packages/cpp_files/src/ 0000775 0001750 0001750 00000000000 15145116760 023514 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/cpp_files/src/hello_world.cpp 0000664 0001750 0001750 00000000312 15145116760 026526 0 ustar alastair alastair #include
#include
extern "C" {
int intvec_maxval(int* array, size_t n){
std::vector vec(array, array + n);
return *(std::max_element(vec.begin(), vec.end()));
}
} fortran-lang-fpm-90bb83a/example_packages/cpp_files/src/cpp_files.f90 0000664 0001750 0001750 00000000612 15145116760 025777 0 ustar alastair alastair module cpp_files
use, intrinsic :: ISO_C_Binding
implicit none
private
public :: intvec_maxval
interface
integer(c_int) function intvec_maxval(array, n) bind(C, name = "intvec_maxval")
import :: c_int, c_size_t
integer(c_int), intent(in) :: array(*)
integer(c_size_t), intent(in), value :: n
end function intvec_maxval
end interface
end module cpp_files
fortran-lang-fpm-90bb83a/example_packages/custom_module_dir/ 0000775 0001750 0001750 00000000000 15145116760 024476 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/custom_module_dir/fpm.toml 0000664 0001750 0001750 00000000130 15145116760 026147 0 ustar alastair alastair name = "custom-module-dir"
install.library = true
install.module-dir = "custom_modules"
fortran-lang-fpm-90bb83a/example_packages/custom_module_dir/README.md 0000664 0001750 0001750 00000001425 15145116760 025757 0 ustar alastair alastair # Custom Module Directory Example
This example demonstrates the use of a custom module directory in the `[install]` section of `fpm.toml`.
## Features
- Two simple Fortran modules: `greeting` and `math_utils`
- Custom module installation directory specified as `custom_modules`
- Shows how modules can be installed to a different location than headers
## Configuration
In `fpm.toml`:
```toml
[install]
library = true
module-dir = "custom_modules"
```
This configuration will install compiled `.mod` files to the `custom_modules` directory instead of the default `include` directory.
## Testing
To test this example:
```bash
cd example_packages/custom_module_dir
fpm build
fpm install --prefix /tmp/test_install
# Check that .mod files are in /tmp/test_install/custom_modules/
``` fortran-lang-fpm-90bb83a/example_packages/custom_module_dir/src/ 0000775 0001750 0001750 00000000000 15145116760 025265 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/custom_module_dir/src/math_utils.f90 0000664 0001750 0001750 00000000702 15145116760 027755 0 ustar alastair alastair module math_utils
implicit none
private
public :: add_numbers, multiply_numbers
contains
function add_numbers(a, b) result(sum)
integer, intent(in) :: a, b
integer :: sum
sum = a + b
end function add_numbers
function multiply_numbers(a, b) result(product)
integer, intent(in) :: a, b
integer :: product
product = a * b
end function multiply_numbers
end module math_utils fortran-lang-fpm-90bb83a/example_packages/custom_module_dir/src/greeting.f90 0000664 0001750 0001750 00000000370 15145116760 027411 0 ustar alastair alastair module greeting
implicit none
private
public :: say_hello
contains
subroutine say_hello(name)
character(len=*), intent(in) :: name
print *, 'Hello, ' // name // '!'
end subroutine say_hello
end module greeting fortran-lang-fpm-90bb83a/example_packages/tree_shake/ 0000775 0001750 0001750 00000000000 15145116760 023073 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/tree_shake/fpm.toml 0000664 0001750 0001750 00000000023 15145116760 024545 0 ustar alastair alastair name = "tree_shake" fortran-lang-fpm-90bb83a/example_packages/tree_shake/test/ 0000775 0001750 0001750 00000000000 15145116760 024052 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/tree_shake/test/greet_test.f90 0000664 0001750 0001750 00000000673 15145116760 026545 0 ustar alastair alastair program greet_test
use greet_m, only: make_greeting
use iso_fortran_env, only: error_unit, output_unit
implicit none
character(len=:), allocatable :: greeting
allocate(character(len=0) :: greeting)
greeting = make_greeting("World")
if (greeting == "Hello, World!") then
write(output_unit, *) "Passed"
else
write(error_unit, *) "Failed"
call exit(1)
end if
end program greet_test
fortran-lang-fpm-90bb83a/example_packages/tree_shake/src/ 0000775 0001750 0001750 00000000000 15145116760 023662 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/tree_shake/src/subdir/ 0000775 0001750 0001750 00000000000 15145116760 025152 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/tree_shake/src/subdir/constants.f90 0000664 0001750 0001750 00000000436 15145116760 027511 0 ustar alastair alastair ! This module is used indirectly by the executables
! and hence should not be dropped during tree-shaking/pruning
module subdir_constants
implicit none
character(*), parameter :: GREET_STR = 'Hello, '
character(*), parameter :: FAREWELL_STR = 'Goodbye, '
end module subdir_constants
fortran-lang-fpm-90bb83a/example_packages/tree_shake/src/greet_m.f90 0000664 0001750 0001750 00000000731 15145116760 025625 0 ustar alastair alastair ! This module is directly by the executables and
! hence should not be dropped during tree-shaking/pruning
module greet_m
use subdir_constants, only: GREET_STR
implicit none
private
public :: make_greeting
contains
function make_greeting(name) result(greeting)
character(len=*), intent(in) :: name
character(len=:), allocatable :: greeting
greeting = GREET_STR // name // "!"
end function make_greeting
end module greet_m
fortran-lang-fpm-90bb83a/example_packages/tree_shake/src/extra_m.f90 0000664 0001750 0001750 00000000577 15145116760 025652 0 ustar alastair alastair ! This module is not used by any other sources,
! however because it also contains an external function
! it cannot be dropped during tree-shaking/pruning
module extra_m
use subdir_constants, only: FAREWELL_STR
implicit none
private
integer, parameter :: m = 0
end
function external_function() result(i)
integer :: i
i = 1
end function external_function fortran-lang-fpm-90bb83a/example_packages/tree_shake/src/farewell_m.f90 0000664 0001750 0001750 00000001041 15145116760 026313 0 ustar alastair alastair ! This module is not used by any other sources
! and only contains a module (no non-module subprograms),
! therefore it should be dropped during tree-shaking/pruning
module farewell_m
use subdir_constants, only: FAREWELL_STR
implicit none
private
public :: make_farewell
contains
function make_farewell(name) result(greeting)
character(len=*), intent(in) :: name
character(len=:), allocatable :: greeting
greeting = FAREWELL_STR // name // "!"
end function make_farewell
end module farewell_m
fortran-lang-fpm-90bb83a/example_packages/tree_shake/.gitignore 0000664 0001750 0001750 00000000010 15145116760 025052 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/tree_shake/app/ 0000775 0001750 0001750 00000000000 15145116760 023653 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/tree_shake/app/say_Hello.f90 0000664 0001750 0001750 00000000467 15145116760 026121 0 ustar alastair alastair program say_Hello
use greet_m, only: make_greeting
implicit none
interface
function external_function() result(i)
integer :: i
end function external_function
end interface
print *, make_greeting("World")
print *, external_function()
end program say_Hello
fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi_cpp/ 0000775 0001750 0001750 00000000000 15145116760 024732 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi_cpp/fpm.toml 0000664 0001750 0001750 00000000233 15145116760 026407 0 ustar alastair alastair name = "test_mpi_cpp"
dependencies.mpi="*"
fortran.implicit-typing=true
fortran.implicit-external=true
[[executable]]
name="test-mpi-cpp"
main="main.cpp"
fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi_cpp/README.md 0000664 0001750 0001750 00000000105 15145116760 026205 0 ustar alastair alastair # test_mpi
This test program prints the running thread ID using MPI.
fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi_cpp/app/ 0000775 0001750 0001750 00000000000 15145116760 025512 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_mpi_cpp/app/main.cpp 0000664 0001750 0001750 00000001407 15145116760 027144 0 ustar alastair alastair // Test MPI linking from a C main program
#include
#include
using namespace std;
int main(int argc, char** argv)
{
int ierror,ncpus,cpuid;
// Initialize MPI argument
ierror = MPI_Init(&argc, &argv);
if (ierror) {
cout << "MPI_Init failed with error " << ierror << endl;
return 1;
}
// Get number of processes and current rank
MPI_Comm_size(MPI_COMM_WORLD, &ncpus);
// Get Rank of the current process
MPI_Comm_rank(MPI_COMM_WORLD, &cpuid);
cout << "Hello, MPI C++ World from rank " << cpuid << " of " << ncpus << "!" << endl;
// Finalize MPI environment.
ierror = MPI_Finalize();
if (ierror) {
cout << "MPI_Finalize failed with error " << ierror << endl;
return 1;
} else {
return 0;
}
}
fortran-lang-fpm-90bb83a/example_packages/auto_with_nondefault_main/ 0000775 0001750 0001750 00000000000 15145116760 026207 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/auto_with_nondefault_main/fpm.toml 0000664 0001750 0001750 00000000116 15145116760 027664 0 ustar alastair alastair name = "auto_with_nondefault_main"
[build]
auto-executables = true
[library]
fortran-lang-fpm-90bb83a/example_packages/auto_with_nondefault_main/README.md 0000664 0001750 0001750 00000000167 15145116760 027472 0 ustar alastair alastair # auto_with_nondefault_main
Install auto-executable with non-default source name
fpm install --prefix=/path/to/install
fortran-lang-fpm-90bb83a/example_packages/auto_with_nondefault_main/.gitignore 0000664 0001750 0001750 00000000024 15145116760 030173 0 ustar alastair alastair build/*
installed/*
fortran-lang-fpm-90bb83a/example_packages/auto_with_nondefault_main/app/ 0000775 0001750 0001750 00000000000 15145116760 026767 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/auto_with_nondefault_main/app/non_default_name.f90 0000664 0001750 0001750 00000000072 15145116760 032604 0 ustar alastair alastair program main
print *, 'hello, world!'
end program main
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_suffix/ 0000775 0001750 0001750 00000000000 15145116760 025374 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_suffix/fpm.toml 0000664 0001750 0001750 00000000236 15145116760 027054 0 ustar alastair alastair name = "preprocess_cpp_suffix"
version = "1"
[preprocess]
[preprocess.cpp]
macros = ["TESTMACRO", "TESTMACRO2=3", "TESTMACRO3={version}"]
suffixes = ["fpp"]
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_suffix/src/ 0000775 0001750 0001750 00000000000 15145116760 026163 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_suffix/src/preprocess_cpp.fpp 0000664 0001750 0001750 00000000562 15145116760 031724 0 ustar alastair alastair module preprocess_cpp
implicit none
private
public :: say_hello
contains
subroutine say_hello
print *, "Hello, preprocess_cpp!"
#ifndef TESTMACRO
This breaks the build.
#endif
#if TESTMACRO2 != 3
This breaks the build.
#endif
#if TESTMACRO3 != 1
This breaks the build.
#endif
end subroutine say_hello
end module preprocess_cpp
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_suffix/.gitignore 0000664 0001750 0001750 00000000010 15145116760 027353 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_suffix/app/ 0000775 0001750 0001750 00000000000 15145116760 026154 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_suffix/app/main.f90 0000664 0001750 0001750 00000000217 15145116760 027420 0 ustar alastair alastair program test_preprocess_suffix
use preprocess_cpp
#ifndef TESTMACRO
stop -1
#else
stop 0
#endif
end program test_preprocess_suffix
fortran-lang-fpm-90bb83a/example_packages/metapackage_netcdf/ 0000775 0001750 0001750 00000000000 15145116760 024546 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_netcdf/fpm.toml 0000664 0001750 0001750 00000000064 15145116760 026225 0 ustar alastair alastair name = "metapackage_netcdf"
dependencies.netcdf="*"
fortran-lang-fpm-90bb83a/example_packages/metapackage_netcdf/app/ 0000775 0001750 0001750 00000000000 15145116760 025326 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_netcdf/app/main.f90 0000664 0001750 0001750 00000000401 15145116760 026565 0 ustar alastair alastair program metapackage_netcdf
use netcdf4_f03
implicit none
integer(c_int) :: ncid, retval
retval = nf_create("dummy.nc", NF_INMEMORY, ncid)
if (retval /= nf_noerr) error stop nf_strerror(retval)
stop 0
end program metapackage_netcdf
fortran-lang-fpm-90bb83a/example_packages/metapackage_openmp/ 0000775 0001750 0001750 00000000000 15145116760 024601 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_openmp/fpm.toml 0000664 0001750 0001750 00000000060 15145116760 026254 0 ustar alastair alastair name = "test_openmp"
dependencies.openmp = "*"
fortran-lang-fpm-90bb83a/example_packages/metapackage_openmp/README.md 0000664 0001750 0001750 00000000307 15145116760 026060 0 ustar alastair alastair # test_openmp
This test program prints the running thread ID using OpenMP.
Module omp_lib is invoked, so, this code cannot build if the OpenMP library
is not properly enabled by the compiler flags.
fortran-lang-fpm-90bb83a/example_packages/metapackage_openmp/test/ 0000775 0001750 0001750 00000000000 15145116760 025560 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_openmp/test/check.f90 0000664 0001750 0001750 00000000122 15145116760 027150 0 ustar alastair alastair program check
implicit none
print *, "Put some tests in here!"
end program check
fortran-lang-fpm-90bb83a/example_packages/metapackage_openmp/src/ 0000775 0001750 0001750 00000000000 15145116760 025370 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_openmp/src/test_openmp.f90 0000664 0001750 0001750 00000000426 15145116760 030247 0 ustar alastair alastair module test_openmp
implicit none
private
public :: say_hello
contains
subroutine say_hello(thread_ID)
integer, intent(in) :: thread_ID
print "(a,i0,a)", "Hello, test_openmp is called from thread ",thread_ID,"!"
end subroutine say_hello
end module test_openmp
fortran-lang-fpm-90bb83a/example_packages/metapackage_openmp/app/ 0000775 0001750 0001750 00000000000 15145116760 025361 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_openmp/app/main.f90 0000664 0001750 0001750 00000000630 15145116760 026624 0 ustar alastair alastair ! OpenMP test case
! This test program will only run if openmp is properly enabled in the compiler flags.
! Otherwise, the omp_lib module won't be found and the code cannot be built.
program openmp_test
use test_openmp, only: say_hello
use omp_lib
implicit none
!$omp parallel
call say_hello(thread_ID=OMP_GET_THREAD_NUM())
!$omp end parallel
! Successful return
stop 0
end program openmp_test
fortran-lang-fpm-90bb83a/example_packages/makefile_complex/ 0000775 0001750 0001750 00000000000 15145116760 024265 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/makefile_complex/fpm.toml 0000664 0001750 0001750 00000000220 15145116760 025736 0 ustar alastair alastair name = "makefile_complex"
[dependencies]
with_makefile = { path = "../with_makefile" }
[library]
source-dir = "src"
build-script = "Makefile"
fortran-lang-fpm-90bb83a/example_packages/makefile_complex/src/ 0000775 0001750 0001750 00000000000 15145116760 025054 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/makefile_complex/src/wrapper_mod.f90 0000664 0001750 0001750 00000000371 15145116760 027714 0 ustar alastair alastair module wrapper_mod
use hello_makefile, only: say_hello_from_makefile
implicit none
private
public :: do_stuff
contains
subroutine do_stuff
call say_hello_from_makefile
end subroutine do_stuff
end module wrapper_mod
fortran-lang-fpm-90bb83a/example_packages/makefile_complex/.gitignore 0000664 0001750 0001750 00000000010 15145116760 026244 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/makefile_complex/Makefile 0000664 0001750 0001750 00000000446 15145116760 025731 0 ustar alastair alastair INCLUDE_FLAGS = $(addprefix -I,$(INCLUDE_DIRS))
$(BUILD_DIR)/libmakefile_complex.a: $(BUILD_DIR)/wrapper_mod.o
ar rs $(@) $(^)
$(BUILD_DIR)/wrapper_mod.mod: src/wrapper_mod.f90
$(BUILD_DIR)/wrapper_mod.o: src/wrapper_mod.f90
$(FC) -c -J$(BUILD_DIR) $(INCLUDE_FLAGS) $(FFLAGS) -o $(@) $(<)
fortran-lang-fpm-90bb83a/example_packages/makefile_complex/app/ 0000775 0001750 0001750 00000000000 15145116760 025045 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/makefile_complex/app/main.f90 0000664 0001750 0001750 00000000200 15145116760 026301 0 ustar alastair alastair program makefile_complex
use wrapper_mod, only: do_stuff
implicit none
call do_stuff
end program makefile_complex
fortran-lang-fpm-90bb83a/example_packages/metapackage_dep_child/ 0000775 0001750 0001750 00000000000 15145116760 025216 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_dep_child/fpm.toml 0000664 0001750 0001750 00000000116 15145116760 026673 0 ustar alastair alastair name = "metapackage_dep_child"
version = "0.1.0"
[dependencies]
openmp = "*"
fortran-lang-fpm-90bb83a/example_packages/metapackage_dep_child/src/ 0000775 0001750 0001750 00000000000 15145116760 026005 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_dep_child/src/metapackage_dep_child.f90 0000664 0001750 0001750 00000000434 15145116760 032563 0 ustar alastair alastair module metapackage_dep_child
use omp_lib
implicit none
contains
function get_num_threads() result(n)
integer :: n
!$omp parallel
n = omp_get_num_threads()
!$omp end parallel
end function get_num_threads
end module metapackage_dep_child
fortran-lang-fpm-90bb83a/example_packages/test_duplicates/ 0000775 0001750 0001750 00000000000 15145116760 024155 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/test_duplicates/fpm.toml 0000664 0001750 0001750 00000001115 15145116760 025632 0 ustar alastair alastair name = "test_duplicates"
version = "0.1.0"
[[executable]]
name = "test_program"
source-dir = "app"
main = "main.f90"
[features]
# This should cause a duplicate executable error when features are combined
feature1.executable.name = "my_exe"
feature1.executable.source-dir = "app1"
feature1.executable.main = "main1.f90"
feature2.executable.name = "my_exe" # Same name - should cause duplicate error
feature2.executable.source-dir = "app2"
feature2.executable.main = "main2.f90"
[profiles]
# This profile combines features with duplicate executables
combined = ["feature1", "feature2"] fortran-lang-fpm-90bb83a/example_packages/test_duplicates/app/ 0000775 0001750 0001750 00000000000 15145116760 024735 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/test_duplicates/app/main.f90 0000664 0001750 0001750 00000000124 15145116760 026176 0 ustar alastair alastair program test_program
print *, "Hello from test program"
end program test_program fortran-lang-fpm-90bb83a/example_packages/metapackage_stdlib/ 0000775 0001750 0001750 00000000000 15145116760 024564 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_stdlib/fpm.toml 0000664 0001750 0001750 00000000060 15145116760 026237 0 ustar alastair alastair name = "test_stdlib"
dependencies.stdlib = "*"
fortran-lang-fpm-90bb83a/example_packages/metapackage_stdlib/README.md 0000664 0001750 0001750 00000000364 15145116760 026046 0 ustar alastair alastair # test_stdlib
This test program generates a real [1,2,3,4,5] array using stdlib.
stdlib math and kinds modules are invoked; so this program cannot be built if stdlib is not
properly built and linked. stdlib tests are not run in this program.
fortran-lang-fpm-90bb83a/example_packages/metapackage_stdlib/src/ 0000775 0001750 0001750 00000000000 15145116760 025353 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_stdlib/src/metapackage_stdlib.f90 0000664 0001750 0001750 00000000316 15145116760 031476 0 ustar alastair alastair module metapackage_stdlib
implicit none
private
public :: say_hello
contains
subroutine say_hello
print *, "Hello, metapackage_stdlib!"
end subroutine say_hello
end module metapackage_stdlib
fortran-lang-fpm-90bb83a/example_packages/metapackage_stdlib/app/ 0000775 0001750 0001750 00000000000 15145116760 025344 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_stdlib/app/main.f90 0000664 0001750 0001750 00000001163 15145116760 026611 0 ustar alastair alastair ! fortran-lang stdlib test case
! This test program will only run if stdlib is properly built and linked to this project.
program test_stdlib_metapackage
! These USEs would not be possible if stdlib is not found
use stdlib_kinds, only: int32, int64, dp, sp
use stdlib_math
implicit none
real(dp), allocatable :: indices(:)
indices = linspace(1.0_dp,5.0_dp,5)
if (.not.allocated(indices)) then
stop 1
elseif (size(indices)/=5) then
stop 2
elseif (any(nint(indices)/=[1,2,3,4,5])) then
stop 3
else
stop 0
endif
end program test_stdlib_metapackage
fortran-lang-fpm-90bb83a/example_packages/hello_complex/ 0000775 0001750 0001750 00000000000 15145116760 023613 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex/fpm.toml 0000664 0001750 0001750 00000000577 15145116760 025303 0 ustar alastair alastair name = "hello_complex"
[library]
source-dir="source"
[[executable]]
name="say_Hello"
source-dir="apps/say_hello"
main="say_Hello.f90"
[[executable]]
name="say_goodbye"
source-dir="apps/say_goodbye"
main="say_goodbye.f90"
[[test]]
name="greet_test"
source-dir="tests/greet"
main="greet_test.f90"
[[test]]
name="farewell_test"
source-dir="tests/farewell"
main="farewell_test.f90"
fortran-lang-fpm-90bb83a/example_packages/hello_complex/tests/ 0000775 0001750 0001750 00000000000 15145116760 024755 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex/tests/farewell/ 0000775 0001750 0001750 00000000000 15145116760 026556 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex/tests/farewell/farewell_test.f90 0000664 0001750 0001750 00000000706 15145116760 031741 0 ustar alastair alastair program farewell_test
use farewell_m, only: make_farewell
use iso_fortran_env, only: error_unit, output_unit
implicit none
character(len=:), allocatable :: farewell
allocate(character(len=0) :: farewell)
farewell = make_farewell("World")
if (farewell == "Goodbye, World!") then
write(output_unit, *) "Passed"
else
write(error_unit, *) "Failed"
call exit(1)
end if
end program farewell_test
fortran-lang-fpm-90bb83a/example_packages/hello_complex/tests/greet/ 0000775 0001750 0001750 00000000000 15145116760 026063 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex/tests/greet/greet_test.f90 0000664 0001750 0001750 00000000673 15145116760 030556 0 ustar alastair alastair program greet_test
use greet_m, only: make_greeting
use iso_fortran_env, only: error_unit, output_unit
implicit none
character(len=:), allocatable :: greeting
allocate(character(len=0) :: greeting)
greeting = make_greeting("World")
if (greeting == "Hello, World!") then
write(output_unit, *) "Passed"
else
write(error_unit, *) "Failed"
call exit(1)
end if
end program greet_test
fortran-lang-fpm-90bb83a/example_packages/hello_complex/.gitignore 0000664 0001750 0001750 00000000010 15145116760 025572 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/hello_complex/apps/ 0000775 0001750 0001750 00000000000 15145116760 024556 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex/apps/say_goodbye/ 0000775 0001750 0001750 00000000000 15145116760 027062 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex/apps/say_goodbye/say_goodbye.f90 0000664 0001750 0001750 00000000214 15145116760 031703 0 ustar alastair alastair program say_goodbye
use farewell_m, only: make_farewell
implicit none
print *, make_farewell("World")
end program say_goodbye
fortran-lang-fpm-90bb83a/example_packages/hello_complex/apps/say_hello/ 0000775 0001750 0001750 00000000000 15145116760 026535 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex/apps/say_hello/say_Hello.f90 0000664 0001750 0001750 00000000205 15145116760 030771 0 ustar alastair alastair program say_Hello
use greet_m, only: make_greeting
implicit none
print *, make_greeting("World")
end program say_Hello
fortran-lang-fpm-90bb83a/example_packages/hello_complex/source/ 0000775 0001750 0001750 00000000000 15145116760 025113 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex/source/subdir/ 0000775 0001750 0001750 00000000000 15145116760 026403 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_complex/source/subdir/constants.f90 0000664 0001750 0001750 00000000253 15145116760 030737 0 ustar alastair alastair module subdir_constants
implicit none
character(*), parameter :: GREET_STR = 'Hello, '
character(*), parameter :: FAREWELL_STR = 'Goodbye, '
end module subdir_constants
fortran-lang-fpm-90bb83a/example_packages/hello_complex/source/greet_m.f90 0000664 0001750 0001750 00000000555 15145116760 027062 0 ustar alastair alastair module greet_m
use subdir_constants, only: GREET_STR
implicit none
private
public :: make_greeting
contains
function make_greeting(name) result(greeting)
character(len=*), intent(in) :: name
character(len=:), allocatable :: greeting
greeting = GREET_STR // name // "!"
end function make_greeting
end module greet_m
fortran-lang-fpm-90bb83a/example_packages/hello_complex/source/farewell_m.f90 0000664 0001750 0001750 00000000571 15145116760 027553 0 ustar alastair alastair module farewell_m
use subdir_constants, only: FAREWELL_STR
implicit none
private
public :: make_farewell
contains
function make_farewell(name) result(greeting)
character(len=*), intent(in) :: name
character(len=:), allocatable :: greeting
greeting = FAREWELL_STR // name // "!"
end function make_farewell
end module farewell_m
fortran-lang-fpm-90bb83a/example_packages/free-form/ 0000775 0001750 0001750 00000000000 15145116760 022643 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/free-form/fpm.toml 0000664 0001750 0001750 00000000141 15145116760 024316 0 ustar alastair alastair name = "free-form"
fortran.source-form = "free"
executable = [{main="main.f", name="free-form"}]
fortran-lang-fpm-90bb83a/example_packages/free-form/src/ 0000775 0001750 0001750 00000000000 15145116760 023432 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/free-form/src/lib.f 0000664 0001750 0001750 00000000141 15145116760 024343 0 ustar alastair alastair module lib
contains
subroutine hello
print '(a)', "Hello, free world!"
end subroutine
end module
fortran-lang-fpm-90bb83a/example_packages/free-form/app/ 0000775 0001750 0001750 00000000000 15145116760 023423 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/free-form/app/main.f 0000664 0001750 0001750 00000000044 15145116760 024514 0 ustar alastair alastair program test
use lib
call hello
end
fortran-lang-fpm-90bb83a/example_packages/c_includes/ 0000775 0001750 0001750 00000000000 15145116760 023071 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/c_includes/fpm.toml 0000664 0001750 0001750 00000000121 15145116760 024542 0 ustar alastair alastair name = "c_includes"
[dependencies]
c_header_only = { path = "../c_header_only"}
fortran-lang-fpm-90bb83a/example_packages/c_includes/include/ 0000775 0001750 0001750 00000000000 15145116760 024514 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/c_includes/include/lib.h 0000664 0001750 0001750 00000000131 15145116760 025426 0 ustar alastair alastair // Include from "c_header_only" dependency
#include "c_header.h"
int test(const int a);
fortran-lang-fpm-90bb83a/example_packages/c_includes/src/ 0000775 0001750 0001750 00000000000 15145116760 023660 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/c_includes/src/lib.c 0000664 0001750 0001750 00000000117 15145116760 024571 0 ustar alastair alastair #include "lib.h"
int test(const int a){
return printf("input: %d\n", a);
} fortran-lang-fpm-90bb83a/example_packages/c_includes/.gitignore 0000664 0001750 0001750 00000000010 15145116760 025050 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/README.md 0000664 0001750 0001750 00000011104 15145116760 022235 0 ustar alastair alastair # Example packages
See the table below for a list of the example packages provided in this directory including
the features demonstrated in each package and which versions of fpm are supported.
| Name | Features | Bootstrap (Haskell) fpm | fpm |
| --------------------------- | ------------------------------------------------------------- | :---------------------: | :-: |
| app_with_c | C files located in app directory (not src) | N | Y |
| app_with_submodule | Submodules located in app directory (not src) | N | Y |
| auto_discovery_off | Default layout with auto-discovery disabled | N | Y |
| c_header_only | C header-only library | N | Y |
| c_includes | C library with c include directory and dependency includes | N | Y |
| circular_example | Local path dependency; circular dependency | Y | Y |
| circular_test | Local path dependency; circular dependency | Y | Y |
| c_main | C App | N | Y |
| c_main_preprocess | C App; propagate command line preprocessor macros to the app | N | Y |
| cpp_files | C++ files get compiled using fpm | N | Y |
| fortran_includes | Fortran library with explicit include directory | Y | N |
| fpm_test_exe_issues | Test parse order of module files and apps | N | Y |
| hello_complex | Non-standard directory layout; multiple tests and executables | Y | Y |
| hello_complex_2 | Auto-discovery of tests and executables with modules | N | Y |
| hello_fpm | App-only; local path dependency | Y | Y |
| hello_fpm_path | Define local path dependencies | N | Y |
| hello_world | App-only | Y | Y |
| link_executable | Link external library to a single executable | N | Y |
| link_external | Link external library | N | Y |
| makefile_complex | External build command (makefile); local path dependency | Y | N |
| preprocess_cpp | Lib only; C preprocessing; Macro parsing | N | Y |
| preprocess_cpp_c | C App; progate macros from fpm.toml to app | N | Y |
| preprocess_cpp_deps | App; cpp preprocessor settings in local path dependency only | N | Y |
| preprocess_hello | App only; Macros remain local to the package | N | Y |
| preprocess_hello_dependency | Lib only; Macros not getting passed here from root | N | Y |
| program_with_module | App-only; module+program in single source file | Y | Y |
| submodules | Lib-only; submodules (3 levels) | N | Y |
| submodule_tree_shake | Test tree-shaking/pruning with submodules dependencies | N | Y |
| tree_shake | Test tree-shaking/pruning of unused module dependencies | N | Y |
| version_file | Read version number from a file in the project root | N | Y |
| with_c | Compile with `c` source files | N | Y |
| with_examples | Example-only | Y | Y |
| with_makefile | External build command (makefile) | Y | N |
fortran-lang-fpm-90bb83a/example_packages/implicit-external/ 0000775 0001750 0001750 00000000000 15145116760 024413 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/implicit-external/fpm.toml 0000664 0001750 0001750 00000000074 15145116760 026073 0 ustar alastair alastair name = "implicit-external"
fortran.implicit-external = true
fortran-lang-fpm-90bb83a/example_packages/implicit-external/src/ 0000775 0001750 0001750 00000000000 15145116760 025202 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/implicit-external/src/impl.f90 0000664 0001750 0001750 00000000104 15145116760 026456 0 ustar alastair alastair subroutine impl(ijk)
integer :: ijk
ijk = 1
end subroutine impl
fortran-lang-fpm-90bb83a/example_packages/implicit-external/app/ 0000775 0001750 0001750 00000000000 15145116760 025173 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/implicit-external/app/main.f90 0000664 0001750 0001750 00000000133 15145116760 026434 0 ustar alastair alastair program test
integer :: ijk
call impl(ijk)
if (ijk /= 1) error stop
end program test
fortran-lang-fpm-90bb83a/example_packages/both_lib_types/ 0000775 0001750 0001750 00000000000 15145116760 023767 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/both_lib_types/fpm.toml 0000664 0001750 0001750 00000000117 15145116760 025445 0 ustar alastair alastair name = "both_lib_types"
library.type=["shared", "static"]
install.library=true
fortran-lang-fpm-90bb83a/example_packages/both_lib_types/src/ 0000775 0001750 0001750 00000000000 15145116760 024556 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/both_lib_types/src/both_lib_types.f90 0000664 0001750 0001750 00000000456 15145116760 030111 0 ustar alastair alastair module both_lib_types
implicit none
private
public :: say_hello
public :: get_number
contains
subroutine say_hello
print *, "Hello from both_lib_types!"
end subroutine say_hello
integer function get_number()
get_number = 42
end function get_number
end module both_lib_types fortran-lang-fpm-90bb83a/example_packages/circular_example/ 0000775 0001750 0001750 00000000000 15145116760 024300 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/circular_example/fpm.toml 0000664 0001750 0001750 00000000134 15145116760 025755 0 ustar alastair alastair name = "circular_example"
[dev-dependencies]
circular_test = { path = "../circular_test" }
fortran-lang-fpm-90bb83a/example_packages/circular_example/test/ 0000775 0001750 0001750 00000000000 15145116760 025257 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/circular_example/test/main.f90 0000664 0001750 0001750 00000000161 15145116760 026521 0 ustar alastair alastair program run_tests
use hello_test, only: run_test
implicit none
call run_test
end program run_tests
fortran-lang-fpm-90bb83a/example_packages/circular_example/src/ 0000775 0001750 0001750 00000000000 15145116760 025067 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/circular_example/src/greet_m.f90 0000664 0001750 0001750 00000000503 15145116760 027027 0 ustar alastair alastair module greet_m
implicit none
private
public :: make_greeting
contains
function make_greeting(name) result(greeting)
character(len=*), intent(in) :: name
character(len=:), allocatable :: greeting
greeting = "Hello, " // name // "!"
end function make_greeting
end module greet_m
fortran-lang-fpm-90bb83a/example_packages/circular_example/.gitignore 0000664 0001750 0001750 00000000010 15145116760 026257 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/features_per_compiler/ 0000775 0001750 0001750 00000000000 15145116760 025337 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/features_per_compiler/fpm.toml 0000664 0001750 0001750 00000003771 15145116760 027026 0 ustar alastair alastair name = "features_per_compiler"
version = "0.1.0"
license = "MIT"
author = "Federico Perini"
maintainer = "federico.perini@gmail.com"
copyright = "Copyright 2025, Federico Perini"
description = "Demo package showcasing features with per-compiler flags and introspection"
[build]
auto-executables=false
[[executable]]
name = "features_per_compiler"
source-dir = "app"
main = "main.f90"
[profiles]
# Development profile with debugging flags
development = ["debug", "verbose"]
# Production profile with optimization flags
production = ["release", "fast"]
# Testing profile with strict checking
testing = ["debug", "strict"]
[features]
# Debug feature with base flags for all compilers, then per-compiler extensions
debug.flags = "-g" # Base debug flag for ALL compilers (applied first)
debug.gfortran.flags = "-Wall -Wextra -fcheck=bounds,do,mem,pointer -fbacktrace"
debug.ifort.flags = "-warn all -check bounds -traceback" # Unix/Linux/macOS Intel
debug.ifx.flags = "-warn all -check bounds -traceback" # Intel oneAPI
debug.preprocess.cpp.macros = "DEBUG"
# Release feature with base optimization, then per-compiler extensions
release.flags = "-O3" # Base optimization for ALL compilers (applied first)
release.gfortran.flags = "-mtune=generic -funroll-loops"
release.ifort.flags = "-unroll" # Unix/Linux/macOS Intel
release.ifx.flags = "-unroll" # Intel oneAPI
# Verbose feature for enhanced diagnostics (applies to all compilers)
verbose.flags = "-v"
# Fast feature with base optimization, then per-compiler extensions
fast.flags = "-O3" # Base fast optimization for ALL compilers (applied first)
fast.gfortran.flags = "-Ofast -ffast-math"
fast.ifort.flags = "-fp-model fast"
fast.ifx.flags = "-fp-model fast"
# Strict feature with base standard compliance, then per-compiler extensions
strict.flags = "-std=f2018" # Base standard compliance for ALL compilers (applied first)
strict.gfortran.flags = "-Wpedantic -Werror"
strict.ifort.flags = "-stand f18 -warn errors"
strict.ifx.flags = "-stand f18 -warn errors"
fortran-lang-fpm-90bb83a/example_packages/features_per_compiler/.gitignore 0000664 0001750 0001750 00000000013 15145116760 027321 0 ustar alastair alastair output.txt
fortran-lang-fpm-90bb83a/example_packages/features_per_compiler/app/ 0000775 0001750 0001750 00000000000 15145116760 026117 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/features_per_compiler/app/main.f90 0000664 0001750 0001750 00000017507 15145116760 027375 0 ustar alastair alastair program main
use iso_fortran_env, only: compiler_options
implicit none
character(len=:), allocatable :: options_str,detected_compiler
logical :: debug_active, release_active, verbose_active, fast_active, strict_active
logical :: all_checks_passed
integer :: failed_checks
! Get compiler flags used to build this file
allocate(options_str, source=compiler_options())
! Display compiler information
print '(a)', '================================='
print '(a)', 'Features Per Compiler Demo'
print '(a)', '================================='
print '(a)', ''
! Detect compiler type using the function
allocate(detected_compiler, source=compiled_with())
print '(2a)', 'Detected compiler: ', detected_compiler
print '(a)', ''
print '(2a)', 'Compiler options: ', trim(options_str)
print '(a)', ''
! Check for feature flags
debug_active = index(options_str, ' -g ') > 0
release_active = index(options_str, '-O3') > 0
verbose_active = index(options_str, ' -v') > 0 .or. index(options_str, ' -v ') > 0
fast_active = index(options_str, 'fast') > 0
strict_active = index(options_str, '-std=f2018') > 0 .or. index(options_str, '-stand f18') > 0
! Display active features
print '(a)', 'Active features detected:'
if (debug_active) print '(a)', ' ✓ DEBUG: debug flags found'
if (release_active) print '(a)', ' ✓ RELEASE: -O flags found'
if (verbose_active) print '(a)', ' ✓ VERBOSE: -v flag found'
if (fast_active) print '(a)', ' ✓ FAST: fast optimization flags found'
if (strict_active) print '(a)', ' ✓ STRICT: standard compliance flags found'
print '(a)', ''
! Check compiler-specific flags and validate
failed_checks = check_compiler_flags(detected_compiler, options_str, debug_active, release_active, fast_active, strict_active)
print '(a)', ''
! Determine overall result
all_checks_passed = (failed_checks == 0)
if (all_checks_passed) then
print '(a)', '✓ All compiler flag checks PASSED'
print '(a)', ''
else
print '(a,i0,a)', '✗ ', failed_checks, ' compiler flag checks FAILED'
print '(a)', ''
end if
! Exit with appropriate code
stop merge(0,1,all_checks_passed)
contains
function check_compiler_flags(compiler, options, debug_on, release_on, fast_on, strict_on) result(failed_count)
character(len=*), intent(in) :: compiler, options
logical, intent(in) :: debug_on, release_on, fast_on, strict_on
integer :: failed_count
failed_count = 0
select case (compiler)
case ('gfortran')
failed_count = check_gfortran_flags(options, debug_on, release_on, fast_on, strict_on)
case ('ifort')
failed_count = check_ifort_flags(options, debug_on, release_on, fast_on, strict_on)
case ('ifx')
failed_count = check_ifx_flags(options, debug_on, release_on, fast_on, strict_on)
case default
print '(a)', 'Compiler-specific checks: Unknown compiler - only base flags checked'
end select
end function
function check_flag(options, flag_name, feature_name, description) result(found)
character(len=*), intent(in) :: options, flag_name, feature_name, description
logical :: found
found = index(options, flag_name) > 0
if (found) then
print '(a,a,a,a,a)', ' ✓ ', feature_name, ': ', description, ' found'
else
print '(a,a,a,a,a)', ' ✗ ', feature_name, ': ', description, ' NOT found'
end if
end function
function compiled_with() result(msg)
use iso_fortran_env, only: compiler_version
character(len=:), allocatable :: msg
character(len=:), allocatable :: version_str
allocate(version_str, source=compiler_version())
if (index(version_str, 'GCC') > 0) then
msg = 'gfortran'
else if (index(version_str, 'Classic') > 0) then
msg = 'ifort'
else if (index(version_str, 'Intel') > 0) then
msg = 'ifx'
else
msg = 'any'
end if
end function
function check_gfortran_flags(options, debug_on, release_on, fast_on, strict_on) result(failed_count)
character(len=*), intent(in) :: options
logical, intent(in) :: debug_on, release_on, fast_on, strict_on
integer :: failed_count
failed_count = 0
print '(a)', 'Compiler-specific flag checks (gfortran):'
if (debug_on) then
if (.not. check_flag(options, '-Wall', 'Debug', '-Wall')) failed_count = failed_count + 1
if (.not. check_flag(options, '-Wextra', 'Debug', '-Wextra')) failed_count = failed_count + 1
if (.not. check_flag(options, '-fcheck=bounds', 'Debug', '-fcheck=bounds')) failed_count = failed_count + 1
if (.not. check_flag(options, '-fbacktrace', 'Debug', '-fbacktrace')) failed_count = failed_count + 1
end if
if (release_on) then
! Check for -mtune flag (portable tuning flag that works on all platforms)
if (.not. check_flag(options, '-mtune', 'Release', '-mtune')) failed_count = failed_count + 1
if (.not. check_flag(options, '-funroll-loops', 'Release', '-funroll-loops')) failed_count = failed_count + 1
end if
if (fast_on) then
if (.not. check_flag(options, '-ffast', 'Fast', '-fast')) failed_count = failed_count + 1
if (.not. check_flag(options, '-ffast-math', 'Fast', '-ffast-math')) failed_count = failed_count + 1
end if
if (strict_on) then
if (.not. check_flag(options, '-Wpedantic', 'Strict', '-Wpedantic')) failed_count = failed_count + 1
if (.not. check_flag(options, '-Werror', 'Strict', '-Werror')) failed_count = failed_count + 1
end if
end function
function check_ifort_flags(options, debug_on, release_on, fast_on, strict_on) result(failed_count)
character(len=*), intent(in) :: options
logical, intent(in) :: debug_on, release_on, fast_on, strict_on
integer :: failed_count
failed_count = 0
print '(a)', 'Compiler-specific flag checks (ifort):'
if (debug_on) then
if (.not. check_flag(options, '-warn all', 'Debug', '-warn all')) failed_count = failed_count + 1
if (.not. check_flag(options, '-check bounds', 'Debug', '-check bounds')) failed_count = failed_count + 1
if (.not. check_flag(options, '-traceback', 'Debug', '-traceback')) failed_count = failed_count + 1
end if
if (release_on) then
if (.not. check_flag(options, '-unroll', 'Release', '-unroll')) failed_count = failed_count + 1
end if
if (fast_on) then
if (.not. check_flag(options, '-fp-model', 'Fast', 'fast')) failed_count = failed_count + 1
end if
if (strict_on) then
if (.not. check_flag(options, '-stand f18', 'Strict', '-stand f18')) failed_count = failed_count + 1
if (.not. check_flag(options, '-warn errors', 'Strict', '-warn errors')) failed_count = failed_count + 1
end if
end function
function check_ifx_flags(options, debug_on, release_on, fast_on, strict_on) result(failed_count)
character(len=*), intent(in) :: options
logical, intent(in) :: debug_on, release_on, fast_on, strict_on
integer :: failed_count
failed_count = 0
print '(a)', 'Compiler-specific flag checks (ifx):'
if (debug_on) then
if (.not. check_flag(options, '-warn all', 'Debug', '-warn all')) failed_count = failed_count + 1
if (.not. check_flag(options, '-check bounds', 'Debug', '-check bounds')) failed_count = failed_count + 1
if (.not. check_flag(options, '-traceback', 'Debug', '-traceback')) failed_count = failed_count + 1
end if
if (release_on) then
if (.not. check_flag(options, '-unroll', 'Release', '-unroll')) failed_count = failed_count + 1
end if
if (fast_on) then
if (.not. check_flag(options, '-fp-model', 'Fast', 'fast')) failed_count = failed_count + 1
end if
if (strict_on) then
if (.not. check_flag(options, '-stand f18', 'Strict', '-stand f18')) failed_count = failed_count + 1
if (.not. check_flag(options, '-warn errors', 'Strict', '-warn errors')) failed_count = failed_count + 1
end if
end function
end program main
fortran-lang-fpm-90bb83a/example_packages/version_file/ 0000775 0001750 0001750 00000000000 15145116760 023445 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/version_file/fpm.toml 0000664 0001750 0001750 00000000052 15145116760 025121 0 ustar alastair alastair name = "version_file"
version = "VERSION"
fortran-lang-fpm-90bb83a/example_packages/version_file/VERSION 0000664 0001750 0001750 00000000007 15145116760 024512 0 ustar alastair alastair 5.42.1
fortran-lang-fpm-90bb83a/example_packages/version_file/app/ 0000775 0001750 0001750 00000000000 15145116760 024225 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/version_file/app/main.f90 0000664 0001750 0001750 00000000540 15145116760 025470 0 ustar alastair alastair program stub
implicit none
logical :: exists
integer :: unit
character(len=100) :: line
inquire(file="VERSION", exist=exists)
if (.not.exists) error stop "File VERSION does not exist."
open(file="VERSION", newunit=unit)
read(unit, '(a)') line
close(unit)
print '(*(a))', "File VERSION contains '", trim(line), "'"
end program stub
fortran-lang-fpm-90bb83a/example_packages/with_makefile/ 0000775 0001750 0001750 00000000000 15145116760 023571 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/with_makefile/fpm.toml 0000664 0001750 0001750 00000000117 15145116760 025247 0 ustar alastair alastair name = "with_makefile"
[library]
source-dir = "src"
build-script = "Makefile"
fortran-lang-fpm-90bb83a/example_packages/with_makefile/src/ 0000775 0001750 0001750 00000000000 15145116760 024360 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/with_makefile/src/hello_makefile.f90 0000664 0001750 0001750 00000000402 15145116760 027634 0 ustar alastair alastair module hello_makefile
implicit none
private
public :: say_hello_from_makefile
contains
subroutine say_hello_from_makefile()
print *, "Hello from Makefile library!"
end subroutine say_hello_from_makefile
end module hello_makefile
fortran-lang-fpm-90bb83a/example_packages/with_makefile/.gitignore 0000664 0001750 0001750 00000000010 15145116760 025550 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/with_makefile/Makefile 0000664 0001750 0001750 00000000462 15145116760 025233 0 ustar alastair alastair INCLUDE_FLAGS = $(addprefix -I,$(INCLUDE_DIRS))
$(BUILD_DIR)/libwith_makefile.a: $(BUILD_DIR)/hello_makefile.o
ar rs $(@) $(^)
$(BUILD_DIR)/hello_makefile.mod: src/hello_makefile.f90
$(BUILD_DIR)/hello_makefile.o: src/hello_makefile.f90
$(FC) -c -J$(BUILD_DIR) $(INCLUDE_FLAGS) $(FFLAGS) -o $(@) $(<)
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp/ 0000775 0001750 0001750 00000000000 15145116760 024010 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp/fpm.toml 0000664 0001750 0001750 00000000205 15145116760 025464 0 ustar alastair alastair name = "preprocess_cpp"
version = "1"
[preprocess]
[preprocess.cpp]
macros = ["TESTMACRO", "TESTMACRO2=3", "TESTMACRO3={version}"]
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp/src/ 0000775 0001750 0001750 00000000000 15145116760 024577 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp/src/preprocess_cpp.f90 0000664 0001750 0001750 00000000562 15145116760 030151 0 ustar alastair alastair module preprocess_cpp
implicit none
private
public :: say_hello
contains
subroutine say_hello
print *, "Hello, preprocess_cpp!"
#ifndef TESTMACRO
This breaks the build.
#endif
#if TESTMACRO2 != 3
This breaks the build.
#endif
#if TESTMACRO3 != 1
This breaks the build.
#endif
end subroutine say_hello
end module preprocess_cpp
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp/.gitignore 0000664 0001750 0001750 00000000010 15145116760 025767 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp/app/ 0000775 0001750 0001750 00000000000 15145116760 024570 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp/app/main.f90 0000664 0001750 0001750 00000000111 15145116760 026025 0 ustar alastair alastair program cpp
use preprocess_cpp
call say_hello()
end program
fortran-lang-fpm-90bb83a/example_packages/many_examples/ 0000775 0001750 0001750 00000000000 15145116760 023623 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/many_examples/fpm.toml 0000664 0001750 0001750 00000000273 15145116760 025304 0 ustar alastair alastair name = "many_examples"
build.auto-examples = false
[[example]]
name = "demo-1"
source-dir = "demo1"
main = "prog.f90"
[[example]]
name = "demo-2"
source-dir = "demo2"
main = "prog.f90"
fortran-lang-fpm-90bb83a/example_packages/many_examples/demo1/ 0000775 0001750 0001750 00000000000 15145116760 024630 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/many_examples/demo1/prog.f90 0000664 0001750 0001750 00000000236 15145116760 026120 0 ustar alastair alastair program demo
integer :: i
open(newunit=i,file="demo1.txt",form="formatted",action="write")
write(i, '(a)') "DEMO1"
close(i)
stop 0
end program demo
fortran-lang-fpm-90bb83a/example_packages/many_examples/demo2/ 0000775 0001750 0001750 00000000000 15145116760 024631 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/many_examples/demo2/prog.f90 0000664 0001750 0001750 00000000236 15145116760 026121 0 ustar alastair alastair program demo
integer :: i
open(newunit=i,file="demo2.txt",form="formatted",action="write")
write(i, '(a)') "DEMO2"
close(i)
stop 0
end program demo
fortran-lang-fpm-90bb83a/example_packages/many_examples/.gitignore 0000664 0001750 0001750 00000000011 15145116760 025603 0 ustar alastair alastair /build/*
fortran-lang-fpm-90bb83a/example_packages/many_examples/app/ 0000775 0001750 0001750 00000000000 15145116760 024403 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/many_examples/app/demo-prog.f90 0000664 0001750 0001750 00000000113 15145116760 026607 0 ustar alastair alastair program demo
write(*, '(a)') "This is a simple program"
end program demo
fortran-lang-fpm-90bb83a/example_packages/metapackage_hdf5/ 0000775 0001750 0001750 00000000000 15145116760 024131 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_hdf5/fpm.toml 0000664 0001750 0001750 00000000060 15145116760 025604 0 ustar alastair alastair name = "metapackage_hdf5"
dependencies.hdf5="*"
fortran-lang-fpm-90bb83a/example_packages/metapackage_hdf5/app/ 0000775 0001750 0001750 00000000000 15145116760 024711 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_hdf5/app/main.f90 0000664 0001750 0001750 00000000321 15145116760 026151 0 ustar alastair alastair program metapackage_hdf5
use hdf5
implicit none
integer :: error
call h5open_f(error)
if (error/=0) stop -1
call h5close_f(error)
if (error/=0) stop -2
stop 0
end program metapackage_hdf5
fortran-lang-fpm-90bb83a/example_packages/metapackage_stdlib_extblas/ 0000775 0001750 0001750 00000000000 15145116760 026306 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_stdlib_extblas/fpm.toml 0000664 0001750 0001750 00000000121 15145116760 027757 0 ustar alastair alastair name = "test_stdlib_ext_blas"
dependencies.blas = "*"
dependencies.stdlib = "*"
fortran-lang-fpm-90bb83a/example_packages/metapackage_stdlib_extblas/app/ 0000775 0001750 0001750 00000000000 15145116760 027066 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_stdlib_extblas/app/main.f90 0000664 0001750 0001750 00000001101 15145116760 030323 0 ustar alastair alastair ! fortran-lang stdlib + external BLAS test case
! Program will fail if an external BLAS has not been linked against.
program test_stdlib_metapackage
use stdlib_linalg_constants, only: external_blas_ilp32,external_lapack_ilp32, &
external_blas_ilp64,external_lapack_ilp64
implicit none
if (.not.(external_blas_ilp32 .or. external_blas_ilp64)) then
stop 1
elseif (.not.(external_lapack_ilp32 .or. external_lapack_ilp64)) then
stop 2
else
stop 0
end if
end program test_stdlib_metapackage
fortran-lang-fpm-90bb83a/example_packages/features_with_dependency/ 0000775 0001750 0001750 00000000000 15145116760 026030 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/features_with_dependency/fpm.toml 0000664 0001750 0001750 00000004037 15145116760 027513 0 ustar alastair alastair name = "features_with_dependency"
version = "0.1.0"
license = "MIT"
description = "Demo package testing dependency features"
[[executable]]
name = "features_with_dependency"
source-dir = "app"
main = "main.f90"
[dependencies]
# Base dependencies (none for this demo - features will add them)
[features]
# Feature that enables debug mode in the dependency
with_feat_debug.dependencies.features_demo = { path = "../features_demo", features = ["debug"] }
with_feat_debug.preprocess.cpp.macros = ["WITH_DEMO","WITH_DEBUG_DEPENDENCY"]
# Feature that enables release mode in the dependency
with_feat_release.dependencies.features_demo = { path = "../features_demo", features = ["release"] }
with_feat_release.preprocess.cpp.macros = ["WITH_DEMO","WITH_RELEASE_DEPENDENCY"]
# Feature that enables multiple dependency features
with_feat_multi.dependencies.features_demo = { path = "../features_demo", features = ["debug", "mpi"] }
with_feat_multi.preprocess.cpp.macros = ["WITH_DEMO","WITH_MULTI_DEPENDENCY"]
# Feature for platform-specific dependency features
linux_specific.linux.dependencies.features_demo = { path = "../features_demo", features = ["linux"] }
linux_specific.preprocess.cpp.macros = ["WITH_DEMO","LINUX_FEATURES"]
# Feature combining compiler and dependency features
gfortran_optimized.gfortran.dependencies.features_demo = { path = "../features_demo", features = ["release", "gfortran"] }
gfortran_optimized.gfortran.flags = "-O3 -mtune=generic -funroll-loops"
gfortran_optimized.preprocess.cpp.macros = ["WITH_DEMO"]
# Feature that uses a profile name (instead of features list) to build the dependency
# "prof_feats" profile in features_demo resolves to ["prof_feat1", "prof_feat2"],
# which sets the PROF_FEAT1 and PROF_FEAT2 macros
with_dep_profile.dependencies.features_demo = { path = "../features_demo", profile = "prof_feats" }
with_dep_profile.preprocess.cpp.macros = ["WITH_DEMO"]
[profiles]
debug_dep = ["with_feat_debug"]
release_dep = ["with_feat_release"]
full_test = ["with_feat_multi", "linux_specific"]
dep_profile = ["with_dep_profile"]
fortran-lang-fpm-90bb83a/example_packages/features_with_dependency/src/ 0000775 0001750 0001750 00000000000 15145116760 026617 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/features_with_dependency/src/features_with_dependency.f90 0000664 0001750 0001750 00000002503 15145116760 034206 0 ustar alastair alastair module features_with_dependency
#ifdef WITH_DEMO
use features_demo, only: show_demo_features => show_features
#endif
implicit none
private
public :: show_features
contains
subroutine show_features()
print *, "Local package features:"
#ifdef WITH_DEBUG_DEPENDENCY
print *, "✓ WITH_DEBUG_DEPENDENCY - dependency built with debug features"
#endif
#ifdef WITH_RELEASE_DEPENDENCY
print *, "✓ WITH_RELEASE_DEPENDENCY - dependency built with release features"
#endif
#ifdef WITH_MULTI_DEPENDENCY
print *, "✓ WITH_MULTI_DEPENDENCY - dependency built with debug+mpi features"
#endif
#ifdef LINUX_FEATURES
print *, "✓ LINUX_FEATURES - Linux-specific dependency features"
#endif
! If no local features are active
#if !defined(WITH_DEBUG_DEPENDENCY) && !defined(WITH_RELEASE_DEPENDENCY) && !defined(WITH_MULTI_DEPENDENCY) && !defined(LINUX_FEATURES)
print *, " NONE - no local features active"
#endif
print *, ""
#ifdef WITH_DEMO
print *, "Dependency (features_demo) status:"
call show_demo_features() ! Call features_demo's show_features
#else
print *, "Dependency (features_demo) is not attached"
#endif
end subroutine show_features
end module features_with_dependency
fortran-lang-fpm-90bb83a/example_packages/features_with_dependency/app/ 0000775 0001750 0001750 00000000000 15145116760 026610 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/features_with_dependency/app/main.f90 0000664 0001750 0001750 00000000540 15145116760 030053 0 ustar alastair alastair program features_with_dependency_demo
use features_with_dependency, only: show_features
implicit none
print *, "=== Features with Dependency Demo ==="
print *, ""
call show_features()
print *, ""
print *, "This demonstrates feature propagation to dependencies."
end program features_with_dependency_demo
fortran-lang-fpm-90bb83a/example_packages/preprocess_hello/ 0000775 0001750 0001750 00000000000 15145116760 024331 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_hello/fpm.toml 0000664 0001750 0001750 00000000243 15145116760 026007 0 ustar alastair alastair name = "preprocess_hello"
[preprocess]
[preprocess.cpp]
macros = ["FOO"]
[dependencies]
preprocess_hello_dependency = { path = "../preprocess_hello_dependency" } fortran-lang-fpm-90bb83a/example_packages/preprocess_hello/README.md 0000664 0001750 0001750 00000000050 15145116760 025603 0 ustar alastair alastair # preprocess_hello
My cool new project!
fortran-lang-fpm-90bb83a/example_packages/preprocess_hello/app/ 0000775 0001750 0001750 00000000000 15145116760 025111 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_hello/app/main.f90 0000664 0001750 0001750 00000000223 15145116760 026352 0 ustar alastair alastair program preprocess_hello
use preprocess_hello_dependency, only: say_hello
implicit none
call say_hello()
end program preprocess_hello
fortran-lang-fpm-90bb83a/example_packages/app_with_submodule/ 0000775 0001750 0001750 00000000000 15145116760 024653 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/app_with_submodule/fpm.toml 0000664 0001750 0001750 00000000033 15145116760 026326 0 ustar alastair alastair name = "app_with_submodule" fortran-lang-fpm-90bb83a/example_packages/app_with_submodule/src/ 0000775 0001750 0001750 00000000000 15145116760 025442 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/app_with_submodule/src/parent.f90 0000664 0001750 0001750 00000000246 15145116760 027255 0 ustar alastair alastair module parent
implicit none
interface
module subroutine my_sub1(a)
integer, intent(out) :: a
end subroutine my_sub1
end interface
end module parent fortran-lang-fpm-90bb83a/example_packages/app_with_submodule/.gitignore 0000664 0001750 0001750 00000000010 15145116760 026632 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/app_with_submodule/app/ 0000775 0001750 0001750 00000000000 15145116760 025433 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/app_with_submodule/app/app1/ 0000775 0001750 0001750 00000000000 15145116760 026274 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/app_with_submodule/app/app1/main1.f90 0000664 0001750 0001750 00000000251 15145116760 027617 0 ustar alastair alastair program test
use parent
implicit none
integer :: a
call my_sub1(a)
if (a /= 1) then
write(*,*) 'FAILED: Unexpected value of a'
stop 1
end if
end program test fortran-lang-fpm-90bb83a/example_packages/app_with_submodule/app/app1/child1.f90 0000664 0001750 0001750 00000000365 15145116760 027764 0 ustar alastair alastair submodule(parent) child1
implicit none
interface
module function my_fun() result (b)
integer :: b
end function my_fun
end interface
contains
module procedure my_sub1
a = my_fun()
end procedure my_sub1
end submodule child1 fortran-lang-fpm-90bb83a/example_packages/app_with_submodule/app/app1/grandchild.f90 0000664 0001750 0001750 00000000215 15145116760 030711 0 ustar alastair alastair submodule(parent:child1) grandchild
implicit none
contains
module procedure my_fun
b = 1
end procedure my_fun
end submodule grandchild fortran-lang-fpm-90bb83a/example_packages/app_with_submodule/app/app2/ 0000775 0001750 0001750 00000000000 15145116760 026275 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/app_with_submodule/app/app2/child2.f90 0000664 0001750 0001750 00000000200 15145116760 027752 0 ustar alastair alastair submodule(parent) child2
implicit none
contains
module procedure my_sub1
a = 2
end procedure my_sub1
end submodule child2 fortran-lang-fpm-90bb83a/example_packages/app_with_submodule/app/app2/main2.f90 0000664 0001750 0001750 00000000251 15145116760 027621 0 ustar alastair alastair program test
use parent
implicit none
integer :: a
call my_sub1(a)
if (a /= 2) then
write(*,*) 'FAILED: Unexpected value of a'
stop 1
end if
end program test fortran-lang-fpm-90bb83a/example_packages/c_header_only/ 0000775 0001750 0001750 00000000000 15145116760 023554 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/c_header_only/fpm.toml 0000664 0001750 0001750 00000000027 15145116760 025232 0 ustar alastair alastair name = "c_header_only"
fortran-lang-fpm-90bb83a/example_packages/c_header_only/include/ 0000775 0001750 0001750 00000000000 15145116760 025177 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/c_header_only/include/c_header.h 0000664 0001750 0001750 00000000051 15145116760 027076 0 ustar alastair alastair int printf ( const char * format, ... );
fortran-lang-fpm-90bb83a/example_packages/c_header_only/.gitignore 0000664 0001750 0001750 00000000010 15145116760 025533 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/submodules/ 0000775 0001750 0001750 00000000000 15145116760 023143 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/submodules/fpm.toml 0000664 0001750 0001750 00000000024 15145116760 024616 0 ustar alastair alastair name = "submodules"
fortran-lang-fpm-90bb83a/example_packages/submodules/src/ 0000775 0001750 0001750 00000000000 15145116760 023732 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/submodules/src/child2.f90 0000664 0001750 0001750 00000000200 15145116760 025407 0 ustar alastair alastair submodule(parent) child2
implicit none
contains
module procedure my_sub2
a = 2
end procedure my_sub2
end submodule child2 fortran-lang-fpm-90bb83a/example_packages/submodules/src/child1.f90 0000664 0001750 0001750 00000000356 15145116760 025422 0 ustar alastair alastair submodule(parent) child1
implicit none
interface
module function my_fun() result (b)
integer :: b
end function my_fun
end interface
contains
module procedure my_sub1
a = 1
end procedure my_sub1
end submodule child1 fortran-lang-fpm-90bb83a/example_packages/submodules/src/grandchild.f90 0000664 0001750 0001750 00000000215 15145116760 026347 0 ustar alastair alastair submodule(parent:child1) grandchild
implicit none
contains
module procedure my_fun
b = 2
end procedure my_fun
end submodule grandchild fortran-lang-fpm-90bb83a/example_packages/submodules/src/parent.f90 0000664 0001750 0001750 00000000405 15145116760 025542 0 ustar alastair alastair module parent
implicit none
interface
module subroutine my_sub1(a)
integer, intent(out) :: a
end subroutine my_sub1
module subroutine my_sub2(a)
integer, intent(out) :: a
end subroutine my_sub2
end interface
end module parent fortran-lang-fpm-90bb83a/example_packages/submodules/.gitignore 0000664 0001750 0001750 00000000010 15145116760 025122 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/fpm_test_exit_code/ 0000775 0001750 0001750 00000000000 15145116760 024625 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/fpm_test_exit_code/fpm.toml 0000664 0001750 0001750 00000000342 15145116760 026303 0 ustar alastair alastair name = "fpm_test_exit_code"
version = "0.1.0"
license = "license"
author = "Federico Perini"
maintainer = "jane.doe@example.com"
copyright = "Copyright 2023, Jane Doe"
[build]
auto-executables = true
[install]
library = false
fortran-lang-fpm-90bb83a/example_packages/fpm_test_exit_code/README.md 0000664 0001750 0001750 00000000436 15145116760 026107 0 ustar alastair alastair # fpm_test_exit_code
Test program for application exit codes
see https://github.com/fortran-lang/fpm/issues/848
This app expects to receive an integer command line argument, to check whether it is odd or even.
It returns 0 on success (odd input), or among a few error codes otherwise.
fortran-lang-fpm-90bb83a/example_packages/fpm_test_exit_code/app/ 0000775 0001750 0001750 00000000000 15145116760 025405 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/fpm_test_exit_code/app/main.f90 0000664 0001750 0001750 00000002263 15145116760 026654 0 ustar alastair alastair ! Test program for application exit codes
! see https://github.com/fortran-lang/fpm/issues/848
! This app expects to receive an integer command line argument, to check whether it is odd or even.
! It returns 0 on success (odd input), or among a few error codes otherwise.
program check_odd_number
implicit none
integer, parameter :: SUCCESS = 0
integer, parameter :: INVALID_ARGUMENT = 1
integer, parameter :: NOT_AN_INTEGER = 2
integer, parameter :: NOT_ODD = 3
character(len=1024) :: buffer
integer :: ierr,ln,the_number
! If the argument is missing or not an integer, return an error flag
if (command_argument_count()/=1) stop INVALID_ARGUMENT
! Get command argument
call get_command_argument(1,value=buffer,length=ln,status=ierr)
! On invalid string
if (ln<1 .or. ierr/=0) stop INVALID_ARGUMENT
! Read to int
read(buffer(:ln),*,iostat=ierr) the_number
! On invalid integer
if (ierr/=0) stop NOT_AN_INTEGER
! Check if it is odd or even
if (mod(the_number,2)==0) then
! Is even
stop NOT_ODD
else
! Is odd
stop SUCCESS
end if
end program check_odd_number
fortran-lang-fpm-90bb83a/example_packages/features_demo/ 0000775 0001750 0001750 00000000000 15145116760 023603 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/features_demo/fpm.toml 0000664 0001750 0001750 00000001752 15145116760 025267 0 ustar alastair alastair name = "features_demo"
version = "0.1.0"
license = "MIT"
description = "Demo package for FPM features functionality"
[[executable]]
name = "features_demo"
source-dir = "app"
main = "main.f90"
[features]
# Base debug feature
debug.flags = "-g"
debug.preprocess.cpp.macros = "DEBUG"
# Release feature
release.flags = "-O3"
release.preprocess.cpp.macros = "RELEASE"
# Compiler-specific features
debug.gfortran.flags = "-Wall -fcheck=bounds"
release.gfortran.flags = "-mtune=generic -funroll-loops"
# Platform-specific features
linux.preprocess.cpp.macros = "LINUX_BUILD"
# Parallel features
mpi.preprocess.cpp.macros = "USE_MPI"
mpi.dependencies.mpi = "*"
openmp.preprocess.cpp.macros = "USE_OPENMP"
openmp.dependencies.openmp = "*"
# Features for testing dependency profile resolution
prof_feat1.preprocess.cpp.macros = "PROF_FEAT1"
prof_feat2.preprocess.cpp.macros = "PROF_FEAT2"
[profiles]
development = ["debug"]
production = ["release", "openmp"]
prof_feats = ["prof_feat1", "prof_feat2"]
fortran-lang-fpm-90bb83a/example_packages/features_demo/src/ 0000775 0001750 0001750 00000000000 15145116760 024372 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/features_demo/src/features_demo.f90 0000664 0001750 0001750 00000003620 15145116760 027535 0 ustar alastair alastair module features_demo
implicit none
private
public :: show_features, get_build_info
contains
!> Display which features are enabled
subroutine show_features()
write(*,*) 'FPM Features Demo'
write(*,*) '================='
! Debug/Release flags
#ifdef DEBUG
write(*,*) '✓ DEBUG mode enabled'
#endif
#ifdef RELEASE
write(*,*) '✓ RELEASE mode enabled'
#endif
! Platform detection
#ifdef LINUX_BUILD
write(*,*) '✓ Linux platform detected'
#endif
#ifdef WINDOWS_BUILD
write(*,*) '✓ Windows platform detected'
#endif
! Parallel features
#ifdef USE_MPI
write(*,*) '✓ MPI support enabled'
#endif
#ifdef USE_OPENMP
write(*,*) '✓ OpenMP support enabled'
#endif
#ifdef PROF_FEAT1
write(*,*) '✓ PROF_FEAT1 enabled'
#endif
#ifdef PROF_FEAT2
write(*,*) '✓ PROF_FEAT2 enabled'
#endif
! Compiler info (if available)
write(*,*) 'Build configuration:'
call show_compiler_info()
end subroutine show_features
!> Show compiler information
subroutine show_compiler_info()
#ifdef __GFORTRAN__
write(*,*) ' - Compiler: GNU Fortran'
#endif
#ifdef __INTEL_COMPILER
write(*,*) ' - Compiler: Intel Fortran'
#endif
end subroutine show_compiler_info
!> Get build information as a string
function get_build_info() result(info)
character(len=200) :: info
info = 'Features: '
#ifdef DEBUG
info = trim(info) // ' DEBUG'
#endif
#ifdef RELEASE
info = trim(info) // ' RELEASE'
#endif
#ifdef USE_MPI
info = trim(info) // ' MPI'
#endif
#ifdef USE_OPENMP
info = trim(info) // ' OPENMP'
#endif
if (len_trim(info) == 10) then ! Only "Features: "
info = trim(info) // 'NONE'
end if
end function get_build_info
end module features_demo
fortran-lang-fpm-90bb83a/example_packages/features_demo/app/ 0000775 0001750 0001750 00000000000 15145116760 024363 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/features_demo/app/debug_demo.f90 0000664 0001750 0001750 00000000442 15145116760 026775 0 ustar alastair alastair program debug_demo
use features_demo
implicit none
write(*,*) 'Debug Demo Program'
write(*,*) '=================='
#ifdef DEBUG
write(*,*) 'Debug mode: ON'
#else
write(*,*) 'Debug mode: OFF'
#endif
call show_features()
end program debug_demo
fortran-lang-fpm-90bb83a/example_packages/features_demo/app/main.f90 0000664 0001750 0001750 00000000337 15145116760 025632 0 ustar alastair alastair program main
use features_demo
implicit none
call show_features()
write(*,*) ''
write(*,*) get_build_info()
write(*,*) ''
write(*,*) 'Demo completed successfully!'
end program main fortran-lang-fpm-90bb83a/example_packages/fpm_test_exe_issues/ 0000775 0001750 0001750 00000000000 15145116760 025036 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/fpm_test_exe_issues/fpm.toml 0000664 0001750 0001750 00000000354 15145116760 026517 0 ustar alastair alastair # See https://github.com/fortran-lang/fpm/issues/734
name = "fpm-test"
[build]
auto-executables = true
auto-tests = true
auto-examples = true
[install]
library = false
[[executable]]
name = "main"
source-dir = "src"
main = "main.f90" fortran-lang-fpm-90bb83a/example_packages/fpm_test_exe_issues/src/ 0000775 0001750 0001750 00000000000 15145116760 025625 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/fpm_test_exe_issues/src/main.f90 0000664 0001750 0001750 00000000117 15145116760 027070 0 ustar alastair alastair program main
use a_mod
implicit none
call a_mod_sub()
end program
fortran-lang-fpm-90bb83a/example_packages/fpm_test_exe_issues/src/a/ 0000775 0001750 0001750 00000000000 15145116760 026045 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/fpm_test_exe_issues/src/a/a_mod.f90 0000664 0001750 0001750 00000000216 15145116760 027443 0 ustar alastair alastair module a_mod
use b_mod, only: hello_world
contains
subroutine a_mod_sub()
call hello_world()
end subroutine
end module
fortran-lang-fpm-90bb83a/example_packages/fpm_test_exe_issues/src/b_mod.f90 0000664 0001750 0001750 00000000206 15145116760 027223 0 ustar alastair alastair module b_mod
implicit none
contains
subroutine hello_world()
print *, "Hello world!"
end subroutine
end module
fortran-lang-fpm-90bb83a/example_packages/auto_discovery_off/ 0000775 0001750 0001750 00000000000 15145116760 024652 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/auto_discovery_off/fpm.toml 0000664 0001750 0001750 00000000223 15145116760 026326 0 ustar alastair alastair name = "auto_discovery_off"
[build]
auto-executables = false
auto-tests = false
[[test]]
name = "my_test"
source-dir="test"
main="my_test.f90"
fortran-lang-fpm-90bb83a/example_packages/auto_discovery_off/test/ 0000775 0001750 0001750 00000000000 15145116760 025631 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/auto_discovery_off/test/unused_test.f90 0000664 0001750 0001750 00000000145 15145116760 030513 0 ustar alastair alastair program unused_test
implicit none
print *, "This program should NOT run."
end program unused_test
fortran-lang-fpm-90bb83a/example_packages/auto_discovery_off/test/my_test.f90 0000664 0001750 0001750 00000000133 15145116760 027632 0 ustar alastair alastair program my_test
implicit none
print *, "Test passed! That was easy!"
end program my_test
fortran-lang-fpm-90bb83a/example_packages/auto_discovery_off/.gitignore 0000664 0001750 0001750 00000000010 15145116760 026631 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/auto_discovery_off/app/ 0000775 0001750 0001750 00000000000 15145116760 025432 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/auto_discovery_off/app/unused.f90 0000664 0001750 0001750 00000000132 15145116760 027251 0 ustar alastair alastair program unused
implicit none
print *, "This program should NOT run."
end program unused
fortran-lang-fpm-90bb83a/example_packages/auto_discovery_off/app/main.f90 0000664 0001750 0001750 00000000122 15145116760 026671 0 ustar alastair alastair program main
implicit none
print *, "This program should run."
end program main
fortran-lang-fpm-90bb83a/example_packages/circular_test/ 0000775 0001750 0001750 00000000000 15145116760 023624 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/circular_test/fpm.toml 0000664 0001750 0001750 00000000132 15145116760 025277 0 ustar alastair alastair name = "circular_test"
[dependencies]
circular_example = { path = "../circular_example"}
fortran-lang-fpm-90bb83a/example_packages/circular_test/src/ 0000775 0001750 0001750 00000000000 15145116760 024413 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/circular_test/src/hello_test.f90 0000664 0001750 0001750 00000000355 15145116760 027100 0 ustar alastair alastair module hello_test
use greet_m, only: make_greeting
implicit none
private
public :: run_test
contains
subroutine run_test
print *, make_greeting("from test")
end subroutine run_test
end module hello_test
fortran-lang-fpm-90bb83a/example_packages/circular_test/.gitignore 0000664 0001750 0001750 00000000010 15145116760 025603 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/c_main/ 0000775 0001750 0001750 00000000000 15145116760 022207 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/c_main/fpm.toml 0000664 0001750 0001750 00000000100 15145116760 023655 0 ustar alastair alastair name = "c-main"
[[executable]]
name = "c-main"
main = "main.c"
fortran-lang-fpm-90bb83a/example_packages/c_main/app/ 0000775 0001750 0001750 00000000000 15145116760 022767 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/c_main/app/main.c 0000664 0001750 0001750 00000000040 15145116760 024051 0 ustar alastair alastair int
main (void)
{
return 0;
}
fortran-lang-fpm-90bb83a/example_packages/c_main_preprocess/ 0000775 0001750 0001750 00000000000 15145116760 024454 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/c_main_preprocess/fpm.toml 0000664 0001750 0001750 00000000147 15145116760 026135 0 ustar alastair alastair name = "c_main_preprocess"
[library]
include-dir = ["src"]
[[executable]]
name="main-c"
main="main.c"
fortran-lang-fpm-90bb83a/example_packages/c_main_preprocess/src/ 0000775 0001750 0001750 00000000000 15145116760 025243 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/c_main_preprocess/src/val.h 0000664 0001750 0001750 00000000122 15145116760 026171 0 ustar alastair alastair #ifndef _VAL_H_
#define _VAL_H_
#ifdef VAL
const int variable = 1;
#endif
#endif
fortran-lang-fpm-90bb83a/example_packages/c_main_preprocess/src/stub.c 0000664 0001750 0001750 00000000021 15145116760 026355 0 ustar alastair alastair #include "val.h"
fortran-lang-fpm-90bb83a/example_packages/c_main_preprocess/app/ 0000775 0001750 0001750 00000000000 15145116760 025234 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/c_main_preprocess/app/main.c 0000664 0001750 0001750 00000000123 15145116760 026320 0 ustar alastair alastair #include
#include "val.h"
int main() {
printf("%d\n", variable);
}
fortran-lang-fpm-90bb83a/example_packages/shared_lib_extra/ 0000775 0001750 0001750 00000000000 15145116760 024260 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/shared_lib_extra/fpm.toml 0000664 0001750 0001750 00000000147 15145116760 025741 0 ustar alastair alastair name = "shared_lib_extra"
library.type="shared"
[dependencies]
shared_lib = { path = "../shared_lib" }
fortran-lang-fpm-90bb83a/example_packages/shared_lib_extra/src/ 0000775 0001750 0001750 00000000000 15145116760 025047 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/shared_lib_extra/src/shared_lib_extra.f90 0000664 0001750 0001750 00000000332 15145116760 030664 0 ustar alastair alastair module shared_lib_extra
implicit none
private
public :: say_extra_hello
contains
subroutine say_extra_hello
print *, "Hello, shared_lib_extra!"
end subroutine say_extra_hello
end module shared_lib_extra
fortran-lang-fpm-90bb83a/example_packages/metapackage_blas/ 0000775 0001750 0001750 00000000000 15145116760 024224 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_blas/fpm.toml 0000664 0001750 0001750 00000000060 15145116760 025677 0 ustar alastair alastair name = "metapackage_blas"
dependencies.blas="*"
fortran-lang-fpm-90bb83a/example_packages/metapackage_blas/app/ 0000775 0001750 0001750 00000000000 15145116760 025004 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_blas/app/main.f90 0000664 0001750 0001750 00000003245 15145116760 026254 0 ustar alastair alastair program metapackage_blas
implicit none
interface
subroutine dgesv(n, nrhs, a, lda, ipiv, b, ldb, info)
integer, intent(in) :: n, nrhs, lda, ldb
double precision, intent(in out) :: a(lda,*), b(ldb,*)
integer, intent(out) :: ipiv(*), info
end subroutine dgesv
end interface
integer, parameter :: dp = kind(1.0d0)
real(dp), dimension(:,:), allocatable :: a
real(dp), dimension(:), allocatable :: b
integer :: info
allocate(a(3,3), b(3))
a = reshape([1.0_dp, 2.0_dp, 3.0_dp, &
4.0_dp, 5.0_dp, 6.0_dp, &
7.0_dp, 8.0_dp, 9.0_dp], [3,3])
b = [1.0_dp, 2.0_dp, 3.0_dp]
call solve_eqsys(a, b, info)
if (info /= 0) error stop
stop 0
contains
!> simple wrapper for solvers for real system of linear
!> equations A * X = B
subroutine solve_eqsys(a, b, info)
real(dp), dimension(:,:), intent(inout) :: a
real(dp), dimension(:), intent(inout) :: b
integer, intent(out) :: info
integer :: i_alloc
integer :: n, nrhs, lda, ldb
integer, dimension(:), allocatable :: ipiv
! ------------------------------------------------------------------
lda = size(a,1)
n = size(a,2)
ldb = size(b,1)
nrhs = 1
allocate(ipiv(n), stat = i_alloc)
if (i_alloc /= 0) stop 'solve_eqsys: Allocation for array failed!'
call dgesv(n, nrhs, a, lda, ipiv, b, ldb, info)
info = 0
deallocate(ipiv, stat = i_alloc)
if (i_alloc /= 0) stop 'solve_eqsys: Deallocation for array failed!'
end subroutine solve_eqsys
end program metapackage_blas
fortran-lang-fpm-90bb83a/example_packages/link_external/ 0000775 0001750 0001750 00000000000 15145116760 023620 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/link_external/fpm.toml 0000664 0001750 0001750 00000000056 15145116760 025300 0 ustar alastair alastair name = "link_external"
[build]
link = "blas"
fortran-lang-fpm-90bb83a/example_packages/link_external/src/ 0000775 0001750 0001750 00000000000 15145116760 024407 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/link_external/src/wrapped_gemv.f90 0000664 0001750 0001750 00000006324 15145116760 027414 0 ustar alastair alastair !> Performs one of the matrix-vector operations
!>
!> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
!>
!> where alpha and beta are scalars, x and y are vectors and A is an
!> m by n matrix.
module wrapped_gemv
implicit none
private
public :: sp, dp, gemv
integer, parameter :: sp = selected_real_kind(6)
integer, parameter :: dp = selected_real_kind(15)
interface gemv
module procedure :: wrap_sgemv
module procedure :: wrap_dgemv
end interface gemv
interface blas_gemv
subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
import :: sp
real(sp), intent(in) :: a(lda, *)
real(sp), intent(in) :: x(*)
real(sp), intent(inout) :: y(*)
real(sp), intent(in) :: alpha
real(sp), intent(in) :: beta
character(len=1), intent(in) :: trans
integer, intent(in) :: incx
integer, intent(in) :: incy
integer, intent(in) :: m
integer, intent(in) :: n
integer, intent(in) :: lda
end subroutine sgemv
subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
import :: dp
real(dp), intent(in) :: a(lda, *)
real(dp), intent(in) :: x(*)
real(dp), intent(inout) :: y(*)
real(dp), intent(in) :: alpha
real(dp), intent(in) :: beta
character(len=1), intent(in) :: trans
integer, intent(in) :: incx
integer, intent(in) :: incy
integer, intent(in) :: m
integer, intent(in) :: n
integer, intent(in) :: lda
end subroutine dgemv
end interface blas_gemv
contains
subroutine wrap_sgemv(amat, xvec, yvec, alpha, beta, trans)
real(sp), intent(in) :: amat(:, :)
real(sp), intent(in) :: xvec(:)
real(sp), intent(inout) :: yvec(:)
real(sp), intent(in), optional :: alpha
real(sp), intent(in), optional :: beta
character(len=1), intent(in), optional :: trans
real(sp) :: a, b
character(len=1) :: tra
integer :: incx, incy, m, n, lda
if (present(alpha)) then
a = alpha
else
a = 1.0_sp
end if
if (present(beta)) then
b = beta
else
b = 0
end if
if (present(trans)) then
tra = trans
else
tra = 'n'
end if
incx = 1
incy = 1
lda = max(1, size(amat, 1))
m = size(amat, 1)
n = size(amat, 2)
call blas_gemv(tra, m, n, a, amat, lda, xvec, incx, b, yvec, incy)
end subroutine wrap_sgemv
subroutine wrap_dgemv(amat, xvec, yvec, alpha, beta, trans)
real(dp), intent(in) :: amat(:, :)
real(dp), intent(in) :: xvec(:)
real(dp), intent(inout) :: yvec(:)
real(dp), intent(in), optional :: alpha
real(dp), intent(in), optional :: beta
character(len=1), intent(in), optional :: trans
real(dp) :: a, b
character(len=1) :: tra
integer :: incx, incy, m, n, lda
if (present(alpha)) then
a = alpha
else
a = 1.0_dp
end if
if (present(beta)) then
b = beta
else
b = 0
end if
if (present(trans)) then
tra = trans
else
tra = 'n'
end if
incx = 1
incy = 1
lda = max(1, size(amat, 1))
m = size(amat, 1)
n = size(amat, 2)
call blas_gemv(tra, m, n, a, amat, lda, xvec, incx, b, yvec, incy)
end subroutine wrap_dgemv
end module wrapped_gemv
fortran-lang-fpm-90bb83a/example_packages/link_external/.gitignore 0000664 0001750 0001750 00000000010 15145116760 025577 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/link_external/app/ 0000775 0001750 0001750 00000000000 15145116760 024400 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/link_external/app/main.f90 0000664 0001750 0001750 00000000621 15145116760 025643 0 ustar alastair alastair program test_blas
use wrapped_gemv, only : sp, gemv
implicit none
integer :: i, j
real(sp) :: mat(4, 4), vec(4), res(4)
do i = 1, size(vec)
vec(i) = sqrt(real(i, sp))
end do
do i = 1, size(mat, 2)
do j = 1, size(mat, 1)
mat(j, i) = sqrt(real(j * i, sp))
end do
end do
call gemv(mat, vec, res, alpha=-1.0_sp, trans='t')
end program test_blas
fortran-lang-fpm-90bb83a/example_packages/metapackage_minpack/ 0000775 0001750 0001750 00000000000 15145116760 024725 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_minpack/fpm.toml 0000664 0001750 0001750 00000000066 15145116760 026406 0 ustar alastair alastair name = "metapackage_minpack"
dependencies.minpack="*"
fortran-lang-fpm-90bb83a/example_packages/metapackage_minpack/src/ 0000775 0001750 0001750 00000000000 15145116760 025514 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_minpack/src/metapackage_minpack.f90 0000664 0001750 0001750 00000000541 15145116760 032000 0 ustar alastair alastair module metapackage_minpack
use minpack_module, only: wp
use iso_fortran_env, only: real64
implicit none
private
public :: simple_test
contains
subroutine simple_test(success)
logical, intent(out) :: success
! Success! can read minpack module
success = wp == real64
end subroutine simple_test
end module metapackage_minpack
fortran-lang-fpm-90bb83a/example_packages/metapackage_minpack/app/ 0000775 0001750 0001750 00000000000 15145116760 025505 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/metapackage_minpack/app/main.f90 0000664 0001750 0001750 00000000247 15145116760 026754 0 ustar alastair alastair program main
use metapackage_minpack, only: simple_test
implicit none
logical :: success
call simple_test(success)
stop merge(0,1,success)
end program main
fortran-lang-fpm-90bb83a/example_packages/program_with_cpp_guarded_module/ 0000775 0001750 0001750 00000000000 15145116760 027365 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/program_with_cpp_guarded_module/fpm.toml 0000664 0001750 0001750 00000000140 15145116760 031037 0 ustar alastair alastair name = "Program_with_cpp_guarded_module"
# Enable CPP but do not define macros
[preprocess.cpp]
fortran-lang-fpm-90bb83a/example_packages/program_with_cpp_guarded_module/.gitignore 0000664 0001750 0001750 00000000010 15145116760 031344 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/program_with_cpp_guarded_module/app/ 0000775 0001750 0001750 00000000000 15145116760 030145 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/program_with_cpp_guarded_module/app/main.f90 0000664 0001750 0001750 00000000345 15145116760 031413 0 ustar alastair alastair program program_with_module
#if defined(HAVE_MODULE)
use greet_m, only: greeting
#endif
implicit none
#ifndef HAVE_MODULE
print *, 'OK without module'
#else
print *, greeting
#endif
end program program_with_module
fortran-lang-fpm-90bb83a/example_packages/features_default_profile/ 0000775 0001750 0001750 00000000000 15145116760 026023 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/features_default_profile/fpm.toml 0000664 0001750 0001750 00000001160 15145116760 027500 0 ustar alastair alastair name = "features_default_profile"
version = "0.1.0"
description = "Demo package for FPM default profile functionality"
[[executable]]
name = "features_default_profile"
source-dir = "app"
main = "main.f90"
[features]
# Baseline feature: always present with debug/release, not with custom profiles
baseline.preprocess.cpp.macros = "BASELINE"
# Debug feature
debug.preprocess.cpp.macros = "DEBUG"
# Release feature
release.preprocess.cpp.macros = "RELEASE"
# A custom feature
custom_opt.preprocess.cpp.macros = "CUSTOM"
[profiles]
default = ["baseline"]
debug = ["debug"]
release = ["release"]
myprofile = ["custom_opt"]
fortran-lang-fpm-90bb83a/example_packages/features_default_profile/src/ 0000775 0001750 0001750 00000000000 15145116760 026612 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/features_default_profile/src/features_default_profile.f90 0000664 0001750 0001750 00000001037 15145116760 034175 0 ustar alastair alastair module features_default_profile
implicit none
private
public :: show_features
contains
subroutine show_features()
write(*,*) 'Default Profile Demo'
write(*,*) '===================='
#ifdef BASELINE
write(*,*) 'BASELINE active'
#endif
#ifdef DEBUG
write(*,*) 'DEBUG active'
#endif
#ifdef RELEASE
write(*,*) 'RELEASE active'
#endif
#ifdef CUSTOM
write(*,*) 'CUSTOM active'
#endif
write(*,*) 'Done'
end subroutine show_features
end module features_default_profile
fortran-lang-fpm-90bb83a/example_packages/features_default_profile/app/ 0000775 0001750 0001750 00000000000 15145116760 026603 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/features_default_profile/app/main.f90 0000664 0001750 0001750 00000000154 15145116760 030047 0 ustar alastair alastair program main
use features_default_profile
implicit none
call show_features()
end program main
fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/ 0000775 0001750 0001750 00000000000 15145116760 023742 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/fpm.toml 0000664 0001750 0001750 00000000156 15145116760 025423 0 ustar alastair alastair name = "hello_fpm_path"
[dependencies]
utils1 = { path = "crate/utils1" }
utils2 = { path = "crate/utils2" }
fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/app/ 0000775 0001750 0001750 00000000000 15145116760 024522 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/app/main.f90 0000664 0001750 0001750 00000000333 15145116760 025765 0 ustar alastair alastair program hello_fpm
use utils1_m, only: say_hello1
use utils1_1_m, only: say_hello1_1
use utils2_m, only: say_hello2
call say_hello1()
call say_hello1_1()
call say_hello2()
end program hello_fpm
fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/crate/ 0000775 0001750 0001750 00000000000 15145116760 025040 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/crate/utils1_1/ 0000775 0001750 0001750 00000000000 15145116760 026501 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/crate/utils1_1/fpm.toml 0000664 0001750 0001750 00000000022 15145116760 030152 0 ustar alastair alastair name = "utils1_1"
fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/crate/utils1_1/src/ 0000775 0001750 0001750 00000000000 15145116760 027270 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/crate/utils1_1/src/say_hello.f90 0000664 0001750 0001750 00000000265 15145116760 031572 0 ustar alastair alastair module utils1_1_m
implicit none
contains
subroutine say_hello1_1()
print '(a)', "Hello, utils1_1."
end subroutine say_hello1_1
end module utils1_1_m
fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/crate/utils1/ 0000775 0001750 0001750 00000000000 15145116760 026261 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/crate/utils1/fpm.toml 0000664 0001750 0001750 00000000104 15145116760 027733 0 ustar alastair alastair name = "utils1"
[dependencies]
utils1_1 = { path = "../utils1_1" }
fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/crate/utils1/src/ 0000775 0001750 0001750 00000000000 15145116760 027050 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/crate/utils1/src/say_hello.f90 0000664 0001750 0001750 00000000253 15145116760 031347 0 ustar alastair alastair module utils1_m
implicit none
contains
subroutine say_hello1()
print '(a)', "Hello, utils1."
end subroutine say_hello1
end module utils1_m
fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/crate/utils2/ 0000775 0001750 0001750 00000000000 15145116760 026262 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/crate/utils2/fpm.toml 0000664 0001750 0001750 00000000020 15145116760 027731 0 ustar alastair alastair name = "utils2"
fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/crate/utils2/src/ 0000775 0001750 0001750 00000000000 15145116760 027051 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_fpm_path/crate/utils2/src/say_hello.f90 0000664 0001750 0001750 00000000253 15145116760 031350 0 ustar alastair alastair module utils2_m
implicit none
contains
subroutine say_hello2()
print '(a)', "Hello, utils2."
end subroutine say_hello2
end module utils2_m
fortran-lang-fpm-90bb83a/example_packages/shared_app_only/ 0000775 0001750 0001750 00000000000 15145116760 024130 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/shared_app_only/fpm.toml 0000664 0001750 0001750 00000000431 15145116760 025605 0 ustar alastair alastair # App only, use shared lib from other folder
name = "shared_app_only"
library.type="shared"
install.library=true
[dependencies]
shared_lib_extra = { path = "../shared_lib_extra" }
[dev-dependencies]
test-drive = { git = "https://github.com/fortran-lang/test-drive", tag="v0.5.0" }
fortran-lang-fpm-90bb83a/example_packages/shared_app_only/test/ 0000775 0001750 0001750 00000000000 15145116760 025107 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/shared_app_only/test/test.f90 0000664 0001750 0001750 00000002527 15145116760 026414 0 ustar alastair alastair module test_shared_lib
use testdrive, only : new_unittest, unittest_type, error_type, check
use shared_lib, only: test_something
implicit none
public :: collect
contains
!> Collect all exported unit tests
subroutine collect(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ new_unittest("shared_lib", test_shared) ]
end subroutine collect
subroutine test_shared(error)
type(error_type), allocatable, intent(out) :: error
call check(error, test_something(), 123, "Should be test_something==123")
end subroutine test_shared
end module test_shared_lib
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_shared_lib, only : collect
implicit none
integer :: stat
type(testsuite_type), allocatable :: testsuite
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuite = new_testsuite("shared_lib", collect)
write(error_unit, fmt) "Testing:", testsuite%name
call run_testsuite(testsuite%collect, error_unit, stat)
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-fpm-90bb83a/example_packages/shared_app_only/app/ 0000775 0001750 0001750 00000000000 15145116760 024710 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/shared_app_only/app/main.f90 0000664 0001750 0001750 00000000111 15145116760 026145 0 ustar alastair alastair program main
use testdrive
print *, 'Hello, world!'
end program main
fortran-lang-fpm-90bb83a/example_packages/submodule_tree_shake/ 0000775 0001750 0001750 00000000000 15145116760 025152 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/submodule_tree_shake/fpm.toml 0000664 0001750 0001750 00000000036 15145116760 026630 0 ustar alastair alastair name = "submodule_tree_shake"
fortran-lang-fpm-90bb83a/example_packages/submodule_tree_shake/src/ 0000775 0001750 0001750 00000000000 15145116760 025741 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/submodule_tree_shake/src/child2.f90 0000664 0001750 0001750 00000000200 15145116760 027416 0 ustar alastair alastair submodule(parent) child2
implicit none
contains
module procedure my_sub2
a = 2
end procedure my_sub2
end submodule child2 fortran-lang-fpm-90bb83a/example_packages/submodule_tree_shake/src/child_unused.f90 0000664 0001750 0001750 00000000231 15145116760 030723 0 ustar alastair alastair submodule(parent_unused) child_unused
implicit none
contains
module procedure unused_sub
a = 1
end procedure unused_sub
end submodule child_unused fortran-lang-fpm-90bb83a/example_packages/submodule_tree_shake/src/child1.f90 0000664 0001750 0001750 00000000365 15145116760 027431 0 ustar alastair alastair submodule(parent) child1
implicit none
interface
module function my_fun() result (b)
integer :: b
end function my_fun
end interface
contains
module procedure my_sub1
a = my_fun()
end procedure my_sub1
end submodule child1 fortran-lang-fpm-90bb83a/example_packages/submodule_tree_shake/src/grandchild.f90 0000664 0001750 0001750 00000000215 15145116760 030356 0 ustar alastair alastair submodule(parent:child1) grandchild
implicit none
contains
module procedure my_fun
b = 2
end procedure my_fun
end submodule grandchild fortran-lang-fpm-90bb83a/example_packages/submodule_tree_shake/src/parent.f90 0000664 0001750 0001750 00000000405 15145116760 027551 0 ustar alastair alastair module parent
implicit none
interface
module subroutine my_sub1(a)
integer, intent(out) :: a
end subroutine my_sub1
module subroutine my_sub2(a)
integer, intent(out) :: a
end subroutine my_sub2
end interface
end module parent fortran-lang-fpm-90bb83a/example_packages/submodule_tree_shake/src/parent_unused.f90 0000664 0001750 0001750 00000000277 15145116760 031143 0 ustar alastair alastair module parent_unused
implicit none
interface
module subroutine unused_sub(a)
integer, intent(out) :: a
end subroutine unused_sub
end interface
end module parent_unused fortran-lang-fpm-90bb83a/example_packages/submodule_tree_shake/.gitignore 0000664 0001750 0001750 00000000010 15145116760 027131 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/submodule_tree_shake/app/ 0000775 0001750 0001750 00000000000 15145116760 025732 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/submodule_tree_shake/app/main.f90 0000664 0001750 0001750 00000000143 15145116760 027174 0 ustar alastair alastair program test
use parent
integer :: a, b
call my_sub1(a)
call my_sub2(b)
end program test fortran-lang-fpm-90bb83a/example_packages/many_targets/ 0000775 0001750 0001750 00000000000 15145116760 023456 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/many_targets/fpm.toml 0000664 0001750 0001750 00000000026 15145116760 025133 0 ustar alastair alastair name = "many_targets"
fortran-lang-fpm-90bb83a/example_packages/many_targets/test/ 0000775 0001750 0001750 00000000000 15145116760 024435 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/many_targets/test/test2.f90 0000664 0001750 0001750 00000000155 15145116760 026017 0 ustar alastair alastair program test2
use file_mod
implicit none
call print_file("test",2)
stop 0
end program test2
fortran-lang-fpm-90bb83a/example_packages/many_targets/test/test3.f90 0000664 0001750 0001750 00000000155 15145116760 026020 0 ustar alastair alastair program test3
use file_mod
implicit none
call print_file("test",3)
stop 0
end program test3
fortran-lang-fpm-90bb83a/example_packages/many_targets/test/test1.f90 0000664 0001750 0001750 00000000156 15145116760 026017 0 ustar alastair alastair program test1
use file_mod
implicit none
call print_file("test",1)
stop 0
end program test1
fortran-lang-fpm-90bb83a/example_packages/many_targets/src/ 0000775 0001750 0001750 00000000000 15145116760 024245 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/many_targets/src/file_mod.f90 0000664 0001750 0001750 00000000652 15145116760 026346 0 ustar alastair alastair module file_mod
implicit none
public
contains
subroutine print_file(name,id)
character(*), intent(in) :: name
integer, intent(in) :: id
integer :: i
character(len(name)+1) :: nm
write(nm,1)name,id
open(newunit=i,file=nm//'.txt',form="formatted",action="write")
write(i, '(a)') nm
close(i)
1 format(a,i1)
end subroutine print_file
end module file_mod
fortran-lang-fpm-90bb83a/example_packages/many_targets/example/ 0000775 0001750 0001750 00000000000 15145116760 025111 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/many_targets/example/example3.f90 0000664 0001750 0001750 00000000166 15145116760 027152 0 ustar alastair alastair program example3
use file_mod
implicit none
call print_file("example",3)
stop 0
end program example3
fortran-lang-fpm-90bb83a/example_packages/many_targets/example/example2.f90 0000664 0001750 0001750 00000000166 15145116760 027151 0 ustar alastair alastair program example2
use file_mod
implicit none
call print_file("example",2)
stop 0
end program example2
fortran-lang-fpm-90bb83a/example_packages/many_targets/example/example1.f90 0000664 0001750 0001750 00000000167 15145116760 027151 0 ustar alastair alastair program example1
use file_mod
implicit none
call print_file("example",1)
stop 0
end program example1
fortran-lang-fpm-90bb83a/example_packages/many_targets/.gitignore 0000664 0001750 0001750 00000000010 15145116760 025435 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/many_targets/app/ 0000775 0001750 0001750 00000000000 15145116760 024236 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/many_targets/app/run3.f90 0000664 0001750 0001750 00000000152 15145116760 025443 0 ustar alastair alastair program run3
use file_mod
implicit none
call print_file("run",3)
stop 0
end program run3
fortran-lang-fpm-90bb83a/example_packages/many_targets/app/run2.f90 0000664 0001750 0001750 00000000152 15145116760 025442 0 ustar alastair alastair program run2
use file_mod
implicit none
call print_file("run",2)
stop 0
end program run2
fortran-lang-fpm-90bb83a/example_packages/many_targets/app/run1.f90 0000664 0001750 0001750 00000000153 15145116760 025442 0 ustar alastair alastair program run1
use file_mod
implicit none
call print_file("run",1)
stop 0
end program run1
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_c/ 0000775 0001750 0001750 00000000000 15145116760 024312 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_c/fpm.toml 0000664 0001750 0001750 00000000170 15145116760 025767 0 ustar alastair alastair name = "preprocess_cpp_c"
[[executable]]
name = "main"
main = "main.c"
[preprocess]
[preprocess.cpp]
macros = ["VAL"]
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_c/include/ 0000775 0001750 0001750 00000000000 15145116760 025735 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_c/include/val.h 0000664 0001750 0001750 00000000122 15145116760 026663 0 ustar alastair alastair #ifndef _VAL_H_
#define _VAL_H_
#ifdef VAL
const int variable = 1;
#endif
#endif
fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_c/app/ 0000775 0001750 0001750 00000000000 15145116760 025072 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_cpp_c/app/main.c 0000664 0001750 0001750 00000000117 15145116760 026161 0 ustar alastair alastair #include
#include "val.h"
int main() { printf("%d\n", variable); }
fortran-lang-fpm-90bb83a/example_packages/hello_fpm/ 0000775 0001750 0001750 00000000000 15145116760 022726 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_fpm/fpm.toml 0000664 0001750 0001750 00000000121 15145116760 024377 0 ustar alastair alastair name = "hello_fpm"
[dependencies]
hello_complex = { path = "../hello_complex" }
fortran-lang-fpm-90bb83a/example_packages/hello_fpm/.gitignore 0000664 0001750 0001750 00000000010 15145116760 024705 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/hello_fpm/app/ 0000775 0001750 0001750 00000000000 15145116760 023506 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/hello_fpm/app/main.f90 0000664 0001750 0001750 00000000315 15145116760 024751 0 ustar alastair alastair program hello_fpm
use farewell_m, only: make_farewell
use greet_m, only: make_greeting
implicit none
print *, make_greeting("fpm")
print *, make_farewell("fpm")
end program hello_fpm
fortran-lang-fpm-90bb83a/example_packages/shared_lib_empty/ 0000775 0001750 0001750 00000000000 15145116760 024273 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/shared_lib_empty/fpm.toml 0000664 0001750 0001750 00000000231 15145116760 025746 0 ustar alastair alastair name = "shared_lib_empty"
library.type="shared"
[dependencies]
shared_lib = { path = "../shared_lib" }
shared_app_only = { path = "../shared_app_only" }
fortran-lang-fpm-90bb83a/example_packages/app_with_c/ 0000775 0001750 0001750 00000000000 15145116760 023076 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/app_with_c/fpm.toml 0000664 0001750 0001750 00000000020 15145116760 024545 0 ustar alastair alastair name = "with_c"
fortran-lang-fpm-90bb83a/example_packages/app_with_c/.gitignore 0000664 0001750 0001750 00000000010 15145116760 025055 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/app_with_c/app/ 0000775 0001750 0001750 00000000000 15145116760 023656 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/app_with_c/app/c_code.c 0000664 0001750 0001750 00000000462 15145116760 025240 0 ustar alastair alastair #include
/*
* Decides whether a given file name is a directory.
* return 1 if file exists and is a directory
* Source (Public domain): https://github.com/urbanjost/M_system
*/
int my_isdir(const char *path)
{
struct stat sb;
return stat(path, &sb) == 0 && S_ISDIR(sb.st_mode);
} fortran-lang-fpm-90bb83a/example_packages/app_with_c/app/main.f90 0000664 0001750 0001750 00000002030 15145116760 025115 0 ustar alastair alastair module with_c
use iso_c_binding, only: c_char, c_int, c_null_char
implicit none
contains
function system_isdir(dirname)
! Source (Public domain): https://github.com/urbanjost/M_system
!
implicit none
character(len=*), intent(in) :: dirname
logical :: system_isdir
interface
function c_isdir(dirname) bind(C, name="my_isdir") result(c_ierr)
import c_char, c_int
character(kind=c_char, len=1), intent(in) :: dirname(*)
integer(kind=c_int) :: c_ierr
end function c_isdir
end interface
system_isdir = c_isdir(trim(dirname)//c_null_char) == 1
end function system_isdir
end module with_c
program with_c_app
use with_c
implicit none
write (*, *) "isdir('app') = ", system_isdir('app')
write (*, *) "isdir('src') = ", system_isdir('src')
write (*, *) "isdir('test') = ", system_isdir('test')
write (*, *) "isdir('bench') = ", system_isdir('bench')
end program with_c_app
fortran-lang-fpm-90bb83a/example_packages/fixed-form/ 0000775 0001750 0001750 00000000000 15145116760 023021 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/fixed-form/fpm.toml 0000664 0001750 0001750 00000000062 15145116760 024476 0 ustar alastair alastair name = "fixed-form"
fortran.source-form = "fixed"
fortran-lang-fpm-90bb83a/example_packages/fixed-form/src/ 0000775 0001750 0001750 00000000000 15145116760 023610 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/fixed-form/src/lib.f90 0000664 0001750 0001750 00000000220 15145116760 024670 0 ustar alastair alastair module lib
contains
subroutine h e l l o
print '(a)',
+"Hello, fixed world!"
end subroutine
end module
fortran-lang-fpm-90bb83a/example_packages/fixed-form/app/ 0000775 0001750 0001750 00000000000 15145116760 023601 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/fixed-form/app/main.f90 0000664 0001750 0001750 00000000074 15145116760 025046 0 ustar alastair alastair program test
use lib
call hello
end
fortran-lang-fpm-90bb83a/example_packages/fortran_includes/ 0000775 0001750 0001750 00000000000 15145116760 024322 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/fortran_includes/fpm.toml 0000664 0001750 0001750 00000000071 15145116760 025777 0 ustar alastair alastair name = "fortran_includes"
[library]
include-dir = "inc"
fortran-lang-fpm-90bb83a/example_packages/fortran_includes/src/ 0000775 0001750 0001750 00000000000 15145116760 025111 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/fortran_includes/src/lib.f90 0000664 0001750 0001750 00000000307 15145116760 026177 0 ustar alastair alastair module test_mod
implicit none
include "parameters.f90"
contains
subroutine test_sub(a)
real(dp), intent(in) :: a
write(*,*) 'a: ', a
end subroutine test_sub
end module test_mod fortran-lang-fpm-90bb83a/example_packages/fortran_includes/.gitignore 0000664 0001750 0001750 00000000010 15145116760 026301 0 ustar alastair alastair build/*
fortran-lang-fpm-90bb83a/example_packages/fortran_includes/inc/ 0000775 0001750 0001750 00000000000 15145116760 025073 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/fortran_includes/inc/parameters.f90 0000664 0001750 0001750 00000000045 15145116760 027555 0 ustar alastair alastair integer, parameter :: dp = kind(0.d0) fortran-lang-fpm-90bb83a/example_packages/with_examples/ 0000775 0001750 0001750 00000000000 15145116760 023632 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/with_examples/fpm.toml 0000664 0001750 0001750 00000000171 15145116760 025310 0 ustar alastair alastair name = "with_examples"
build.auto-examples = false
[[example]]
name = "demo-prog"
source-dir = "demo"
main = "prog.f90"
fortran-lang-fpm-90bb83a/example_packages/with_examples/demo/ 0000775 0001750 0001750 00000000000 15145116760 024556 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/with_examples/demo/prog.f90 0000664 0001750 0001750 00000000154 15145116760 026045 0 ustar alastair alastair program demo
write(*, '(a)') "This is a simple demo program, but not a real application"
end program demo
fortran-lang-fpm-90bb83a/example_packages/with_examples/.gitignore 0000664 0001750 0001750 00000000011 15145116760 025612 0 ustar alastair alastair /build/*
fortran-lang-fpm-90bb83a/example_packages/with_examples/app/ 0000775 0001750 0001750 00000000000 15145116760 024412 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/with_examples/app/demo-prog.f90 0000664 0001750 0001750 00000000113 15145116760 026616 0 ustar alastair alastair program demo
write(*, '(a)') "This is a simple program"
end program demo
fortran-lang-fpm-90bb83a/example_packages/preprocess_per_dependency/ 0000775 0001750 0001750 00000000000 15145116760 026212 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_per_dependency/fpm.toml 0000664 0001750 0001750 00000000173 15145116760 027672 0 ustar alastair alastair name = "preprocess_cpp_deps"
[dependencies]
utils = { path = "crate/utils" , preprocess.cpp.macros=["DEPENDENCY_MACRO"] }
fortran-lang-fpm-90bb83a/example_packages/preprocess_per_dependency/app/ 0000775 0001750 0001750 00000000000 15145116760 026772 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_per_dependency/app/main.f90 0000664 0001750 0001750 00000000255 15145116760 030240 0 ustar alastair alastair program hello_fpm
use utils, only: say_hello
integer :: ierr
call say_hello(ierr)
stop ierr ! ierr==0 if DEPENDENCY_MACRO is defined
end program hello_fpm
fortran-lang-fpm-90bb83a/example_packages/preprocess_per_dependency/crate/ 0000775 0001750 0001750 00000000000 15145116760 027310 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_per_dependency/crate/utils/ 0000775 0001750 0001750 00000000000 15145116760 030450 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_per_dependency/crate/utils/fpm.toml 0000664 0001750 0001750 00000000077 15145116760 032133 0 ustar alastair alastair name = "utils"
[preprocess]
[preprocess.cpp]
macros = ["X=1"]
fortran-lang-fpm-90bb83a/example_packages/preprocess_per_dependency/crate/utils/src/ 0000775 0001750 0001750 00000000000 15145116760 031237 5 ustar alastair alastair fortran-lang-fpm-90bb83a/example_packages/preprocess_per_dependency/crate/utils/src/say_hello.f90 0000664 0001750 0001750 00000000464 15145116760 033542 0 ustar alastair alastair module utils
implicit none
contains
subroutine say_hello(ierr)
integer, intent(out) :: ierr
ierr = -1
#ifdef DEPENDENCY_MACRO
ierr = 0
#endif
print *, "Dependency macro ", merge(" IS","NOT",ierr==0)," defined"
end subroutine say_hello
end module utils
fortran-lang-fpm-90bb83a/doc/ 0000775 0001750 0001750 00000000000 15145116760 016235 5 ustar alastair alastair fortran-lang-fpm-90bb83a/doc/media/ 0000775 0001750 0001750 00000000000 15145116760 017314 5 ustar alastair alastair fortran-lang-fpm-90bb83a/doc/media/favicon.ico 0000664 0001750 0001750 00000041076 15145116760 021445 0 ustar alastair alastair @@ (B ( @ Pu#PssPsPsږOrOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOrOsٕPsNrrSq" Mw NsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPtPu# Nr\OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsNs[ Os~OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPr} Ps]OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOtZ Nq$OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsMt! OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOs Nq$OsOsOsOsOsOsOsǡOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPu#OrtOsOsOsOsOsOsOsǡOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsqOsOsOsOsOsOsOsOsǠOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOrOsܖOsOsOsOsOsOsOsŞOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsٖOrOsOsOsOsOsOsOs{ĜOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsbѲչؾӶpOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPt]OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOspOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsٿkOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOshOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsdOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsaOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOs_OsOsOsOsOsOsOsOsչOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֻ[}OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֺXzOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֺVxOsOsOsOsOsOsOsRvOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֺUwOsOsOsOsOsOsOshOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsչTwOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsչRvOsOsOsOsOsOsOsѲOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsոQuOsOsOsOsOsOsSvOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsոPtOsOsOsOsOsOsҴOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsԷOsOsOsOsRu}OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsԷ̩չOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsԷOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsԷOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsԷOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsԷOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsոOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsոQuQuarϯOsOsOsOsOsOsOsdέҴչչoOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsչQuOsOsOsOsOs[}OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsչQuOsOsOsOsOsOs^OsOsOsOsOsOsOsȣOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֺQuOsOsOsOsOsOsOsѲOsOsOsOsOsOsOsӵOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֺQuOsOsOsOsOsOsOs}OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֻQuOsOsOsOsOsOsOs]~OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֻQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsPtOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsgOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsӴOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsٿOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsXzOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsٿQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOs˧OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOstOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsyOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsUw|ٿOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsgέέӴήέέέέչչչٿOsOsOsOsOsOsOsOsOrOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsNsݖOsOsOsOsOsOsOsOsOsOsOsOsOsOsPsڗOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPsNtuOsOsOsOsOsOsOsOsOsOsOsOsOsOsNrrLu%OsOsOsOsOsOsOsOsOsOsOsOsOsOsPu# PtOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOs Lu%OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsSq" Or^OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsNrb PtOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOs~ PsYOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPr` Rs OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPtLu% Lu%NtuOsOsۖOrOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOrOsۗOsOrtNq$ fortran-lang-fpm-90bb83a/doc/Contributing.md 0000664 0001750 0001750 00000000074 15145116760 021227 0 ustar alastair alastair ---
title: Contributing Guidelines
---
{!CONTRIBUTING.md!}
fortran-lang-fpm-90bb83a/doc/index.md 0000664 0001750 0001750 00000000052 15145116760 017663 0 ustar alastair alastair ---
title: Packaging and contributing
---
fortran-lang-fpm-90bb83a/doc/Packaging.md 0000664 0001750 0001750 00000000064 15145116760 020443 0 ustar alastair alastair ---
title: Packaging with fpm
---
{!PACKAGING.md!}
fortran-lang-fpm-90bb83a/doc/License.md 0000664 0001750 0001750 00000000044 15145116760 020137 0 ustar alastair alastair ---
title: License
---
{!LICENSE!}
fortran-lang-fpm-90bb83a/doc/Manifest.md 0000664 0001750 0001750 00000000076 15145116760 020330 0 ustar alastair alastair ---
title: Manifest reference
---
{!manifest-reference.md!}
fortran-lang-fpm-90bb83a/PACKAGING.md 0000664 0001750 0001750 00000052424 15145116760 017305 0 ustar alastair alastair # Preparing your package for FPM
This document describes how you need to organize your application or library for
it to successfully build with the Fortran Package Manager (*fpm*).
* [What kind of package can fpm build?](#what-kind-of-package-can-fpm-build)
* [Example package layouts](#example-package-layouts)
- [Single program](#single-program)
- [Single-module library](#single-module-library)
- [Multi-module library](#multi-module-library)
- [Application and library](#application-and-library)
- [Multi-level library](#multi-level-library)
- [Be more explicit](#be-more-explicit)
- [Add some tests](#add-some-tests)
- [Adding dependencies](#adding-dependencies)
- [Custom build scripts](#custom-build-scripts)
## What kind of package can fpm build?
You can use *fpm* to build:
* Applications (program only)
* Libraries (modules only)
* Combination of the two (programs and modules combined)
Let’s look at some examples of different kinds of package layouts that you can
use with *fpm*.
## Example package layouts
This section describes some example package layouts that you can build with
*fpm*. You can use them to model the layout of your own package.
### Single program
Let’s start with the simplest package imaginable—a single program without
dependencies or modules. Here’s what the layout of the top-level directory
looks like:
```
.
├── app
│ └── main.f90
└── fpm.toml
```
We have one source file (`main.f90`) in one directory (`app`). Its contents
are:
```fortran
program main
print *, 'Hello, World!'
end program main
```
This program prints the usual greeting to the standard output, and nothing more.
There’s another important file in the top-level directory, `fpm.toml`. This is
*fpm*’s configuration file specific to your package. It includes all the data
that *fpm* needs to build your app. In our simple case, it looks like this:
```toml
name = "hello"
version = "0.1.0"
license = "MIT"
author = "Jane Programmer"
maintainer = "jane@example.com"
copyright = "2020 Jane Programmer"
```
The preamble includes some metadata, such as `license`, `author`, and similar,
that you may have seen in other package manager configuration files. The one
option that matters here right now is:
```toml
name = "hello"
```
This line specifies the name of your package, which determines the name of the
executable file of your program. In this example, our program executable, once
built, will be called `hello`.
Let’s now build this program using *fpm*:
```
$ fpm build
# gfortran (for build/debug/app/main.o)
# gfortran (for build/debug/app/hello)
```
On the first line, we ran `fpm build` to compile and link the application.
The latter two lines are emitted by *fpm*, and indicate which command was
executed at each build step (`gfortran`), and which files have been output
by it: object file `main.o`, and executable `hello`.
We can now run the app with `fpm run`:
```
$ fpm run
Hello, World!
```
If your application needs to use a module internally, but you don’t intend
to build it as a library to be used in other projects, you can include the
module in your program source file as well.
For example:
```fortran
$ cat app/main.f90
module math_constants
real, parameter :: pi = 4 * atan(1.)
end module math_constants
program main
use math_constants, only: pi
print *, 'Hello, World!'
print *, 'pi = ', pi
end program main
```
Now, run this using `fpm run`:
```
$ fpm run
# gfortran (for build/debug/app/main.o)
# gfortran (for build/debug/app/hello)
Hello, World!
pi = 3.14159274
```
Although we have named our program `hello`, which is the same name as the
package name in `fpm.toml`, you can name it anything you want as long as it’s
permitted by the language.
Notice that you can run `fpm run`, and if the package hasn’t been built yet,
`fpm build` will run automatically for you. This is true if the source files
have been updated since the last build. Thus, if you want to run your
application, you can skip the `fpm build` step, and go straight to `fpm run`.
When running your application using `fpm run`, the program's exit code is
passed by *fpm* back to the operating system. So, it is possible to use Fortran
numbered `stop` and `error stop` codes to pass termination reasons back to the terminal.
Try running the following app with `fpm run`:
```fortran
program main
use math_constants, only: pi
real :: angle
read(*,*,iostat=ierr) angle
if (ierr/=0) then
stop 2 ! Not real
elseif (angle>pi) then
stop 1
else
stop 0
endif
end program main
```
and then checking that the error code matches. Note that error codes are passed to variable `$?`
on Unix/Mac systems, and to environment variable `%errorlevel%` on Windows.
In this last example, our source file defined a `math_constants` module inside
the same source file as the main program. Let’s see how we can define an *fpm*
package that makes this module available as a library.
### Single-module library
The package layout for this example looks like this:
```
.
├── fpm.toml
└── src
└── math_constants.f90
```
In this example we’ll build a simple math constants library that exports
the number pi as a parameter:
```fortran
$ cat src/math_constants.f90
module math_constants
real, parameter :: pi = 4 * atan(1.)
end module math_constants
```
and our `fpm.toml` is the same as before.
Now use `fpm build` to build the package:
```
$ fpm build
# gfortran (for build/debug/library/math_constants.o build/debug/library/math_constants.mod)
# ar (for build/debug/library/math_constants.a)
ar: creating build/debug/library/math_constants.a
```
Based on the output of `fpm build`, *fpm* first ran `gfortran` to emit the
binary object (`math_constants.o`) and module (`math_constants.mod`) files.
Then it ran `ar` to create a static library archive `math_constants.a`.
`build/debug/library` is thus both your include and library path, should you
want to compile and link an external program with this library.
For modules in the top-level (`src`) directory, *fpm* requires that:
* The module has the same name as the source file.
* There is 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 (more on this in a bit).
Since this is a library without executable programs, `fpm run` here does
nothing.
In this example, our library is made of only one module. However, most
real-world libraries are likely to use multiple modules. Let’s see how you can
package your multi-module library.
### Multi-module library
In this example, we’ll use another module to define a 64-bit real kind
parameter and make it available in `math_constants` to define `pi` with
higher precision. To make this exercise worthwhile, we’ll define another math
constant, Euler’s number.
Our package layout looks like this:
```
.
├── fpm.toml
└── src
├── math_constants.f90
└── type_kinds.f90
```
And our source file contents are:
```fortran
$ cat src/math_constants.f90
module math_constants
use type_kinds, only: rk
real(rk), parameter :: pi = 4 * atan(1._rk)
real(rk), parameter :: e = exp(1._rk)
end module math_constants
$ cat src/type_kinds.f90
module type_kinds
use iso_fortran_env, only: real64
integer, parameter :: rk = real64
end module type_kinds
```
and there are no changes to our `fpm.toml` relative to previous examples.
Like before, notice that the module `type_kinds` is name exactly as the
source file that contains it.
This is important.
By now you know how to build the package:
```
$ fpm build
# gfortran (for build/debug/library/type_kinds.o build/debug/library/type_kinds.mod)
# gfortran (for build/debug/library/math_constants.o build/debug/library/math_constants.mod)
# ar (for build/debug/library/math_constants.a)
ar: creating build/debug/library/math_constants.a
```
Our build path now contains:
```
$ ls build/debug/library/
math_constants.a math_constants.mod math_constants.o type_kinds.mod type_kinds.o
```
And the static library includes all the object files:
```
$ nm build/debug/library/math_constants.a
math_constants.o:
type_kinds.o:
```
The takeaways from this example are that:
* *fpm* automatically scanned the `src` directory for any source files.
* It also resolved the dependency order between different modules.
### Application and library
Let’s now combine the two previous examples into one: We’ll build the math
constants library *and* an executable program that uses it. We’ll use this
program as a demo, and to verify that defining higher-precision constants from
the previous example actually worked.
Here’s the package layout for your application + library package:
```
.
├── app
│ └── main.f90
├── fpm.toml
└── src
├── math_constants.f90
└── type_kinds.f90
```
Our `fpm.toml` remains unchanged and our executable program source file is:
```fortran
$ cat app/main.f90
program main
use math_constants, only: e, pi
print *, 'math_constants library demo'
print *, 'pi = ', pi
print *, 'e = ', e
end program main
```
Let’s go straight to running the demo program:
```
$ fpm run
# gfortran (for build/debug/library/type_kinds.o build/debug/library/type_kinds.mod)
# gfortran (for build/debug/library/math_constants.o build/debug/library/math_constants.mod)
# ar (for build/debug/library/math_constants.a)
ar: creating build/debug/library/math_constants.a
# gfortran (for build/debug/app/main.o)
# gfortran (for build/debug/app/math_constants)
math_constants library demo
pi = 3.1415926535897931
e = 2.7182818284590451
```
The *fpm* build + run process works as expected, and our program correctly
outputs higher-precision constants.
So far we covered how *fpm* builds:
* A single program
* A single-module library
* A multi-module library
* A program and a library
However, all our modules so far have been organized in the top level source
directory. More complex libraries may organize their modules in subdirectories.
Let’s see how we can build this with *fpm*.
### Multi-level library
In this example, we’ll define our library as a collection of modules, two of
which are defined in a subdirectory:
```
.
├── app
│ └── main.f90
├── fpm.toml
└── src
├── math_constants
│ ├── derived.f90
│ └── fundamental.f90
├── math_constants.f90
└── type_kinds.f90
```
First, `fpm.toml` and `src/type_kinds.f90` remain unchanged relative to the
previous example.
The rest of the source files are:
```fortran
$ cat src/math_constants.f90
module math_constants
use math_constants_fundamental, only: e, pi
use math_constants_derived, only: half_pi, two_pi
end module math_constants
$ cat src/math_constants/fundamental.f90
module math_constants_fundamental
use type_kinds, only: rk
real(rk), parameter :: pi = 4 * atan(1._rk)
real(rk), parameter :: e = exp(1._rk)
end module math_constants_fundamental
$ cat src/math_constants/derived.f90
module math_constants_derived
use math_constants_fundamental, only: pi
use type_kinds, only: rk
real(rk), parameter :: two_pi = 2 * pi
real(rk), parameter :: half_pi = pi / 2
end module math_constants_derived
$ cat app/main.f90
program main
use math_constants, only: e, pi, half_pi, two_pi
print *, 'math_constants library demo'
print *, 'pi = ', pi
print *, '2*pi = ', two_pi
print *, 'pi/2 = ', half_pi
print *, 'e = ', e
end program main
```
Our top-level `math_constants` module now doesn’t define the constants, but
imports them from the two modules in the subdirectory. Constants `e` and `pi`
we define in the `math_constants_fundamental` module, and `two_pi` and `half_pi`
in the `math_constants_derived` module. From the main program, we access all
the constants from the top-level module `math_constants`.
Let’s build and run this package:
```
$ fpm run
# gfortran (for build/debug/library/type_kinds.o build/debug/library/type_kinds.mod)
# gfortran (for build/debug/library/math_constants_fundamental.o build/debug/library/math_constants_fundamental.mod)
# gfortran (for build/debug/library/math_constants_derived.o build/debug/library/math_constants_derived.mod)
# gfortran (for build/debug/library/math_constants.o build/debug/library/math_constants.mod)
# ar (for build/debug/library/math_constants.a)
ar: creating build/debug/library/math_constants.a
# gfortran (for build/debug/app/main.o)
# gfortran (for build/debug/app/math_constants)
math_constants library demo
pi = 3.1415926535897931
2*pi = 6.2831853071795862
pi/2 = 1.5707963267948966
e = 2.7182818284590451
```
Again, *fpm* built and run the package as expected.
Recall from an earlier example that *fpm* required the modules in the top-level
`src` directory to be named the same as their source file. This is why
`src/math_constants.f90` defines `module math_constants`.
For modules defined in subdirectories, there’s an additional requirement: module
name must contain the path components of the directory that its source file is
in. In our case, `src/math_constants/fundamental.f90` defines the
`math_constants_fundamental` module. Likewise, `src/math_constants/derived.f90`
defines the `math_constants_derived` module.
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`.
Takeaways from this example are that:
* You can place your module source files in any levels of subdirectories inside `src`.
* The module name must include the path components and the source file name--for example,
`src/a/b/c/d.f90` must define a module called `a_b_c_d`.
### Be more explicit
So far we’ve let *fpm* use its defaults to determine the layout of our package.
It determined where our library sources would live, what the name of the
executable will be, and some other things. But we can be more explicit about it,
and make some changes to those things.
Let’s look at what the `fpm.toml` file from our last example would look like if
we specified everything.
```toml
name = "math_constants"
version = "0.1.0"
license = "MIT"
author = "Jane Programmer"
maintainer = "jane@example.com"
copyright = "2020 Jane Programmer"
[library]
source-dir="src"
[[ executable ]]
name="math_constants"
source-dir="app"
main="main.f90"
```
You can see that by making these explicit in the `fpm.toml` we are able to
change many of the settings that *fpm* used by default. We can change the
folders where our sources are stored, we can change the name of our executable,
and we can change the name of the file our program is defined in.
### Add some tests
*fpm* also provides support for unit testing. By default, *fpm* looks for a
program in `test/main.f90` which it will compile and execute with the command
`fpm test`. The tests are treated pretty much exactly like the executables.
Let’s define one explicitly in our `fpm.toml` file. We’ll make sure that our
definition of `pi` satisfies the property `sin(pi) == 0.0`. Here’s the
`fpm.toml` file:
```toml
name = "math_constants"
version = "0.1.0"
license = "MIT"
author = "Jane Programmer"
maintainer = "jane@example.com"
copyright = "2020 Jane Programmer"
[library]
source-dir="src"
[[ executable ]]
name="math_constants"
source-dir="app"
main="main.f90"
[[ test ]]
name="runTests"
source-dir="test"
main="main.f90"
```
where the contents of the `main.f90` file are
```fortran
program main
use math_constants, only: pi
print *, "sin(pi) = ", sin(pi)
end program main
```
With this setup, we can run our tests.
```
$ fpm test
# gfortran (for build/debug/library/type_kinds.o build/debug/library/type_kinds.mod)
# gfortran (for build/debug/library/math_constants_fundamental.o build/debug/library/math_constants_fundamental.mod)
# gfortran (for build/debug/library/math_constants_derived.o build/debug/library/math_constants_derived.mod)
# gfortran (for build/debug/library/math_constants.o build/debug/library/math_constants.mod)
# ar (for build/debug/library/math_constants.a)
ar: creating build/debug/library/math_constants.a
# gfortran (for build/debug/app/main.o)
# gfortran (for build/debug/app/math_constants)
# gfortran (for build/debug/test/main.o)
# gfortran (for build/debug/test/runTests)
sin(pi) = 1.2246467991473532E-016
```
### Adding dependencies
Inevitably, you’ll want to be able to include other libraries in your project.
fpm makes this incredibly simple, by taking care of fetching and compiling your
dependencies for you. You just tell it what your dependencies are, and where to
find them. Let’s add a dependency to our library. Now our `fpm.toml` file looks
like this:
```toml
name = "math_constants"
version = "0.1.0"
license = "MIT"
author = "Jane Programmer"
maintainer = "jane@example.com"
copyright = "2020 Jane Programmer"
[library]
source-dir="src"
[dependencies]
helloff = { git = "https://gitlab.com/everythingfunctional/helloff.git" }
[[ executable ]]
name="math_constants"
source-dir="app"
main="main.f90"
[[ test ]]
name="runTests"
source-dir="test"
main="main.f90"
```
Now you can use any modules from this library anywhere in your code. Just like
this:
```fortran
program main
use helloff, only: create_greeting
use math_constants, only: e, pi, half_pi, two_pi
print *, 'math_constants library demo'
print *, 'pi = ', pi
print *, '2*pi = ', two_pi
print *, 'pi/2 = ', half_pi
print *, 'e = ', e
print *, create_greeting("fpm")
end program main
```
And now, `fpm run` will output the following:
```
math_constants library demo
pi = 3.1415926535897931
2*pi = 6.2831853071795862
pi/2 = 1.5707963267948966
e = 2.7182818284590451
Hello, fpm!
```
Additionally, any users of your library will now automatically depend on your
dependencies too. So if you don’t need that dependency for the library, like in
the above example, then you can specify it for the specific executable like
below. Then fpm will still fetch and compile it when building your executable,
but users of your library won’t have to.
```toml
name = "math_constants"
version = "0.1.0"
license = "MIT"
author = "Jane Programmer"
maintainer = "jane@example.com"
copyright = "2020 Jane Programmer"
[library]
source-dir="src"
[[ executable ]]
name="math_constants"
source-dir="app"
main="main.f90"
[executable.dependencies]
helloff = { git = "https://gitlab.com/everythingfunctional/helloff.git" }
[[ test ]]
name="runTests"
source-dir="test"
main="main.f90"
```
You can also specify dependencies for your tests in a similar way, with
`[test.dependencies]` instead of `[executable.dependencies]`. There’s also
another option for test dependencies. The below example makes the dependencies
available for all the tests, but again your users won’t depend on these.
```toml
name = "math_constants"
version = "0.1.0"
license = "MIT"
author = "Jane Programmer"
maintainer = "jane@example.com"
copyright = "2020 Jane Programmer"
[library]
source-dir="src"
[dev-dependencies]
helloff = { git = "https://gitlab.com/everythingfunctional/helloff.git" }
[[ executable ]]
name="math_constants"
source-dir="app"
main="main.f90"
[[ test ]]
name="runTests"
source-dir="test"
main="main.f90"
```
You can also be specific about which version of a dependency you’d like. You can
specify a branch to use like
`helloff = { git = "https://gitlab.com/everythingfunctional/helloff.git", branch = "master" }`,
or a tag like
`helloff = { git = "https://gitlab.com/everythingfunctional/helloff.git", tag = "v1.2.3" }`,
or even a specific commit like
`helloff = { git = "https://gitlab.com/everythingfunctional/helloff.git", rev = "a1b2c3" }`.
You can even specify the path to another folder, if for example you’ve got
another fpm package in the same repository. Like this:
`helloff = { path = "helloff" }`. Note that you should *not* specify paths
outside of your repository, or things won’t work for your users.
### Custom build scripts
If there is something special about your library that makes fpm unable to build
it, you can provide your own build script. fpm will then simply call your build
script to build the library.
To specify a build script to be used, put it in the library section of your
`fpm.toml` file, like:
```toml
[library]
source-dir="src"
build-script="my_build_script"
```
*fpm* will set the following environment variables to specify some parameters to
the build script:
* `FC` – The Fortran compiler to be used.
* `FFLAGS` – The flags that should be passed to the Fortran compiler.
* `BUILD_DIR` – Where the compiled files should be placed.
* `INCLUDE_DIRS` – The folders where any dependencies can be found, space separated.
It is then the responsibility of the build script to generate the appropriate
include flags.
Additionally, script will be called with the name of the archive (`*.a` file)
that should be produced as the command line argument.
> Note: If the name of the build script is `Makefile` or ends with `.mk`, then
> the make program will be used to run it. Not the the archive file is explicitly
> specified as the target to be built
> Note: All file and directory names are specified with their full canonical
> path.
fortran-lang-fpm-90bb83a/.gitignore 0000664 0001750 0001750 00000000130 15145116760 017452 0 ustar alastair alastair build/*
# Visual Studio Code
.vscode/
# CodeBlocks
project/
# Temporary files
*.swp
fortran-lang-fpm-90bb83a/app/ 0000775 0001750 0001750 00000000000 15145116760 016250 5 ustar alastair alastair fortran-lang-fpm-90bb83a/app/main.f90 0000664 0001750 0001750 00000007632 15145116760 017524 0 ustar alastair alastair program main
use, intrinsic :: iso_fortran_env, only : error_unit, output_unit
use fpm_command_line, only: &
fpm_cmd_settings, &
fpm_new_settings, &
fpm_build_settings, &
fpm_export_settings, &
fpm_run_settings, &
fpm_test_settings, &
fpm_install_settings, &
fpm_update_settings, &
fpm_clean_settings, &
fpm_publish_settings, &
get_command_line_settings
use fpm_error, only: error_t
use fpm_filesystem, only: exists, parent_dir, join_path
use fpm, only: cmd_build, cmd_run, cmd_clean
use fpm_cmd_install, only: cmd_install
use fpm_cmd_export, only: cmd_export
use fpm_cmd_new, only: cmd_new
use fpm_cmd_update, only : cmd_update
use fpm_cmd_publish, only: cmd_publish
use fpm_os, only: change_directory, get_current_directory
implicit none
class(fpm_cmd_settings), allocatable :: cmd_settings
type(error_t), allocatable :: error
character(len=:), allocatable :: pwd_start, pwd_working, working_dir, project_root
call get_command_line_settings(cmd_settings)
call get_current_directory(pwd_start, error)
call handle_error(error)
call get_working_dir(cmd_settings, working_dir)
if (allocated(working_dir)) then
! Change working directory if requested
if (len_trim(working_dir) > 0) then
call change_directory(working_dir, error)
call handle_error(error)
call get_current_directory(pwd_working, error)
call handle_error(error)
write(output_unit, '(*(a))') "fpm: Entering directory '"//pwd_working//"'"
else
pwd_working = pwd_start
end if
else
pwd_working = pwd_start
end if
select type (settings => cmd_settings)
type is (fpm_new_settings)
class default
if (.not.has_manifest(pwd_working)) then
project_root = pwd_working
do while(.not.has_manifest(project_root))
working_dir = parent_dir(project_root)
if (len(working_dir) == 0) exit
project_root = working_dir
end do
if (has_manifest(project_root)) then
call change_directory(project_root, error)
call handle_error(error)
write(output_unit, '(*(a))') "fpm: Entering directory '"//project_root//"'"
end if
end if
end select
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_export_settings)
call cmd_export(settings)
type is (fpm_install_settings)
call cmd_install(settings)
type is (fpm_update_settings)
call cmd_update(settings)
type is (fpm_clean_settings)
call cmd_clean(settings)
type is (fpm_publish_settings)
call cmd_publish(settings)
end select
if (allocated(project_root)) then
write(output_unit, '(*(a))') "fpm: Leaving directory '"//project_root//"'"
end if
if (pwd_start /= pwd_working) then
write(output_unit, '(*(a))') "fpm: Leaving directory '"//pwd_working//"'"
end if
contains
function has_manifest(dir)
character(len=*), intent(in) :: dir
logical :: has_manifest
has_manifest = exists(join_path(dir, "fpm.toml"))
end function has_manifest
subroutine handle_error(error_)
type(error_t), optional, intent(in) :: error_
if (present(error_)) then
write (error_unit, '("[Error]", 1x, a)') error_%message
stop 1
end if
end subroutine handle_error
!> Save access to working directory in settings, in case setting have not been allocated
subroutine get_working_dir(settings, working_dir_)
class(fpm_cmd_settings), optional, intent(in) :: settings
character(len=:), allocatable, intent(out) :: working_dir_
if (present(settings)) then
working_dir_ = settings%working_dir
end if
end subroutine get_working_dir
end program main
fortran-lang-fpm-90bb83a/ci/ 0000775 0001750 0001750 00000000000 15145116760 016063 5 ustar alastair alastair fortran-lang-fpm-90bb83a/ci/test_custom_build_dir.sh 0000775 0001750 0001750 00000006257 15145116760 023022 0 ustar alastair alastair #!/usr/bin/env bash
set -ex
# Test script for custom build directory functionality
# Usage: ./test_custom_build_dir.sh [fpm_executable] [example_package_dir]
if [ "$1" ]; then
fpm="$1"
else
fpm=fpm
fi
if [ "$2" ]; then
test_package="$2"
else
test_package="hello_world"
fi
echo "Testing custom build directory functionality with package: $test_package"
# Test 1: Custom build directory with CLI option
pushd "$test_package"
echo "Test 1: CLI option --build-dir"
rm -rf ./build custom_build_test
"$fpm" build --build-dir custom_build_test
test -d custom_build_test
test -f custom_build_test/.gitignore
"$fpm" run --build-dir custom_build_test --target "$test_package"
# Verify standard build directory was not created
test ! -d build
echo "✓ CLI option --build-dir works"
# Test 2: Environment variable
echo "Test 2: Environment variable FPM_BUILD_DIR"
rm -rf custom_build_test env_build_test
FPM_BUILD_DIR=env_build_test "$fpm" build
test -d env_build_test
test -f env_build_test/.gitignore
FPM_BUILD_DIR=env_build_test "$fpm" run --target "$test_package"
echo "✓ Environment variable FPM_BUILD_DIR works"
# Test 3: CLI option overrides environment variable
echo "Test 3: CLI option overrides environment variable"
rm -rf env_build_test cli_override_test
FPM_BUILD_DIR=env_build_test "$fpm" build --build-dir cli_override_test
test -d cli_override_test
test ! -d env_build_test
echo "✓ CLI option correctly overrides environment variable"
# Test 4: Build directory validation - reserved names
echo "Test 4: Build directory validation"
# These should fail with specific error messages
if "$fpm" build --build-dir src 2>&1 | grep -q "conflicts with source directory"; then
echo "✓ Correctly rejected 'src'"
else
echo "ERROR: Should reject 'src'" && exit 1
fi
if "$fpm" build --build-dir app 2>&1 | grep -q "conflicts with source directory"; then
echo "✓ Correctly rejected 'app'"
else
echo "ERROR: Should reject 'app'" && exit 1
fi
if "$fpm" build --build-dir test 2>&1 | grep -q "conflicts with source directory"; then
echo "✓ Correctly rejected 'test'"
else
echo "ERROR: Should reject 'test'" && exit 1
fi
if "$fpm" build --build-dir . 2>&1 | grep -q "would overwrite the current"; then
echo "✓ Correctly rejected '.'"
else
echo "ERROR: Should reject '.'" && exit 1
fi
# Test 5: Path normalization
echo "Test 5: Path normalization"
if "$fpm" build --build-dir ./src 2>&1 | grep -q "conflicts with source directory"; then
echo "✓ Correctly rejected './src' (path normalization works)"
else
echo "ERROR: Should reject './src'" && exit 1
fi
# Test 6: Different commands with custom build directory
echo "Test 6: Different commands with custom build directory"
rm -rf test_build_all
"$fpm" build --build-dir test_build_all
"$fpm" run --build-dir test_build_all --target "$test_package"
# Some packages may not have tests, so this might fail but that's expected
"$fpm" test --build-dir test_build_all 2>/dev/null || echo "No tests in $test_package (expected)"
echo "✓ All commands work with custom build directory"
# Cleanup test directories
rm -rf custom_build_test env_build_test cli_override_test test_build_all
popd
echo "All custom build directory tests passed!"
fortran-lang-fpm-90bb83a/ci/installer-icon.ico 0000664 0001750 0001750 00000041076 15145116760 021512 0 ustar alastair alastair @@ (B ( @ Pu#PssPsPsږOrOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOrOsٕPsNrrSq" Mw NsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPtPu# Nr\OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsNs[ Os~OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPr} Ps]OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOtZ Nq$OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsMt! OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOs Nq$OsOsOsOsOsOsOsǡOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPu#OrtOsOsOsOsOsOsOsǡOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsqOsOsOsOsOsOsOsOsǠOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOrOsܖOsOsOsOsOsOsOsŞOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsٖOrOsOsOsOsOsOsOs{ĜOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsbѲչؾӶpOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPt]OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOspOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsٿkOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOshOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsdOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsaOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOs_OsOsOsOsOsOsOsOsչOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֻ[}OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֺXzOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֺVxOsOsOsOsOsOsOsRvOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֺUwOsOsOsOsOsOsOshOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsչTwOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsչRvOsOsOsOsOsOsOsѲOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsոQuOsOsOsOsOsOsSvOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsոPtOsOsOsOsOsOsҴOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsԷOsOsOsOsRu}OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsԷ̩չOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsԷOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsԷOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsԷOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsԷOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsոOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsոQuQuarϯOsOsOsOsOsOsOsdέҴչչoOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsչQuOsOsOsOsOs[}OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsչQuOsOsOsOsOsOs^OsOsOsOsOsOsOsȣOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֺQuOsOsOsOsOsOsOsѲOsOsOsOsOsOsOsӵOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֺQuOsOsOsOsOsOsOs}OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֻQuOsOsOsOsOsOsOs]~OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsֻQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsPtOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsgOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsӴOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsٿOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsXzOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsٿQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOs˧OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOstOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsyOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsQuOsOsOsOsOsOsOsOsOsOsOsOsOsOsUw|ٿOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsgέέӴήέέέέչչչٿOsOsOsOsOsOsOsOsOrOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsNsݖOsOsOsOsOsOsOsOsOsOsOsOsOsOsPsڗOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPsNtuOsOsOsOsOsOsOsOsOsOsOsOsOsOsNrrLu%OsOsOsOsOsOsOsOsOsOsOsOsOsOsPu# PtOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOs Lu%OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsSq" Or^OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsNrb PtOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOs~ PsYOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPr` Rs OsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsPtLu% Lu%NtuOsOsۖOrOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOsOrOsۗOsOrtNq$ fortran-lang-fpm-90bb83a/ci/meta_tests.sh 0000775 0001750 0001750 00000002322 15145116760 020571 0 ustar alastair alastair #!/usr/bin/env bash
set -ex
# ***********************
# This script tests all example packages using any metapackage/system dependencies
# ***********************
cd "$(dirname $0)/.."
if [ "$1" ]; then
fpm="$1"
else
fpm=fpm
fi
# Build example packages
pushd example_packages/
rm -rf ./*/build
pushd metapackage_openmp
"$fpm" build --verbose
"$fpm" run --verbose
popd
pushd metapackage_stdlib
"$fpm" build --verbose
"$fpm" run --verbose
popd
pushd metapackage_minpack
"$fpm" build --verbose --flag " -Wno-external-argument-mismatch"
"$fpm" run --verbose --flag " -Wno-external-argument-mismatch"
popd
pushd metapackage_mpi
"$fpm" build --verbose
"$fpm" run --verbose
popd
pushd metapackage_mpi_c
"$fpm" build --verbose
"$fpm" run --verbose
popd
pushd metapackage_hdf5
"$fpm" build --verbose
"$fpm" run --verbose
popd
pushd metapackage_netcdf
"$fpm" build --verbose
"$fpm" run --verbose
popd
pushd metapackage_blas
"$fpm" build --verbose
"$fpm" run --verbose
popd
pushd metapackage_stdlib_extblas
"$fpm" build --verbose
"$fpm" run --verbose
popd
# Test metapackage propagation from dependencies (issue #1209)
pushd metapackage_dep_parent
"$fpm" build --verbose
"$fpm" run --verbose
popd
# Cleanup
rm -rf ./*/build
fortran-lang-fpm-90bb83a/ci/test_features.sh 0000775 0001750 0001750 00000036733 15145116760 021313 0 ustar alastair alastair #!/usr/bin/env bash
set -exo pipefail
# Test script for FPM features functionality
# Usage: ./test_features.sh [fpm_executable]
# Note: This script should be run from the repo root or integrated into run_tests.sh
if [ "$1" ]; then
fpm="$1"
else
# Default to the fpm passed from run_tests.sh or system fpm
fpm="${fpm:-fpm}"
fi
echo "Testing FPM features functionality"
echo "=== Testing features_demo package ==="
# Test 1: Basic features - debug feature
pushd "features_demo"
echo "Test 1: Basic debug feature"
rm -rf build
"$fpm" run --features debug > output.txt
grep -q "DEBUG mode enabled" output.txt || { echo "ERROR: DEBUG mode not enabled"; exit 1; }
echo "✓ Debug feature works"
# Test 2: Profile usage - development profile (includes debug)
echo "Test 2: Development profile (debug feature)"
rm -rf build
"$fpm" run --profile development --target features_demo > output.txt
grep -q "DEBUG mode enabled" output.txt || { echo "ERROR: DEBUG mode not enabled in development profile"; exit 1; }
echo "✓ Development profile works"
# Test 3: Multiple features
echo "Test 3: Multiple features (debug + openmp)"
rm -rf build
"$fpm" run --features debug,openmp --target features_demo > output.txt
grep -q "DEBUG mode enabled" output.txt || { echo "ERROR: DEBUG mode not enabled with multiple features"; exit 1; }
grep -q "OpenMP support enabled" output.txt || { echo "ERROR: OpenMP not enabled with multiple features"; exit 1; }
echo "✓ Multiple features work"
# Test 4: Feature-specific executable (debug_demo only available with debug feature)
echo "Test 4: Feature-specific executable"
rm -rf build
"$fpm" run --features debug --target debug_demo > output.txt
grep -q "Debug Demo Program" output.txt || { echo "ERROR: Debug Demo Program not found"; exit 1; }
grep -q "Debug mode: ON" output.txt || { echo "ERROR: Debug mode not ON in debug_demo"; exit 1; }
echo "✓ Feature-specific executable works"
# Test 5: Profile with multiple features - production profile (release + openmp)
echo "Test 5: Production profile (release + openmp)"
rm -rf build
"$fpm" run --profile production --target features_demo > output.txt
grep -q "RELEASE mode enabled" output.txt || { echo "ERROR: RELEASE mode not enabled in production profile"; exit 1; }
grep -q "OpenMP support enabled" output.txt || { echo "ERROR: OpenMP not enabled in production profile"; exit 1; }
# Should NOT have debug
if grep -q "DEBUG mode enabled" output.txt; then
echo "ERROR: DEBUG mode should not be enabled in production profile"
exit 1
fi
echo "✓ Production profile works"
# Test 6: No features - baseline behavior
echo "Test 6: No features (baseline)"
rm -rf build
"$fpm" run --target features_demo > output.txt
# Should have neither DEBUG nor RELEASE without explicit features
if grep -q "DEBUG mode enabled" output.txt; then
echo "ERROR: DEBUG mode should not be enabled in baseline"
exit 1
fi
if grep -q "RELEASE mode enabled" output.txt; then
echo "ERROR: RELEASE mode should not be enabled in baseline"
exit 1
fi
if ! grep -q "Features: NONE" output.txt && ! grep -q "Demo completed successfully" output.txt; then
echo "ERROR: Expected baseline features output not found"
exit 1
fi
echo "✓ Baseline (no features) works"
# Test 7: Error handling - invalid feature
echo "Test 7: Error handling for invalid feature"
rm -rf build
if ! "$fpm" run --features nonexistent --target features_demo > /dev/null 2>&1; then
echo "Correctly rejected invalid feature"
else
echo "ERROR: Should reject invalid feature" && exit 1
fi
# Test 8: Error handling - invalid profile
echo "Test 8: Error handling for invalid profile"
rm -rf build
if ! "$fpm" run --profile nonexistent --target features_demo > /dev/null 2>&1; then
echo "Correctly rejected invalid profile"
else
echo "ERROR: Should reject invalid profile" && exit 1
fi
# Test 9: Features and profile mutual exclusion
echo "Test 9: Features and profile mutual exclusion"
rm -rf build
if ! "$fpm" run --features debug --profile development --target features_demo > /dev/null 2>&1; then
echo "Correctly rejected features + profile combination"
else
echo "ERROR: Should reject features + profile combination" && exit 1
fi
# Cleanup
rm -rf build output.txt build_list.txt
popd
echo "=== Testing features_with_dependency package ==="
# Test dependency features
pushd "features_with_dependency"
# RE-ENABLE AFTER MERGING fpm WITH CPP PARSING PR
# Test 10: No features - should show NONE for both local and dependency
# echo "Test 10: Dependency package without features"
rm -rf build
#"$fpm" run | tee output.txt
# grep -q "NONE - no local features active" output.txt || { echo "ERROR: Local features NONE message not found"; exit 1; }
# grep -q "Features: NONE" output.txt || { echo "ERROR: Features NONE not found in dependency test"; exit 1; }
# echo "✓ Dependency package baseline works"
# Test 11: Debug dependency feature
echo "Test 11: Debug dependency feature"
rm -rf build
"$fpm" run --features with_feat_debug > output.txt
grep -q "WITH_DEBUG_DEPENDENCY" output.txt || { echo "ERROR: WITH_DEBUG_DEPENDENCY not found"; exit 1; }
grep -q "DEBUG mode enabled" output.txt || { echo "ERROR: DEBUG mode not enabled in dependency test"; exit 1; }
echo "✓ Debug dependency feature works"
# Test 12: Release dependency feature
echo "Test 12: Release dependency feature"
rm -rf build
"$fpm" run --features with_feat_release > output.txt
grep -q "WITH_RELEASE_DEPENDENCY" output.txt || { echo "ERROR: WITH_RELEASE_DEPENDENCY not found"; exit 1; }
grep -q "RELEASE mode enabled" output.txt || { echo "ERROR: RELEASE mode not enabled in dependency test"; exit 1; }
echo "✓ Release dependency feature works"
# Test 13: Multi dependency feature
echo "Test 13: Multi dependency feature"
rm -rf build
"$fpm" run --features with_feat_multi > output.txt
grep -q "WITH_MULTI_DEPENDENCY" output.txt || { echo "ERROR: WITH_MULTI_DEPENDENCY not found"; exit 1; }
grep -q "DEBUG mode enabled" output.txt || { echo "ERROR: DEBUG mode not enabled in multi dependency test"; exit 1; }
grep -q "MPI support enabled" output.txt || { echo "ERROR: MPI support not enabled in multi dependency test"; exit 1; }
echo "✓ Multi dependency feature works"
# Test 14: Profile with dependency features
echo "Test 14: Debug dependency profile"
rm -rf build
"$fpm" run --profile debug_dep > output.txt
grep -q "WITH_DEBUG_DEPENDENCY" output.txt || { echo "ERROR: WITH_DEBUG_DEPENDENCY not found in profile test"; exit 1; }
grep -q "DEBUG mode enabled" output.txt || { echo "ERROR: DEBUG mode not enabled in dependency profile test"; exit 1; }
echo "✓ Debug dependency profile works"
# Test 15: Dependency with profile (instead of features list)
# features_demo's "prof_feats" profile resolves to ["prof_feat1", "prof_feat2"],
# which sets the PROF_FEAT1 and PROF_FEAT2 macros
echo "Test 15: Dependency with profile"
rm -rf build
"$fpm" run --profile dep_profile > output.txt
grep -q "PROF_FEAT1 enabled" output.txt || { echo "ERROR: PROF_FEAT1 not enabled via dependency profile=prof_feats"; exit 1; }
grep -q "PROF_FEAT2 enabled" output.txt || { echo "ERROR: PROF_FEAT2 not enabled via dependency profile=prof_feats"; exit 1; }
echo "Dependency profile works"
# Cleanup
rm -rf build output.txt
popd
echo "=== Testing features_per_compiler package ==="
# Test features per compiler package
pushd "features_per_compiler"
# Test 15: Development profile (debug + verbose)
echo "Test 15: Features per compiler - development profile"
rm -rf build
if "$fpm" run --profile development > output.txt 2>&1; then
echo "✓ Exit code 0 (success) as expected"
else
echo "ERROR: Expected exit code 0 but got non-zero exit code"
echo "=== Program output ==="
cat output.txt
echo "======================"
exit 1
fi
grep -q "Features Per Compiler Demo" output.txt || { echo "ERROR: Features Per Compiler Demo not found"; exit 1; }
grep -q "✓ DEBUG: debug flags found" output.txt || { echo "ERROR: Debug feature not detected"; exit 1; }
grep -q "✓ VERBOSE: -v flag found" output.txt || { echo "ERROR: Verbose feature not detected"; exit 1; }
grep -q "✓ All compiler flag checks PASSED" output.txt || { echo "ERROR: Expected all checks to pass"; exit 1; }
# Check compiler-specific flags (will depend on detected compiler)
if grep -q "Detected compiler: gfortran" output.txt; then
grep -q "✓ Debug: -Wall found" output.txt || { echo "ERROR: gfortran debug flag -Wall not found"; exit 1; }
grep -q "✓ Debug: -fcheck=bounds found" output.txt || { echo "ERROR: gfortran debug flag -fcheck=bounds not found"; exit 1; }
fi
echo "✓ Development profile works"
# Test 16: Production profile (release + fast)
echo "Test 16: Features per compiler - production profile"
rm -rf build
if "$fpm" run --profile production > output.txt 2>&1; then
echo "✓ Exit code 0 (success) as expected"
else
echo "ERROR: Expected exit code 0 but got non-zero exit code"
echo "=== Program output ==="
cat output.txt
echo "======================"
exit 1
fi
grep -q "Features Per Compiler Demo" output.txt || { echo "ERROR: Features Per Compiler Demo not found"; exit 1; }
grep -q "✓ RELEASE: -O flags found" output.txt || { echo "ERROR: Release feature not detected"; exit 1; }
grep -q "✓ FAST: fast optimization flags found" output.txt || { echo "ERROR: Fast feature not detected"; exit 1; }
grep -q "✓ All compiler flag checks PASSED" output.txt || { echo "ERROR: Expected all checks to pass"; exit 1; }
# Check compiler-specific flags (will depend on detected compiler)
if grep -q "Detected compiler: gfortran" output.txt; then
# Check for -mtune flag (portable tuning flag)
grep -q "✓ Release: -mtune found" output.txt || { echo "ERROR: gfortran release flag -mtune not found"; exit 1; }
grep -q "✓ Fast: -ffast-math found" output.txt || { echo "ERROR: gfortran fast flag -ffast-math not found"; exit 1; }
fi
echo "✓ Production profile works"
# Test 17: Testing profile (debug + strict)
echo "Test 17: Features per compiler - testing profile"
rm -rf build
if "$fpm" run --profile testing > output.txt 2>&1; then
echo "✓ Exit code 0 (success) as expected"
else
echo "ERROR: Expected exit code 0 but got non-zero exit code"
echo "=== Program output ==="
cat output.txt
echo "======================"
exit 1
fi
grep -q "Features Per Compiler Demo" output.txt || { echo "ERROR: Features Per Compiler Demo not found"; exit 1; }
grep -q "✓ DEBUG: debug flags found" output.txt || { echo "ERROR: Debug feature not detected"; exit 1; }
grep -q "✓ STRICT: standard compliance flags found" output.txt || { echo "ERROR: Strict feature not detected"; exit 1; }
grep -q "✓ All compiler flag checks PASSED" output.txt || { echo "ERROR: Expected all checks to pass"; exit 1; }
# Check compiler-specific flags (will depend on detected compiler)
if grep -q "Detected compiler: gfortran" output.txt; then
grep -q "✓ Strict: -Wpedantic found" output.txt || { echo "ERROR: gfortran strict flag -Wpedantic not found"; exit 1; }
fi
echo "✓ Testing profile works"
# Test 18: Individual features - debug only
echo "Test 18: Features per compiler - debug feature only"
rm -rf build
if "$fpm" run --features debug > output.txt 2>&1; then
echo "✓ Exit code 0 (success) as expected"
else
echo "ERROR: Expected exit code 0 but got non-zero exit code"
echo "=== Program output ==="
cat output.txt
echo "======================"
exit 1
fi
grep -q "Features Per Compiler Demo" output.txt || { echo "ERROR: Features Per Compiler Demo not found"; exit 1; }
grep -q "✓ DEBUG: debug flags found" output.txt || { echo "ERROR: Debug feature not detected"; exit 1; }
grep -q "✓ All compiler flag checks PASSED" output.txt || { echo "ERROR: Expected all checks to pass"; exit 1; }
# Should NOT have release or fast flags
if grep -q "✓ RELEASE: -O flags found" output.txt; then
echo "ERROR: Release flags should not be present with debug only"
exit 1
fi
echo "✓ Debug feature works"
# Test 19: Individual features - release only
echo "Test 19: Features per compiler - release feature only"
rm -rf build
if "$fpm" run --features release > output.txt 2>&1; then
echo "✓ Exit code 0 (success) as expected"
else
echo "ERROR: Expected exit code 0 but got non-zero exit code"
echo "=== Program output ==="
cat output.txt
echo "======================"
exit 1
fi
grep -q "Features Per Compiler Demo" output.txt || { echo "ERROR: Features Per Compiler Demo not found"; exit 1; }
grep -q "✓ RELEASE: -O flags found" output.txt || { echo "ERROR: Release feature not detected"; exit 1; }
grep -q "✓ All compiler flag checks PASSED" output.txt || { echo "ERROR: Expected all checks to pass"; exit 1; }
# Should NOT have debug flags
if grep -q "✓ DEBUG: debug flags found" output.txt; then
echo "ERROR: Debug flags should not be present with release only"
exit 1
fi
echo "✓ Release feature works"
# Test 20: No profile/features - baseline
echo "Test 20: Features per compiler - baseline (no profile)"
rm -rf build
if "$fpm" run > output.txt 2>&1; then
echo "✓ Exit code 0 (success) as expected"
else
echo "ERROR: Expected exit code 0 but got non-zero exit code"
echo "=== Program output ==="
cat output.txt
echo "======================"
exit 1
fi
grep -q "Features Per Compiler Demo" output.txt || { echo "ERROR: Features Per Compiler Demo not found"; exit 1; }
grep -q "✓ All compiler flag checks PASSED" output.txt || { echo "ERROR: Expected all checks to pass"; exit 1; }
# Should NOT have any feature flags in baseline
if grep -q "✓ DEBUG: debug flags found" output.txt; then
echo "ERROR: Debug flags should not be present in baseline"
exit 1
fi
if grep -q "✓ RELEASE: -O flags found" output.txt; then
echo "ERROR: Release flags should not be present in baseline"
exit 1
fi
echo "✓ Baseline (no profile) works"
# Cleanup
rm -rf build output.txt
popd
echo "=== Testing features_default_profile package ==="
pushd "features_default_profile"
# Test: --profile debug should include default (baseline) + debug features
echo "Test: Default profile with --profile debug"
rm -rf build
"$fpm" run --profile debug > output.txt
grep -q "BASELINE active" output.txt || { echo "ERROR: BASELINE not active with --profile debug"; exit 1; }
grep -q "DEBUG active" output.txt || { echo "ERROR: DEBUG not active with --profile debug"; exit 1; }
echo "Default + debug profile works"
# Test: --profile release should include default (baseline) + release features
echo "Test: Default profile with --profile release"
rm -rf build
"$fpm" run --profile release > output.txt
grep -q "BASELINE active" output.txt || { echo "ERROR: BASELINE not active with --profile release"; exit 1; }
grep -q "RELEASE active" output.txt || { echo "ERROR: RELEASE not active with --profile release"; exit 1; }
echo "Default + release profile works"
# Test: --profile myprofile (custom) should NOT include default features
echo "Test: Custom profile skips default features"
rm -rf build
"$fpm" run --profile myprofile > output.txt
grep -q "CUSTOM active" output.txt || { echo "ERROR: CUSTOM not active with --profile myprofile"; exit 1; }
if grep -q "BASELINE active" output.txt; then
echo "ERROR: BASELINE should NOT be active with custom profile"
exit 1
fi
echo "Custom profile correctly skips default"
# Test: no profile (implicit debug) should include default features
echo "Test: No profile includes default features"
rm -rf build
"$fpm" run > output.txt
grep -q "BASELINE active" output.txt || { echo "ERROR: BASELINE not active with no explicit profile"; exit 1; }
echo "Implicit build includes default features"
# Cleanup
rm -rf build output.txt
popd
echo "All FPM features tests passed!"
fortran-lang-fpm-90bb83a/ci/fpm-installer.nsi 0000664 0001750 0001750 00000005215 15145116760 021356 0 ustar alastair alastair ; NSIS Installer script for the Fortran Package Manager
; ---------------- Properties ----------------
; Name used in installer GUI
Name "Fortran Package Manager"
; Name for folder location and reg key
!define INSTALL_NAME "fortran-lang"
; Installer icon
!define MUI_ICON "installer-icon.ico"
; Compress installer
SetCompress auto
; Always produce unicode installer
Unicode true
; ---------------- Setup ----------------
; Use EnVar plugin (https://nsis.sourceforge.io/EnVar_plug-in)
!addplugindir ".\EnVar_plugin\Plugins\x86-unicode"
; Use the 'Modern' Installer UI macros
!include "MUI2.nsh"
; Default installation folder (local)
InstallDir "$LOCALAPPDATA\${INSTALL_NAME}"
; Get installation folder from registry if available
InstallDirRegKey HKCU "Software\${INSTALL_NAME}" ""
; Request application privileges
RequestExecutionLevel user
; ---------------- Installer Pages ----------------
!insertmacro MUI_PAGE_COMPONENTS
!insertmacro MUI_PAGE_DIRECTORY
!insertmacro MUI_PAGE_INSTFILES
; ---------------- Uninstaller Pages ----------------
!insertmacro MUI_UNPAGE_CONFIRM
!insertmacro MUI_UNPAGE_INSTFILES
; MUI Language
!insertmacro MUI_LANGUAGE "English"
; ---------------- Component: Core Installation ----------------
Section "-Core" SecCore
SetOutPath "$INSTDIR"
; Store installation folder
WriteRegStr HKCU "Software\${INSTALL_NAME}" "" $INSTDIR
; Create uninstaller
WriteUninstaller "$INSTDIR\Uninstall.exe"
; Add to path
EnVar::SetHKCU
EnVar::AddValue "PATH" "$INSTDIR\fpm"
EnVar::AddValue "PATH" "$INSTDIR\MinGit\mingw64\bin"
SectionEnd
; ---------------- Component: fpm ----------------
Section "FPM" SecFPM
SetOutPath "$INSTDIR\fpm"
File "fpm.exe"
SectionEnd
; ---------------- Component: Git ----------------
Section "Git for Windows" SecGit
SetOutPath "$INSTDIR"
File /r "MinGit"
SectionEnd
; ---------------- Uninstaller ----------------
Section "Uninstall"
RMDir /r "$INSTDIR"
DeleteRegKey /ifempty HKCU "Software\${INSTALL_NAME}"
EnVar::SetHKCU
EnVar::DeleteValue "PATH" "$INSTDIR\fpm"
EnVar::DeleteValue "PATH" "$INSTDIR\MinGit\mingw64\bin"
SectionEnd
; ---------------- Component description Strings (EN) ----------------
LangString DESC_SecFPM ${LANG_ENGLISH} "The Fortran Package Manager"
LangString DESC_SecGit ${LANG_ENGLISH} "Git version control (required for FPM)"
!insertmacro MUI_FUNCTION_DESCRIPTION_BEGIN
!insertmacro MUI_DESCRIPTION_TEXT ${SecFPM} $(DESC_SecFPM)
!insertmacro MUI_DESCRIPTION_TEXT ${SecGit} $(DESC_SecGit)
!insertmacro MUI_FUNCTION_DESCRIPTION_END
fortran-lang-fpm-90bb83a/ci/run_tests.sh 0000775 0001750 0001750 00000015607 15145116760 020461 0 ustar alastair alastair #!/usr/bin/env bash
set -ex
cd "$(dirname $0)/.."
if [ "$1" ]; then
fpm="$1"
else
fpm=fpm
fi
# Build example packages
pushd example_packages/
rm -rf ./*/build
dir=hello_world
"$fpm" -C $dir build
"$fpm" -C $dir run --target hello_world
"$fpm" -C $dir/app run
pushd hello_fpm
"$fpm" build
"$fpm" run --target hello_fpm
popd
pushd circular_test
"$fpm" build
popd
pushd circular_example
"$fpm" build
popd
pushd nonintrinsic
"$fpm" build
popd
pushd hello_complex
"$fpm" build
"$fpm" test
"$fpm" run --target say_Hello
"$fpm" run --target say_goodbye
"$fpm" test --target greet_test
"$fpm" test --target farewell_test
popd
pushd hello_complex_2
"$fpm" build
"$fpm" run --target say_hello_world
"$fpm" run --target say_goodbye
"$fpm" test --target greet_test
"$fpm" test --target farewell_test
popd
pushd with_examples
"$fpm" build
"$fpm" run --example --target demo-prog
"$fpm" run --target demo-prog
popd
pushd many_examples
"$fpm" run --example --all
test -e demo1.txt
test -e demo2.txt
popd
# Test building individual targets
pushd many_targets
cases=( "1" "2" "3" )
targets=( "run" "example" "test" )
cmdrun=( "run --target" "run --example" "test --target" )
for j in {0..2}
do
for i in {0..2}
do
rm -f *.txt
this=${cases[$i]}
others=${cases[@]/$this}
filename=${targets[$j]}$this
echo "$filename"
"$fpm" ${cmdrun[$j]} $filename
test -e $filename.txt
# non-i-th tests should not have run
for k in ${others[@]}
do
test ! -e ${targets[$k]}$k.txt
done
done
done
# Test building all targets and with runner
if [[ "$(which time)" ]]; then
targets=( "run" "run --example" "test" )
names=( "run" "example" "test" )
cmdrun=( " " " --runner time" )
for j in {0..2}
do
for i in {0..1}
do
rm -f *.txt
"$fpm" ${targets[$j]}${cmdrun[$i]}
# all targets should have run
for k in ${cases[@]}
do
test -e ${names[$j]}$k.txt
done
done
done
fi
popd
pushd auto_discovery_off
"$fpm" build
"$fpm" run --target auto_discovery_off
"$fpm" test --target my_test
test ! -x ./build/gfortran_*/app/unused
test ! -x ./build/gfortran_*/test/unused_test
popd
pushd auto_with_nondefault_main
"$fpm" build
"$fpm" install --prefix=./installed
test -x ./installed/bin/non_default_name
popd
pushd tree_shake
"$fpm" build
"$fpm" run
"$fpm" test
test ! -e ./build/gfortran_*/tree_shake/src_farewell_m.f90.o
test ! -e ./build/gfortran_*/tree_shake/src_farewell_m.f90.o.log
popd
pushd submodule_tree_shake
"$fpm" run
test ! -e ./build/gfortran_*/submodule_tree_shake/src_parent_unused.f90.o
test ! -e ./build/gfortran_*/submodule_tree_shake/src_parent_unused.f90.o.log
test ! -e ./build/gfortran_*/submodule_tree_shake/src_child_unused.f90.o
test ! -e ./build/gfortran_*/submodule_tree_shake/src_child_unused.f90.o.log
popd
pushd version_file
"$fpm" build
"$fpm" run
popd
pushd with_c
"$fpm" build
"$fpm" run --target with_c
popd
pushd submodules
"$fpm" build
popd
pushd app_with_submodule
"$fpm" run --all
popd
pushd program_with_module
"$fpm" build
"$fpm" run --target Program_with_module
popd
pushd program_with_cpp_guarded_module
"$fpm" build
"$fpm" run
popd
pushd link_executable
"$fpm" build
"$fpm" run --target gomp_test
popd
pushd fortran_includes
"$fpm" build
popd
pushd c_includes
"$fpm" build
popd
pushd c_header_only
"$fpm" build
popd
pushd c_main
"$fpm" run
popd
pushd c_main_preprocess
"$fpm" build --c-flag "-DVAL"
popd
pushd app_with_c
"$fpm" run
popd
pushd hello_fpm_path
"$fpm" run
popd
pushd preprocess_cpp
"$fpm" build
popd
pushd preprocess_cpp_c
"$fpm" run
popd
pushd preprocess_cpp_deps
"$fpm" build
popd
pushd preprocess_cpp_suffix
"$fpm" run
popd
pushd preprocess_per_dependency
"$fpm" run
popd
pushd preprocess_hello
"$fpm" build
popd
pushd fpm_test_exe_issues
"$fpm" build
popd
pushd cpp_files
"$fpm" test --verbose
popd
# Test Fortran features
for feature in free-form fixed-form implicit-typing implicit-external
do
pushd $feature
"$fpm" run
popd
done
# Test app exit codes
pushd fpm_test_exit_code
"$fpm" build
# odd number -> success!
EXIT_CODE=0
"$fpm" run -- 1 || EXIT_CODE=$?
test $EXIT_CODE -eq 0
# even number -> error 3
EXIT_CODE=0
"$fpm" run -- 512 || EXIT_CODE=$?
test $EXIT_CODE -eq 3
# even number -> error 3
EXIT_CODE=0
"$fpm" run -- 0 || EXIT_CODE=$?
test $EXIT_CODE -eq 3
# not an integer -> error 2
EXIT_CODE=0
"$fpm" run -- 3.1415 || EXIT_CODE=$?
if [[ "$FPM_FC" == "ifx" ]]; then
test $EXIT_CODE -eq 0 # ifx does not return error code on non-integer input
else
test $EXIT_CODE -eq 2
fi
# not a number -> error 2
EXIT_CODE=0
"$fpm" run -- notanumber || EXIT_CODE=$?
test $EXIT_CODE -eq 2
# no arguments -> error 1
EXIT_CODE=0
"$fpm" run || EXIT_CODE=$?
test $EXIT_CODE -eq 1
popd
# test dependency priority
pushd dependency_priority
# first build should run OK
EXIT_CODE=0
"$fpm" run || EXIT_CODE=$?
test $EXIT_CODE -eq 0
"$fpm" build --verbose
# Build again, should update nothing
"$fpm" build --verbose > build.log
if [[ -n "$(grep Update build.log)" ]]; then
echo "Some dependencies were updated that should not be";
exit 1;
fi
# Request update --clean, should update all dependencies
"$fpm" update --clean --verbose > update.log
if [[ -z "$(grep Update update.log)" ]]; then
echo "No updated dependencies after 'fpm update --clean'";
exit 1;
fi
# Test that no files are lost during multiple `install`s
# including overwriting the same install
"$fpm" install --prefix a
"$fpm" install --prefix a
"$fpm" install --prefix a
"$fpm" install --prefix b
"$fpm" install --prefix c
popd
# Test shared library dependencies
pushd shared_lib
"$fpm" build --verbose || EXIT_CODE=$?
test $EXIT_CODE -eq 0
popd
pushd shared_lib_extra
"$fpm" build || EXIT_CODE=$?
test $EXIT_CODE -eq 0
popd
pushd shared_lib_empty
"$fpm" build
"$fpm" run
"$fpm" test
popd
pushd static_lib_empty
"$fpm" build
"$fpm" run
"$fpm" test
popd
pushd shared_app_only
"$fpm" test || EXIT_CODE=$?
test $EXIT_CODE -eq 0
popd
# Static library dependencies
pushd static_app_only
"$fpm" test || EXIT_CODE=$?
test $EXIT_CODE -eq 0
popd
# Test custom module directory
pushd custom_module_dir
"$fpm" build
rm -rf ./test_custom_install
"$fpm" install --prefix ./test_custom_install
# Verify modules are installed in custom directory
test -f ./test_custom_install/custom_modules/greeting.mod
test -f ./test_custom_install/custom_modules/math_utils.mod
# Verify library is still installed normally
test -f ./test_custom_install/lib/libcustom-module-dir.a
# Clean up
rm -rf ./test_custom_install
popd
# Test both shared and static library types
pushd both_lib_types
"$fpm" build
"$fpm" install --prefix=.
# Check that exactly 2 libboth_lib_types library files were installed
test $(ls lib/libboth_lib_types* | wc -l) -eq 2
popd
# Test custom build directory functionality
bash "../ci/test_custom_build_dir.sh" "$fpm" hello_world
# Test FPM features functionality
echo "=== Testing FPM Features Functionality ==="
bash "../ci/test_features.sh" "$fpm"
# Cleanup
rm -rf ./*/build
fortran-lang-fpm-90bb83a/ci/single-file.patch 0000664 0001750 0001750 00000001205 15145116760 021300 0 ustar alastair alastair diff --git a/fpm.toml b/fpm.toml
index 51faa0e9..273e8e0e 100644
--- a/fpm.toml
+++ b/fpm.toml
@@ -17,23 +17,5 @@ M_CLI2.rev = "7264878cdb1baff7323cc48596d829ccfe7751b8"
jonquil.git = "https://github.com/toml-f/jonquil"
jonquil.rev = "05d30818bb12fb877226ce284b9a3a41b971a889"
-[[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"
-
+[build]
+auto-tests = false
fortran-lang-fpm-90bb83a/ci/single-file-gfortran.sh 0000775 0001750 0001750 00000000414 15145116760 022437 0 ustar alastair alastair #!/usr/bin/env bash
output="${OUTPUT:-fpm-single-file.F90}"
args=("$@")
file=$(printf "%s\n" "${args[@]}" | grep -P '^.+\.[fF]90$')
if [ $? = 0 ]; then
echo " + Appending source file '$file' to '${output}'"
cat $file >> "${output}"
fi
exec gfortran "${args[@]}"
fortran-lang-fpm-90bb83a/LICENSE 0000664 0001750 0001750 00000002061 15145116760 016474 0 ustar alastair alastair MIT License
Copyright (c) 2020 fpm contributors
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.