diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/fpm.f90 | 5 | ||||
| -rw-r--r-- | src/fpm/cmd/new.f90 | 2 | ||||
| -rw-r--r-- | src/fpm/manifest.f90 | 2 | ||||
| -rw-r--r-- | src/fpm/manifest/package.f90 | 29 | ||||
| -rw-r--r-- | src/fpm_command_line.f90 | 82 | ||||
| -rw-r--r-- | src/fpm_compiler.f90 | 25 | ||||
| -rw-r--r-- | src/fpm_environment.f90 | 147 | ||||
| -rw-r--r-- | src/fpm_filesystem.f90 | 84 | ||||
| -rw-r--r-- | src/fpm_source_parsing.f90 | 31 |
9 files changed, 341 insertions, 66 deletions
diff --git a/src/fpm.f90 b/src/fpm.f90 index 401136b..c670378 100644 --- a/src/fpm.f90 +++ b/src/fpm.f90 @@ -4,12 +4,13 @@ use fpm_backend, only: build_package use fpm_command_line, only: fpm_build_settings, fpm_new_settings, & fpm_run_settings, fpm_install_settings, fpm_test_settings use fpm_dependency, only : new_dependency_tree -use fpm_environment, only: run, get_env, get_archiver +use fpm_environment, only: run, get_env use fpm_filesystem, only: is_dir, join_path, number_of_rows, list_files, exists, basename use fpm_model, only: fpm_model_t, srcfile_t, show_model, & FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, FPM_SCOPE_DEP, & FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST -use fpm_compiler, only: get_module_flags, is_unknown_compiler, get_default_c_compiler +use fpm_compiler, only: get_module_flags, is_unknown_compiler, get_default_c_compiler, & + get_archiver use fpm_sources, only: add_executable_sources, add_sources_from_dir diff --git a/src/fpm/cmd/new.f90 b/src/fpm/cmd/new.f90 index 773d7a7..1e92678 100644 --- a/src/fpm/cmd/new.f90 +++ b/src/fpm/cmd/new.f90 @@ -605,7 +605,7 @@ character(len=*),intent(in) :: filename call set_value(table, "copyright", 'Copyright '//date(1:4)//', Jane Doe') ! continue building of manifest ! ... - call new_package(package, table, error) + call new_package(package, table, error=error) if (allocated(error)) stop 3 if(settings%verbose)then call table%accept(ser) diff --git a/src/fpm/manifest.f90 b/src/fpm/manifest.f90 index 4170b91..8c39aa6 100644 --- a/src/fpm/manifest.f90 +++ b/src/fpm/manifest.f90 @@ -113,7 +113,7 @@ contains return end if - call new_package(package, table, error) + call new_package(package, table, dirname(file), error) if (allocated(error)) return if (present(apply_defaults)) then diff --git a/src/fpm/manifest/package.f90 b/src/fpm/manifest/package.f90 index bbaa51d..0430761 100644 --- a/src/fpm/manifest/package.f90 +++ b/src/fpm/manifest/package.f90 @@ -38,6 +38,7 @@ module fpm_manifest_package 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_filesystem, only : exists, getline, join_path use fpm_error, only : error_t, fatal_error, syntax_error use fpm_toml, only : toml_table, toml_array, toml_key, toml_stat, get_value, & & len @@ -99,7 +100,7 @@ contains !> Construct a new package configuration from a TOML data structure - subroutine new_package(self, table, error) + subroutine new_package(self, table, root, error) !> Instance of the package configuration type(package_config_t), intent(out) :: self @@ -107,6 +108,9 @@ contains !> 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 @@ -116,8 +120,8 @@ contains achar(8) // achar(9) // achar(10) // achar(12) // achar(13) type(toml_table), pointer :: child, node type(toml_array), pointer :: children - character(len=:), allocatable :: version - integer :: ii, nn, stat + character(len=:), allocatable :: version, version_file + integer :: ii, nn, stat, io call check(table, error) if (allocated(error)) return @@ -157,6 +161,25 @@ contains call get_value(table, "version", version, "0") call new_version(self%version, version, error) + if (allocated(error) .and. present(root)) then + version_file = join_path(root, version) + if (exists(version_file)) then + deallocate(error) + open(file=version_file, newunit=io, iostat=stat) + if (stat == 0) then + call getline(io, version, iostat=stat) + end if + if (stat == 0) then + close(io, iostat=stat) + end if + if (stat == 0) then + call new_version(self%version, version, error) + else + call fatal_error(error, "Reading version number from file '" & + & //version_file//"' failed") + end if + end if + end if if (allocated(error)) return call get_value(table, "dependencies", child, requested=.false.) diff --git a/src/fpm_command_line.f90 b/src/fpm_command_line.f90 index f44bcd0..d324b97 100644 --- a/src/fpm_command_line.f90 +++ b/src/fpm_command_line.f90 @@ -27,8 +27,10 @@ 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 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, fnv_1a -use fpm_filesystem, only : basename, canon_path, to_fortran_name +use fpm_filesystem, only : basename, canon_path, to_fortran_name, which +use fpm_environment, only : run, get_command_arguments_quoted use fpm_compiler, only : get_default_compile_flags use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & & stdout=>output_unit, & @@ -144,11 +146,8 @@ contains & os_type] ! find the subcommand name by looking for first word on command ! not starting with dash - cmdarg=' ' - do i = 1, command_argument_count() - call get_command_argument(i, cmdarg) - if(adjustl(cmdarg(1:1)) .ne. '-')exit - enddo + CLI_RESPONSE_FILE=.true. + cmdarg = get_subcommand() common_args = '--directory:C " " ' @@ -446,25 +445,29 @@ contains case default - call set_args(common_args // '& - & --list F& - & --verbose F& - &', help_fpm, version_text) - ! Note: will not get here if --version or --usage or --help - ! is present on commandline - help_text=help_usage - if(lget('list'))then - help_text=help_list_dash - elseif(len_trim(cmdarg).eq.0)then - write(stdout,'(*(a))')'Fortran Package Manager:' - write(stdout,'(*(a))')' ' - call printhelp(help_list_nodash) + if(which('fpm-'//cmdarg).ne.'')then + call run('fpm-'//trim(cmdarg)//' '// get_command_arguments_quoted(),.false.) else - write(stderr,'(*(a))')'<ERROR> unknown subcommand [', & - & trim(cmdarg), ']' - call printhelp(help_list_dash) + call set_args('& + & --list F& + & --verbose F& + &', help_fpm, version_text) + ! Note: will not get here if --version or --usage or --help + ! is present on commandline + help_text=help_usage + if(lget('list'))then + help_text=help_list_dash + elseif(len_trim(cmdarg).eq.0)then + write(stdout,'(*(a))')'Fortran Package Manager:' + write(stdout,'(*(a))')' ' + call printhelp(help_list_nodash) + else + write(stderr,'(*(a))')'<ERROR> unknown subcommand [', & + & trim(cmdarg), ']' + call printhelp(help_list_dash) + endif + call printhelp(help_text) endif - call printhelp(help_text) end select @@ -666,7 +669,7 @@ contains ' + run Run the local package binaries. defaults to all binaries for ', & ' that release. ', & ' + test Run the tests. ', & - ' + help Alternate method for displaying subcommand help. ', & + ' + help Alternate to the --help switch for displaying help text. ', & ' + list Display brief descriptions of all subcommands. ', & ' + install Install project ', & ' ', & @@ -709,6 +712,37 @@ contains ' --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. ', & + ' ', & 'EXAMPLES ', & ' sample commands: ', & ' ', & diff --git a/src/fpm_compiler.f90 b/src/fpm_compiler.f90 index 389ba94..b3e3a56 100644 --- a/src/fpm_compiler.f90 +++ b/src/fpm_compiler.f90 @@ -27,7 +27,7 @@ ! Unisys ? ? ? ? ? discontinued module fpm_compiler use fpm_model, only: fpm_model_t -use fpm_filesystem, only: join_path, basename +use fpm_filesystem, only: join_path, basename, get_temp_filename use fpm_environment, only: & get_os_type, & OS_LINUX, & @@ -36,13 +36,15 @@ use fpm_environment, only: & OS_CYGWIN, & OS_SOLARIS, & OS_FREEBSD, & - OS_OPENBSD + OS_OPENBSD, & + OS_UNKNOWN implicit none public :: is_unknown_compiler public :: get_module_flags public :: get_default_compile_flags public :: get_debug_compile_flags public :: get_release_compile_flags +public :: get_archiver enum, bind(C) enumerator :: & @@ -464,4 +466,23 @@ function is_unknown_compiler(compiler) result(is_unknown) is_unknown = get_compiler_id(compiler) == id_unknown end function is_unknown_compiler + +function get_archiver() result(archiver) + character(:), allocatable :: archiver + integer :: estat, os_type + + os_type = get_os_type() + if (os_type /= OS_WINDOWS .and. os_type /= OS_UNKNOWN) then + archiver = "ar -rs " + else + call execute_command_line("ar --version > "//get_temp_filename()//" 2>&1", & + & exitstat=estat) + if (estat /= 0) then + archiver = "lib /OUT:" + else + archiver = "ar -rs " + end if + end if +end function + end module fpm_compiler diff --git a/src/fpm_environment.f90 b/src/fpm_environment.f90 index 107c977..cf76250 100644 --- a/src/fpm_environment.f90 +++ b/src/fpm_environment.f90 @@ -3,13 +3,17 @@ !! * [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 implicit none private public :: get_os_type public :: os_is_unix public :: run public :: get_env - public :: get_archiver + public :: get_command_arguments_quoted + public :: separator integer, parameter, public :: OS_UNKNOWN = 0 integer, parameter, public :: OS_LINUX = 1 @@ -197,24 +201,129 @@ contains if(VALUE.eq.''.and.present(DEFAULT))VALUE=DEFAULT end function get_env - function get_archiver() result(archiver) - character(:), allocatable :: archiver - - associate(os_type => get_os_type()) - if (os_type /= OS_WINDOWS .and. os_type /= OS_UNKNOWN) then - archiver = "ar -rs " + 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().eq.'\') + 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))')'<ERROR>*get_command_arguments_stack* error obtaining argument ',i + exit else - block - integer :: estat - - call execute_command_line("ar --version", exitstat=estat) - if (estat /= 0) then - archiver = "lib /OUT:" + 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))')'<ERROR>*get_command_arguments_stack* error obtaining argument ',i + exit + elseif(ilength.gt.0)then + if(index(arg//' ','-').ne.1)then + args=args//quote//arg//quote//' ' + elseif(index(arg,' ').ne.0)then + args=args//quote//arg//quote//' ' else - archiver = "ar -rs " - end if - end block - end if - end associate - end function + 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.ne.' ')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,'\').ne.0)then + sep='\' + elseif(index(arg0,'/').ne.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,'\').ne.0)then + sep='\' + elseif(index(name,'/').ne.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'),'\').ne.0) + !*!write(*,*)'<WARNING>unknown system directory path separator' + endif + endif + endif + endif + !*ifort_bug*!sep_cache=sep +end function separator end module fpm_environment diff --git a/src/fpm_filesystem.f90 b/src/fpm_filesystem.f90 index c9c97dd..e6226b4 100644 --- a/src/fpm_filesystem.f90 +++ b/src/fpm_filesystem.f90 @@ -5,15 +5,18 @@ use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, use fpm_environment, only: get_os_type, & OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD + use fpm_environment, only: separator, get_env use fpm_strings, only: f_string, replace, string_t, split implicit none private public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, read_lines, list_files, env_variable, & mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, to_fortran_name public :: fileopen, fileclose, filewrite, warnwrite, parent_dir + public :: which integer, parameter :: LINE_BUFFER_LEN = 1000 + contains @@ -181,6 +184,7 @@ function dirname(path) result (dir) character(:), allocatable :: dir dir = path(1:scan(path,'/\',back=.true.)) + if (len_trim(dir) == 0) dir = "." end function dirname @@ -618,4 +622,84 @@ pure function to_fortran_name(string) result(res) res = replace(string, SPECIAL_CHARACTERS, '_') end function to_fortran_name +function which(command) result(pathname) +!> +!!##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 +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain + +character(len=*),intent(in) :: command +character(len=:),allocatable :: pathname, checkon, paths(:), exts(:) +integer :: i, j + pathname='' + call split(get_env('PATH'),paths,delimiters=merge(';',':',separator().eq.'\')) + 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 + end module fpm_filesystem diff --git a/src/fpm_source_parsing.f90 b/src/fpm_source_parsing.f90 index dd9a4c5..6fa00d5 100644 --- a/src/fpm_source_parsing.f90 +++ b/src/fpm_source_parsing.f90 @@ -79,7 +79,7 @@ function parse_f_source(f_filename,error) result(f_source) integer :: stat integer :: fh, n_use, n_include, n_mod, i, j, ic, pass type(string_t), allocatable :: file_lines(:) - character(:), allocatable :: temp_string, mod_name + character(:), allocatable :: temp_string, mod_name, string_parts(:) f_source%file_name = f_filename @@ -191,22 +191,25 @@ function parse_f_source(f_filename,error) result(f_source) ! Extract name of module if is module if (index(adjustl(lower(file_lines(i)%s)),'module ') == 1) then - mod_name = lower(split_n(file_lines(i)%s,n=2,delims=' ',stat=stat)) - if (stat /= 0) then - call file_parse_error(error,f_filename, & - 'unable to find module name',i, & - file_lines(i)%s) - return + ! Remove any trailing comments + ic = index(file_lines(i)%s,'!')-1 + if (ic < 1) then + ic = len(file_lines(i)%s) + end if + temp_string = trim(file_lines(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 - if (mod_name == 'procedure' .or. & - mod_name == 'subroutine' .or. & - mod_name == 'function' .or. & - scan(mod_name,'=(')>0 ) then + mod_name = lower(trim(adjustl(string_parts(2)))) + if (scan(mod_name,'=(&')>0 ) then ! Ignore these cases: - ! module procedure * - ! module function * - ! module subroutine * + ! module <something>& ! module =* ! module (i) cycle |