diff --git a/.github/workflows/meta.yml b/.github/workflows/meta.yml index 773978caea..411437d6b8 100644 --- a/.github/workflows/meta.yml +++ b/.github/workflows/meta.yml @@ -67,6 +67,7 @@ jobs: wget unzip curl + hdf5 - name: (Windows) Setup VS Build environment if: contains(matrix.os,'windows') && contains(matrix.mpi,'intel') @@ -93,12 +94,12 @@ jobs: - name: (Ubuntu) Install OpenMPI if: contains(matrix.os,'ubuntu') && contains(matrix.mpi,'openmpi') run: | - sudo apt install -y -q openmpi-bin libopenmpi-dev + sudo apt install -y -q openmpi-bin libopenmpi-dev hwloc fabric libhdf5-dev libhdf5-fortran-102 - name: (Ubuntu) Install MPICH if: contains(matrix.os,'ubuntu') && contains(matrix.mpi,'mpich') run: | - sudo apt install -y -q mpich + sudo apt install -y -q mpich hwloc fabric libhdf5-dev libhdf5-fortran-102 - name: (Ubuntu) Retrieve Intel toolchain if: contains(matrix.os,'ubuntu') && contains(matrix.mpi,'intel') @@ -110,14 +111,27 @@ jobs: - name: (Ubuntu) Install Intel oneAPI if: contains(matrix.os,'ubuntu') && contains(matrix.mpi,'intel') - timeout-minutes: 15 - run: sudo apt-get install intel-oneapi-compiler-dpcpp-cpp-2023.1.0 intel-oneapi-compiler-fortran-2023.1.0 intel-oneapi-mpi-devel ninja-build + uses: fortran-lang/setup-fortran@v1.6.1 + id: setup-fortran + with: + compiler: intel + version: 2024.1.0 - - name: (Ubuntu) Setup Intel oneAPI environment + - name: (Ubuntu) finalize oneAPI environment if: contains(matrix.os,'ubuntu') && contains(matrix.mpi,'intel') run: | - source /opt/intel/oneapi/setvars.sh - printenv >> $GITHUB_ENV + # Install MPI + sudo apt-get install -y -q intel-oneapi-mpi-devel ninja-build cmake + source /opt/intel/oneapi/setvars.sh --force + printenv >> $GITHUB_ENV + # To run HDF5 with oneAPI, we need to build it from source. Use CMake to generate pkg-config info + 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 + 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 + sudo make install - name: (Windows) Put MSYS2_MinGW64 on PATH if: contains(matrix.os,'windows') && (!contains(matrix.mpi,'intel')) @@ -197,6 +211,11 @@ jobs: run: | brew install openmpi #--cc=gcc-${{ env.GCC_V }} openmpi + - name: (macOS) Install homebrew HDF5 + if: contains(matrix.os,'macos') + run: | + brew install hdf5 + # Phase 1: Bootstrap fpm with existing version - name: Install fpm uses: fortran-lang/setup-fpm@v5 @@ -209,8 +228,8 @@ jobs: mv $(which fpm) fpm-bootstrap${{ matrix.exe }} echo "BOOTSTRAP=$PWD/fpm-bootstrap" >> $GITHUB_ENV - - name: (macOS) Use gcc/g++ instead of Clang for C/C++ - if: contains(matrix.os,'macOS') + - 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 diff --git a/ci/meta_tests.sh b/ci/meta_tests.sh index c2911d2737..d9749bb511 100755 --- a/ci/meta_tests.sh +++ b/ci/meta_tests.sh @@ -42,5 +42,10 @@ pushd metapackage_mpi_c "$fpm" run --verbose popd +pushd metapackage_hdf5 +"$fpm" build --verbose +"$fpm" run --verbose +popd + # Cleanup rm -rf ./*/build diff --git a/example_packages/metapackage_hdf5/app/main.f90 b/example_packages/metapackage_hdf5/app/main.f90 new file mode 100644 index 0000000000..3735a3e525 --- /dev/null +++ b/example_packages/metapackage_hdf5/app/main.f90 @@ -0,0 +1,15 @@ +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 diff --git a/example_packages/metapackage_hdf5/fpm.toml b/example_packages/metapackage_hdf5/fpm.toml new file mode 100644 index 0000000000..5a7d2f12b4 --- /dev/null +++ b/example_packages/metapackage_hdf5/fpm.toml @@ -0,0 +1,2 @@ +name = "metapackage_hdf5" +dependencies.hdf5="*" diff --git a/src/fpm/manifest/meta.f90 b/src/fpm/manifest/meta.f90 index 3719067030..d942a25a16 100644 --- a/src/fpm/manifest/meta.f90 +++ b/src/fpm/manifest/meta.f90 @@ -48,6 +48,9 @@ module fpm_manifest_metapackages !> fortran-lang minpack type(metapackage_request_t) :: minpack + + !> HDF5 + type(metapackage_request_t) :: hdf5 end type metapackage_config_t @@ -196,6 +199,9 @@ subroutine new_meta_config(self, table, meta_allowed, error) 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 end subroutine new_meta_config @@ -208,7 +214,7 @@ logical function is_meta_package(key) select case (key) !> Supported metapackages - case ("openmp","stdlib","mpi","minpack") + case ("openmp","stdlib","mpi","minpack","hdf5") is_meta_package = .true. case default diff --git a/src/fpm/manifest/profiles.f90 b/src/fpm/manifest/profiles.f90 index f50cf32cff..6b139910d9 100644 --- a/src/fpm/manifest/profiles.f90 +++ b/src/fpm/manifest/profiles.f90 @@ -749,25 +749,25 @@ function get_default_profiles(error) result(default_profiles) & 'ifort', & & OS_ALL, & & flags = ' -fp-model precise -pc64 -align all -error-limit 1 -reentrancy& - & threaded -nogen-interfaces -assume byterecl -standard-semantics', & + & threaded -nogen-interfaces -assume byterecl', & & is_built_in=.true.), & & new_profile('release', & & 'ifort', & & OS_WINDOWS, & & flags = ' /fp:precise /align:all /error-limit:1 /reentrancy:threaded& - & /nogen-interfaces /assume:byterecl /standard-semantics', & + & /nogen-interfaces /assume:byterecl', & & is_built_in=.true.), & & new_profile('release', & & 'ifx', & & OS_ALL, & & flags = ' -fp-model=precise -pc64 -align all -error-limit 1 -reentrancy& - & threaded -nogen-interfaces -assume byterecl -standard-semantics', & + & threaded -nogen-interfaces -assume byterecl', & & is_built_in=.true.), & & new_profile('release', & & 'ifx', & & OS_WINDOWS, & & flags = ' /fp:precise /align:all /error-limit:1 /reentrancy:threaded& - & /nogen-interfaces /assume:byterecl /standard-semantics', & + & /nogen-interfaces /assume:byterecl', & & is_built_in=.true.), & & new_profile('release', & &'nagfor', & @@ -805,28 +805,28 @@ function get_default_profiles(error) result(default_profiles) & new_profile('debug', & & 'ifort', & & OS_ALL, & - & flags = ' -warn all -check all -error-limit 1 -O0 -g -assume byterecl -standard-semantics -traceback', & + & flags = ' -warn all -check all -error-limit 1 -O0 -g -assume byterecl -traceback', & & is_built_in=.true.), & & new_profile('debug', & & 'ifort', & & OS_WINDOWS, & & flags = ' /warn:all /check:all /error-limit:1& - & /Od /Z7 /assume:byterecl /standard-semantics /traceback', & + & /Od /Z7 /assume:byterecl /traceback', & & is_built_in=.true.), & & new_profile('debug', & & 'ifx', & & OS_ALL, & - & flags = ' -warn all -check all -error-limit 1 -O0 -g -assume byterecl -standard-semantics -traceback', & + & flags = ' -warn all -check all -error-limit 1 -O0 -g -assume byterecl -traceback', & & is_built_in=.true.), & & new_profile('debug', & & 'ifx', & & OS_WINDOWS, & - & flags = ' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl /standard-semantics', & + & flags = ' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl', & & is_built_in=.true.), & & new_profile('debug', & & 'ifx', & & OS_WINDOWS, & - & flags = ' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl /standard-semantics', & + & flags = ' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl', & & is_built_in=.true.), & & new_profile('debug', & & 'lfortran', & diff --git a/src/fpm_compiler.F90 b/src/fpm_compiler.F90 index 718843a3eb..5928ee2fd1 100644 --- a/src/fpm_compiler.F90 +++ b/src/fpm_compiler.F90 @@ -309,8 +309,7 @@ subroutine get_release_compile_flags(id, flags) flag_intel_limit//& flag_intel_pthread//& flag_intel_nogen//& - flag_intel_byterecl//& - flag_intel_standard_compliance + flag_intel_byterecl case(id_intel_classic_mac) flags = & @@ -320,8 +319,7 @@ subroutine get_release_compile_flags(id, flags) flag_intel_limit//& flag_intel_pthread//& flag_intel_nogen//& - flag_intel_byterecl//& - flag_intel_standard_compliance + flag_intel_byterecl case(id_intel_classic_windows) flags = & @@ -331,8 +329,7 @@ subroutine get_release_compile_flags(id, flags) flag_intel_limit_win//& flag_intel_pthread_win//& flag_intel_nogen_win//& - flag_intel_byterecl_win//& - flag_intel_standard_compliance_win + flag_intel_byterecl_win case(id_intel_llvm_nix) flags = & @@ -342,8 +339,7 @@ subroutine get_release_compile_flags(id, flags) flag_intel_limit//& flag_intel_pthread//& flag_intel_nogen//& - flag_intel_byterecl//& - flag_intel_standard_compliance + flag_intel_byterecl case(id_intel_llvm_windows) flags = & @@ -353,8 +349,7 @@ subroutine get_release_compile_flags(id, flags) flag_intel_limit_win//& flag_intel_pthread_win//& flag_intel_nogen_win//& - flag_intel_byterecl_win//& - flag_intel_standard_compliance_win + flag_intel_byterecl_win case(id_nag) flags = & @@ -418,7 +413,6 @@ subroutine get_debug_compile_flags(id, flags) flag_intel_limit//& flag_intel_debug//& flag_intel_byterecl//& - flag_intel_standard_compliance//& flag_intel_backtrace case(id_intel_classic_mac) @@ -428,7 +422,6 @@ subroutine get_debug_compile_flags(id, flags) flag_intel_limit//& flag_intel_debug//& flag_intel_byterecl//& - flag_intel_standard_compliance//& flag_intel_backtrace case(id_intel_classic_windows) flags = & @@ -437,7 +430,6 @@ subroutine get_debug_compile_flags(id, flags) flag_intel_limit_win//& flag_intel_debug_win//& flag_intel_byterecl_win//& - flag_intel_standard_compliance_win//& flag_intel_backtrace_win case(id_intel_llvm_nix) flags = & @@ -446,7 +438,6 @@ subroutine get_debug_compile_flags(id, flags) flag_intel_limit//& flag_intel_debug//& flag_intel_byterecl//& - flag_intel_standard_compliance//& flag_intel_backtrace case(id_intel_llvm_windows) flags = & @@ -454,8 +445,7 @@ subroutine get_debug_compile_flags(id, flags) flag_intel_check_win//& flag_intel_limit_win//& flag_intel_debug_win//& - flag_intel_byterecl_win//& - flag_intel_standard_compliance_win + flag_intel_byterecl_win case(id_nag) flags = & flag_nag_debug//& diff --git a/src/fpm_environment.c b/src/fpm_environment.c new file mode 100644 index 0000000000..34a3140840 --- /dev/null +++ b/src/fpm_environment.c @@ -0,0 +1,38 @@ +#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 +} diff --git a/src/fpm_environment.f90 b/src/fpm_environment.f90 index aba65e77bd..cea8a633e5 100644 --- a/src/fpm_environment.f90 +++ b/src/fpm_environment.f90 @@ -6,14 +6,18 @@ 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 implicit none private public :: get_os_type public :: os_is_unix public :: get_env + public :: set_env + public :: delete_env public :: get_command_arguments_quoted public :: separator + public :: OS_NAME integer, parameter, public :: OS_UNKNOWN = 0 @@ -338,4 +342,99 @@ function separator() result(sep) 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 + 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 diff --git a/src/fpm_meta.f90 b/src/fpm_meta.f90 index 3265b26e47..59d205970d 100644 --- a/src/fpm_meta.f90 +++ b/src/fpm_meta.f90 @@ -9,6 +9,7 @@ !> !> - OpenMP !> - MPI +!> - HDF5 !> - fortran-lang stdlib !> - fortran-lang minpack !> @@ -26,10 +27,11 @@ module fpm_meta use fpm_manifest_dependency, only: dependency_config_t use fpm_git, only : git_target_branch, git_target_tag use fpm_manifest, only: package_config_t -use fpm_environment, only: get_env,os_is_unix +use fpm_environment, only: get_env,os_is_unix,set_env,delete_env use fpm_filesystem, only: run, get_temp_filename, getline, exists, canon_path, is_dir, get_dos_path use fpm_versioning, only: version_t, new_version, regex_version_from_text use fpm_os, only: get_absolute_path +use fpm_pkg_config use shlex_module, only: shlex_split => split use regex_module, only: regex use iso_fortran_env, only: stdout => output_unit @@ -170,6 +172,7 @@ subroutine init_from_name(this,name,compiler,error) case("stdlib"); call init_stdlib (this,compiler,error) case("minpack"); call init_minpack(this,compiler,error) case("mpi"); call init_mpi (this,compiler,error) + case("hdf5"); call init_hdf5 (this,compiler,error) case default call syntax_error(error, "Package "//name//" is not supported in [metapackages]") return @@ -326,7 +329,7 @@ subroutine resolve_model(self,model,error) if (self%has_cxx_flags) model%cxx_compile_flags = model%cxx_compile_flags//self%cxxflags%s if (self%has_link_flags) then - model%link_flags = model%link_flags//self%link_flags%s + model%link_flags = model%link_flags//' '//self%link_flags%s end if if (self%has_link_libraries) then @@ -454,13 +457,12 @@ subroutine resolve_metapackage_model(model,package,settings,error) if (allocated(error)) return endif - ! stdlib + ! minpack if (package%meta%minpack%on) then call add_metapackage_model(model,package,settings,"minpack",error) if (allocated(error)) return endif - ! Stdlib is not 100% thread safe. print a warning to the user if (package%meta%stdlib%on .and. package%meta%openmp%on) then write(stdout,'(a)')' both openmp and stdlib requested: some functions may not be thread-safe!' @@ -472,6 +474,12 @@ subroutine resolve_metapackage_model(model,package,settings,error) if (allocated(error)) return endif + ! hdf5 + if (package%meta%hdf5%on) then + call add_metapackage_model(model,package,settings,"hdf5",error) + if (allocated(error)) return + endif + end subroutine resolve_metapackage_model !> Initialize MPI metapackage for the current system @@ -1267,95 +1275,6 @@ subroutine assert_mpi_wrappers(wrappers,compiler,verbose) end subroutine assert_mpi_wrappers -!> Simple call to execute_command_line involving one mpi* wrapper -subroutine run_mpi_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 MPI wrapper') - endif - - end if - -end subroutine run_mpi_wrapper - !> 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 @@ -1371,7 +1290,7 @@ integer function which_mpi_library(wrapper,compiler,verbose) if (len_trim(wrapper)<=0) return ! Run mpi wrapper first - call run_mpi_wrapper(wrapper,verbose=verbose,cmd_success=is_mpi_wrapper) + call run_wrapper(wrapper,verbose=verbose,cmd_success=is_mpi_wrapper) if (is_mpi_wrapper) then @@ -1383,7 +1302,7 @@ integer function which_mpi_library(wrapper,compiler,verbose) ! Attempt to decipher which library this wrapper comes from. ! OpenMPI responds to '--showme' calls - call run_mpi_wrapper(wrapper,[string_t('--showme')],verbose,& + 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 @@ -1391,7 +1310,7 @@ integer function which_mpi_library(wrapper,compiler,verbose) endif ! MPICH responds to '-show' calls - call run_mpi_wrapper(wrapper,[string_t('-show')],verbose,& + 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 @@ -1432,7 +1351,7 @@ type(string_t) function mpi_wrapper_query(mpilib,wrapper,command,verbose,error) return end select - call run_mpi_wrapper(wrapper,[cmdstr],verbose=verbose, & + call run_wrapper(wrapper,[cmdstr],verbose=verbose, & exitcode=stat,cmd_success=success,screen_output=screen) if (stat/=0 .or. .not.success) then @@ -1458,7 +1377,7 @@ type(string_t) function mpi_wrapper_query(mpilib,wrapper,command,verbose,error) return end select - call run_mpi_wrapper(wrapper,[cmdstr],verbose=verbose, & + call run_wrapper(wrapper,[cmdstr],verbose=verbose, & exitcode=stat,cmd_success=success,screen_output=screen) if (stat/=0 .or. .not.success) then @@ -1495,7 +1414,7 @@ type(string_t) function mpi_wrapper_query(mpilib,wrapper,command,verbose,error) return end select - call run_mpi_wrapper(wrapper,[cmdstr],verbose=verbose, & + call run_wrapper(wrapper,[cmdstr],verbose=verbose, & exitcode=stat,cmd_success=success,screen_output=screen) if (stat/=0 .or. .not.success) then @@ -1525,7 +1444,7 @@ type(string_t) function mpi_wrapper_query(mpilib,wrapper,command,verbose,error) case (MPI_TYPE_OPENMPI) ! --showme:command returns the build command of this wrapper - call run_mpi_wrapper(wrapper,[string_t('--showme:libdirs')],verbose=verbose, & + 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 @@ -1546,7 +1465,7 @@ type(string_t) function mpi_wrapper_query(mpilib,wrapper,command,verbose,error) select case (mpilib) case (MPI_TYPE_OPENMPI) ! --showme:command returns the build command of this wrapper - call run_mpi_wrapper(wrapper,[string_t('--showme:incdirs')],verbose=verbose, & + 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') @@ -1566,7 +1485,7 @@ type(string_t) function mpi_wrapper_query(mpilib,wrapper,command,verbose,error) case (MPI_TYPE_OPENMPI) ! --showme:command returns the build command of this wrapper - call run_mpi_wrapper(wrapper,[string_t('--showme:version')],verbose=verbose, & + 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 @@ -1581,12 +1500,12 @@ type(string_t) function mpi_wrapper_query(mpilib,wrapper,command,verbose,error) !> 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_mpi_wrapper(cmdstr,verbose=verbose, & + 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_mpi_wrapper(wrapper,[string_t('-v')],verbose=verbose, & + call run_wrapper(wrapper,[string_t('-v')],verbose=verbose, & exitcode=stat,cmd_success=success,screen_output=screen) call remove_newline_characters(screen) endif @@ -1594,7 +1513,7 @@ type(string_t) function mpi_wrapper_query(mpilib,wrapper,command,verbose,error) ! Third option: mpiexec --version if (stat/=0 .or. .not.success) then cmdstr = string_t('mpiexec --version') - call run_mpi_wrapper(cmdstr,verbose=verbose, & + call run_wrapper(cmdstr,verbose=verbose, & exitcode=stat,cmd_success=success,screen_output=screen) endif @@ -1606,7 +1525,7 @@ type(string_t) function mpi_wrapper_query(mpilib,wrapper,command,verbose,error) case (MPI_TYPE_INTEL) ! --showme:command returns the build command of this wrapper - call run_mpi_wrapper(wrapper,[string_t('-v')],verbose=verbose, & + call run_wrapper(wrapper,[string_t('-v')],verbose=verbose, & exitcode=stat,cmd_success=success,screen_output=screen) if (stat/=0 .or. .not.success) then @@ -1765,5 +1684,240 @@ subroutine filter_link_arguments(compiler,command) end subroutine filter_link_arguments +!> 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 + +!> Initialize HDF5 metapackage for the current system +subroutine init_hdf5(this,compiler,error) + class(metapackage_t), intent(inout) :: this + type(compiler_t), intent(in) :: compiler + 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,module_flag,include_flag,libdir,ext,pref + + module_flag = get_module_flag(compiler,"") + 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("") + + !> 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' + do i=1,size(candidates) + if (pkgcfg_has_package(trim(candidates(i)))) then + name = trim(candidates(i)) + exit + end if + end do + + !> some distros put hdf5-1.2.3.pc with version number in .pc filename. + if (name=='NOT_FOUND') then + modules = pkgcfg_list_all(error) + do i=1,size(modules) + if (str_begins_with_str(modules(i)%s,'hdf5')) then + name = modules(i)%s + exit + end if + end do + end if + + if (name=='NOT_FOUND') then + call fatal_error(error,'pkg-config could not find a suitable hdf5 package.') + return + end if + + !> Get version + 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 + + !> 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 + this%has_link_libraries = .true. + this%link_libs = [this%link_libs, string_t(libs(i)%s(3:))] + + print *, 'HDF5: add link library '//libs(i)%s(3:) + + 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:) + endif + + print *, 'HDF5: add link flag '//libs(i)%s + + end if + end do + + print *, 'libdir = ',libdir + do i=1,size(this%link_libs) + print *, '-l'//this%link_libs(i)%s + end do + + + ! 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) + print *, this%link_libs(j)%s,' begins? ',str_begins_with_str(this%link_libs(j)%s,this%link_libs(i)%s), & + ' ends? ',str_ends_with(this%link_libs(j)%s,trim(find_hl(k))) + 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 + + print *, 'lib ',this%link_libs(i)%s,' found = ',found_hl + + ! 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) this%link_libs = [this%link_libs, & + string_t(this%link_libs(i)%s//trim(find_hl(k)))] + + end do add_missing + + end if + + end do + endif + + print *, 'final link libs: ' + do i=1,size(this%link_libs) + print *, '-l'//this%link_libs(i)%s + 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 + this%has_include_dirs = .true. + this%incl_dirs = [this%incl_dirs, string_t(flags(i)%s(len(include_flag)+1:))] + else + this%has_build_flags = .true. + this%flags = string_t(trim(this%flags%s)//' '//flags(i)%s) + end if + + end do + + !> 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('h5lib'), & + string_t('h5global'), & + string_t('h5_gen'), & + string_t('h5fortkit'), & + string_t('hdf5')] + +end subroutine init_hdf5 end module fpm_meta diff --git a/src/fpm_os.c b/src/fpm_os.c index 49e1a4d5f4..c423c3a28b 100644 --- a/src/fpm_os.c +++ b/src/fpm_os.c @@ -1,4 +1,5 @@ #include +#include /// @brief Determine the absolute, canonicalized path for a given path. /// @param path @@ -14,3 +15,6 @@ char* c_realpath(char* path, char* resolved_path, int maxLength) { return _fullpath(resolved_path, path, maxLength); #endif } + + + diff --git a/src/fpm_pkg_config.f90 b/src/fpm_pkg_config.f90 new file mode 100644 index 0000000000..eb4bc5f822 --- /dev/null +++ b/src/fpm_pkg_config.f90 @@ -0,0 +1,348 @@ +!># 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 MPI wrapper') + endif + + end if + +end subroutine run_wrapper + +end module fpm_pkg_config diff --git a/test/fpm_test/test_manifest.f90 b/test/fpm_test/test_manifest.f90 index ddabe3cf49..316508d9bc 100644 --- a/test/fpm_test/test_manifest.f90 +++ b/test/fpm_test/test_manifest.f90 @@ -556,7 +556,7 @@ subroutine test_profiles(error) compiler = 'ifort' call find_profile(package%profiles, profile_name, compiler, 3, profile_found, chosen_profile) if (.not.(chosen_profile%flags.eq.& - ' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl /standard-semantics /traceback')) then + ' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl /traceback')) then call test_failed(error, "Failed to load built-in profile "//profile_name) return end if diff --git a/test/fpm_test/test_os.f90 b/test/fpm_test/test_os.f90 index 71989167f5..a0b5c11a79 100644 --- a/test/fpm_test/test_os.f90 +++ b/test/fpm_test/test_os.f90 @@ -1,7 +1,7 @@ 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 + 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 @@ -21,6 +21,7 @@ subroutine collect_os(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.), & @@ -251,4 +252,55 @@ subroutine abs_path_cd_current(error) 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