diff options
| -rw-r--r-- | fpm/fpm.toml | 5 | ||||
| -rw-r--r-- | fpm/src/fpm.f90 | 35 | ||||
| -rw-r--r-- | fpm/src/fpm_backend.f90 | 4 | ||||
| -rw-r--r-- | fpm/src/fpm_command_line.f90 | 273 | ||||
| -rw-r--r-- | fpm/src/fpm_compiler.f90 | 236 | ||||
| -rw-r--r-- | fpm/src/fpm_environment.f90 | 34 | ||||
| -rw-r--r-- | fpm/src/fpm_filesystem.f90 | 12 | ||||
| -rw-r--r-- | fpm/test/cli_test/cli_test.f90 | 30 | ||||
| -rw-r--r-- | fpm/test/help_test/help_test.f90 | 311 |
9 files changed, 827 insertions, 113 deletions
diff --git a/fpm/fpm.toml b/fpm/fpm.toml index c30c9b4..66e5049 100644 --- a/fpm/fpm.toml +++ b/fpm/fpm.toml @@ -29,4 +29,7 @@ name = "fpm-test" source-dir = "test/fpm_test" main = "main.f90" - +[[test]] +name = "help-test" +source-dir = "test/help_test" +main = "help_test.f90" diff --git a/fpm/src/fpm.f90 b/fpm/src/fpm.f90 index b94d25f..67be1cc 100644 --- a/fpm/src/fpm.f90 +++ b/fpm/src/fpm.f90 @@ -9,6 +9,8 @@ use fpm_model, only: fpm_model_t, srcfile_t, build_target_t, & FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, & FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST, & FPM_TARGET_EXECUTABLE, FPM_TARGET_ARCHIVE +use fpm_compiler, only: add_compile_flag_defaults + use fpm_sources, only: add_executable_sources, add_sources_from_dir use fpm_targets, only: targets_from_sources, resolve_module_dependencies, & @@ -153,11 +155,17 @@ subroutine build_model(model, settings, package, error) type(fpm_build_settings), intent(in) :: settings type(package_config_t), intent(in) :: package type(error_t), allocatable, intent(out) :: error + type(string_t), allocatable :: package_list(:) integer :: i - type(string_t), allocatable :: package_list(:) + + if(settings%verbose)then + write(*,*)'<INFO>BUILD_NAME:',settings%build_name + write(*,*)'<INFO>COMPILER: ',settings%compiler + endif model%package_name = package%name + if (allocated(package%build%link)) then model%link_libraries = package%build%link else @@ -167,25 +175,16 @@ subroutine build_model(model, settings, package, error) allocate(package_list(1)) package_list(1)%s = package%name - ! #TODO: Choose flags and output directory based on cli settings & manifest inputs - model%fortran_compiler = 'gfortran' - - if(settings%release)then - model%output_directory = 'build/gfortran_release' - model%fortran_compile_flags=' & - & -O3 & - & -Wimplicit-interface & - & -fPIC & - & -fmax-errors=1 & - & -ffast-math & - & -funroll-loops ' // & - & '-J'//join_path(model%output_directory,model%package_name) + if(settings%compiler.eq.'')then + model%fortran_compiler = 'gfortran' else - model%output_directory = 'build/gfortran_debug' - model%fortran_compile_flags = ' -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1 -g '// & - '-fbounds-check -fcheck-array-temporaries -fbacktrace '// & - '-J'//join_path(model%output_directory,model%package_name) + model%fortran_compiler = settings%compiler endif + + model%output_directory = join_path('build',basename(model%fortran_compiler)//'_'//settings%build_name) + + call add_compile_flag_defaults(settings%build_name, basename(model%fortran_compiler), model) + model%link_flags = '' ! Add sources from executable directories diff --git a/fpm/src/fpm_backend.f90 b/fpm/src/fpm_backend.f90 index d0843a3..6b56799 100644 --- a/fpm/src/fpm_backend.f90 +++ b/fpm/src/fpm_backend.f90 @@ -204,7 +204,7 @@ subroutine build_target(model,target) select case(target%target_type) case (FPM_TARGET_OBJECT) - call run("gfortran -c " // target%source%file_name // model%fortran_compile_flags & + call run(model%fortran_compiler//" -c " // target%source%file_name // model%fortran_compile_flags & // " -o " // target%output_file) case (FPM_TARGET_EXECUTABLE) @@ -223,7 +223,7 @@ subroutine build_target(model,target) end if end if - call run("gfortran " // model%fortran_compile_flags & + call run(model%fortran_compiler// " " // model%fortran_compile_flags & //" "//link_flags// " -o " // target%output_file) case (FPM_TARGET_ARCHIVE) diff --git a/fpm/src/fpm_command_line.f90 b/fpm/src/fpm_command_line.f90 index 03daf6f..2a44a4f 100644 --- a/fpm/src/fpm_command_line.f90 +++ b/fpm/src/fpm_command_line.f90 @@ -1,9 +1,9 @@ module fpm_command_line -use fpm_environment, only : get_os_type, & +use fpm_environment, only : get_os_type, get_env, & OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & OS_CYGWIN, OS_SOLARIS, OS_FREEBSD use M_CLI2, only : set_args, lget, sget, unnamed, remaining, specified -use fpm_strings, only : lower +use fpm_strings, only : lower, split use fpm_filesystem, only : basename, canon_path use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & & stdout=>output_unit, & @@ -20,6 +20,7 @@ public :: fpm_cmd_settings, & get_command_line_settings type, abstract :: fpm_cmd_settings + logical :: verbose=.true. end type integer,parameter :: ibug=4096 @@ -32,8 +33,9 @@ type, extends(fpm_cmd_settings) :: fpm_new_settings end type type, extends(fpm_cmd_settings) :: fpm_build_settings - logical :: release=.false. logical :: list=.false. + character(len=:),allocatable :: compiler + character(len=:),allocatable :: build_name end type type, extends(fpm_build_settings) :: fpm_run_settings @@ -50,7 +52,8 @@ end type character(len=:),allocatable :: name character(len=:),allocatable :: os_type -character(len=ibug),allocatable :: names(:) +character(len=ibug),allocatable :: names(:) +character(len=:),allocatable :: tnames(:) character(len=:), allocatable :: version_text(:) character(len=:), allocatable :: help_new(:), help_fpm(:), help_run(:), & @@ -61,7 +64,8 @@ character(len=20),parameter :: manual(*)=[ character(len=20) ::& & ' ', 'fpm', 'new', 'build', 'run', & & 'test', 'runner', 'list', 'help', 'version' ] -character(len=:), allocatable :: charbug +character(len=:), allocatable :: val_runner, val_build, val_compiler + contains subroutine get_command_line_settings(cmd_settings) class(fpm_cmd_settings), allocatable, intent(out) :: cmd_settings @@ -102,7 +106,16 @@ contains select case(trim(cmdarg)) case('run') - call set_args('--list F --release F --runner " " --',help_run,version_text) + call set_args('& + & --target " " & + & --list F & + & --release F& + & --runner " " & + & --compiler "'//get_env('FPM_COMPILER','gfortran')//'" & + & --verbose F& + & --',help_test,version_text) + + call check_build_vals() if( size(unnamed) .gt. 1 )then names=unnamed(2:) @@ -110,39 +123,67 @@ contains 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 + allocate(fpm_run_settings :: cmd_settings) - cmd_settings=fpm_run_settings( name=names, list=lget('list'), & - & release=lget('release'), args=remaining ,runner=sget('runner') ) + val_runner=sget('runner') + cmd_settings=fpm_run_settings(& + & args=remaining,& + & build_name=val_build,& + & compiler=val_compiler, & + & list=lget('list'),& + & name=names,& + & runner=val_runner,& + & verbose=lget('verbose') ) case('build') - call set_args( '--release F --list F --',help_build,version_text ) + call set_args( '& + & --release F & + & --list F & + & --compiler "'//get_env('FPM_COMPILER','gfortran')//'" & + & --verbose F& + & --',help_build,version_text) + + call check_build_vals() allocate( fpm_build_settings :: cmd_settings ) - cmd_settings=fpm_build_settings( release=lget('release'), & - & list=lget('list') ) + cmd_settings=fpm_build_settings( & + & build_name=val_build,& + & compiler=val_compiler, & + & list=lget('list'),& + & verbose=lget('verbose') ) case('new') - call set_args(' --src F --lib F --app F --test F --backfill F', & + call set_args('& + & --src F & + & --lib F & + & --app F & + & --test F & + & --backfill F& + & --verbose F',& & help_new, version_text) select case(size(unnamed)) case(1) - write(stderr,'(*(g0,/))')'ERROR: directory name required' + write(stderr,'(*(g0,/))')'<ERROR> directory name required' write(stderr,'(*(7x,g0,/))') & - & 'USAGE: fpm new NAME [--lib|--src] [--app] [--test] [--backfill]' + & '<USAGE> fpm new NAME [--lib|--src] [--app] [--test] [--backfill]' stop 1 case(2) name=trim(unnamed(2)) case default - write(stderr,'(g0)')'ERROR: only one directory name allowed' + write(stderr,'(g0)')'<ERROR> only one directory name allowed' write(stderr,'(7x,g0)') & - & 'USAGE: fpm new NAME [--lib|--src] [--app] [--test] [--backfill]' + & '<USAGE> fpm new NAME [--lib|--src] [--app] [--test] [--backfill]' stop 2 end select !*! canon_path is not converting ".", etc. name=canon_path(name) if( .not.is_fortran_name(basename(name)) )then write(stderr,'(g0)') [ character(len=72) :: & - & 'ERROR: the new directory basename must be an allowed ', & + & '<ERROR>the new directory basename must be an allowed ', & & ' Fortran name. It must be composed of 1 to 63 ASCII', & & ' characters and start with a letter and be composed', & & ' entirely of alphanumeric characters [a-zA-Z0-9]', & @@ -153,21 +194,27 @@ contains allocate(fpm_new_settings :: cmd_settings) if (any( specified(['src ','lib ','app ','test']) ) )then - cmd_settings=fpm_new_settings(name=name, & + cmd_settings=fpm_new_settings(& + & backfill=lget('backfill'), & + & name=name, & & with_executable=lget('app'), & - & with_test=lget('test'), & & with_lib=any([lget('lib'),lget('src')]), & - & backfill=lget('backfill') ) + & with_test=lget('test'), & + & verbose=lget('verbose') ) else - cmd_settings=fpm_new_settings(name=name, & + cmd_settings=fpm_new_settings(& + & backfill=lget('backfill') , & + & name=name, & & with_executable=.true., & - & with_test=.true., & & with_lib=.true., & - & backfill=lget('backfill') ) + & with_test=.true., & + & verbose=lget('verbose') ) endif case('help','manual') - call set_args(' ',help_help,version_text) + call set_args('& + & --verbose F & + & ',help_help,version_text) if(size(unnamed).lt.2)then if(unnamed(1).eq.'help')then unnamed=[' ', 'fpm'] @@ -209,17 +256,32 @@ contains call printhelp(help_text) case('install') - call set_args('--release F ', help_install, version_text) + call set_args('& + & --release F& + & --verbose F& + &', help_install, version_text) allocate(fpm_install_settings :: cmd_settings) case('list') - call set_args(' --list F', help_list, version_text) + call set_args('& + & --list F& + & --verbose F& + &', help_list, version_text) call printhelp(help_list_nodash) if(lget('list'))then call printhelp(help_list_dash) endif case('test') - call set_args('--list F --release F --runner " " --',help_test,version_text) + call set_args('& + & --target " " & + & --list F& + & --release F& + & --runner " " & + & --compiler "'//get_env('FPM_COMPILER','gfortran')//'" & + & --verbose F& + & --',help_test,version_text) + + call check_build_vals() if( size(unnamed) .gt. 1 )then names=unnamed(2:) @@ -227,14 +289,28 @@ contains 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 + allocate(fpm_test_settings :: cmd_settings) - charbug=sget('runner') - cmd_settings=fpm_test_settings( name=names, list=lget('list'), & - & release=lget('release'), args=remaining ,runner=charbug ) + val_runner=sget('runner') + cmd_settings=fpm_test_settings(& + & args=remaining, & + & build_name=val_build, & + & compiler=val_compiler, & + & list=lget('list'), & + & name=names, & + & runner=val_runner, & + & verbose=lget('verbose') ) case default - call set_args(' --list F', help_fpm, version_text) + 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 @@ -245,7 +321,7 @@ contains write(stdout,'(*(a))')' ' call printhelp(help_list_nodash) else - write(stderr,'(*(a))')'ERROR: unknown subcommand [', & + write(stderr,'(*(a))')'<ERROR> unknown subcommand [', & & trim(cmdarg), ']' call printhelp(help_list_dash) endif @@ -253,10 +329,31 @@ contains end select contains + + subroutine check_build_vals() + + val_compiler=sget('compiler') + if(val_compiler.eq.'') then + val_compiler='gfortran' + endif + + val_build=trim(merge('release','debug ',lget('release'))) + + end subroutine check_build_vals + subroutine printhelp(lines) character(len=:),intent(in),allocatable :: lines(:) - write(stdout,'(g0)')(trim(lines(i)), i=1, size(lines) ) + integer :: iii,ii + if(allocated(lines))then + ii=size(lines) + if(ii .gt. 0 .and. len(lines).gt. 0) then + write(stdout,'(g0)')(trim(lines(iii)), iii=1, ii) + else + write(stdout,'(a)')'<WARNING> *printhelp* output requested is empty' + endif + endif end subroutine printhelp + end subroutine get_command_line_settings function is_fortran_name(line) result (lout) @@ -298,13 +395,15 @@ contains ' "fpm --help" or "fpm SUBCOMMAND --help" for detailed descriptions. ', & ' '] help_list_dash = [character(len=80) :: & - ' ', & - ' build [--release] [--list] ', & - ' help [NAME(s)] ', & - ' new NAME [--lib|--src] [--app] [--test] [--backfill] ', & - ' list [--list] ', & - ' run [NAME(s)] [--release] [--runner "CMD"] [--list] [-- ARGS] ', & - ' test [NAME(s)] [--release] [--runner "CMD"] [--list] [-- ARGS] ', & + ' ', & + ' build [--compiler COMPILER_NAME] [--release] [--list] ', & + ' help [NAME(s)] ', & + ' new NAME [--lib|--src] [--app] [--test] [--backfill] ', & + ' list [--list] ', & + ' run [[--target] NAME(s)] [--release] [--runner "CMD"] [--list] ', & + ' [--compiler COMPILER_NAME] [-- ARGS] ', & + ' test [[--target] NAME(s)] [--release] [--runner "CMD"] [--list] ', & + ' [--compiler COMPILER_NAME] [-- ARGS] ', & ' '] help_usage=[character(len=80) :: & '' ] @@ -368,8 +467,8 @@ contains ' # generates commands of the form "cp $FILENAME /usr/local/bin/" ', & ' ', & ' # bash(1) alias example: ', & - ' alias fpm-install="ffpm run --release --runner \ ', & - ' ''install -vbp -m 0711 -t ~/.local/bin''" ', & + ' alias fpm-install=\ ', & + ' "fpm run --release --runner ''install -vbp -m 0711 -t ~/.local/bin''" ', & ' fpm-install ', & '' ] help_fpm=[character(len=80) :: & @@ -390,9 +489,6 @@ contains ' part of your default programming environment, as well as letting ', & ' you share your projects with others in a similar manner. ', & ' ', & - ' See the fpm(1) repository at https://fortran-lang.org/packages/fpm ', & - ' for a listing of registered projects. ', & - ' ', & ' 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. ', & @@ -400,18 +496,22 @@ contains 'SUBCOMMANDS ', & ' Valid fpm(1) subcommands are: ', & ' ', & - ' build [--release] [--list] ', & - ' Compile the packages into the "build/" directory. ', & + ' + build Compile the packages into the "build/" directory. ', & + ' + new Create a new Fortran package directory with sample files. ', & + ' + run Run the local package binaries. defaults to all binaries for ', & + ' that release. ', & + ' + test Run the tests. ', & + ' + help Alternate method for displaying subcommand help. ', & + ' + list Display brief descriptions of all subcommands. ', & + ' ', & + ' Their syntax is ', & + ' ', & + ' build [--release] [--list] [--compiler COMPILER_NAME] ', & ' new NAME [--lib|--src] [--app] [--test] [--backfill] ', & - ' Create a new Fortran package directory ', & - ' with sample files ', & - ' run [NAME(s)] [--release] [--list] [--runner "CMD"][-- ARGS] ', & - ' Run the local package binaries. defaults to all ', & - ' binaries for that release. ', & - ' test [NAME(s)] [--release] [--list] [--runner "CMD"] [-- ARGS] ', & - ' Run the tests ', & - ' help [NAME(s)] Alternate method for displaying subcommand help ', & - ' list [--list] Display brief descriptions of all subcommands. ', & + ' run|test [[--target] NAME(s)] [--release] [--list] ', & + ' [--runner "CMD"] [--compiler COMPILER_NAME] [-- ARGS] ', & + ' help [NAME(s)] ', & + ' list [--list] ', & ' ', & 'SUBCOMMAND OPTIONS ', & ' --release Builds or runs in release mode (versus debug mode). fpm(1)', & @@ -421,11 +521,15 @@ contains ' optimization flags are used. ', & ' --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. ', & + ' --runner CMD Provides a command to prefix program execution paths. ', & + ' --compiler COMPILER_NAME Compiler name. The environment variable ', & + ' FPM_COMPILER sets the default. ', & ' -- ARGS Arguments to pass to executables. ', & - ' --help Show help text and exit. Valid for all subcommands. ', & - ' --version Show version information and exit. Valid for all ', & - ' subcommands. ', & + ' ', & + 'VALID FOR ALL SUBCOMMANDS ', & + ' --help Show help text and exit ', & + ' --verbose Display additional information when available ', & + ' --version Show version information and exit. ', & ' ', & 'EXAMPLES ', & ' sample commands: ', & @@ -438,10 +542,11 @@ contains ' fpm run myprogram --release -- -x 10 -y 20 --title "my title" ', & ' ', & 'SEE ALSO ', & + ' ', & ' + The fpm(1) home page is at https://github.com/fortran-lang/fpm ', & ' + Registered fpm(1) packages are at https://fortran-lang.org/packages ', & ' + The fpm(1) TOML file format is described at ', & - ' https://github.com/fortran-lang/fpm/blob/master/manifest-reference.md ', & + ' https://github.com/fortran-lang/fpm/blob/master/manifest-reference.md ', & ''] help_list=[character(len=80) :: & 'NAME ', & @@ -470,7 +575,8 @@ contains ' run(1) - the fpm(1) subcommand to run project applications ', & ' ', & 'SYNOPSIS ', & - ' fpm run [NAME(s)] [--release] [--runner "CMD"] [-- ARGS] ', & + ' fpm run [[--target] NAME(s)][--release][--compiler COMPILER_NAME] ', & + ' [--runner "CMD"] [--list][-- ARGS] ', & ' ', & ' fpm run --help|--version ', & ' ', & @@ -478,14 +584,17 @@ contains ' Run applications you have built in your fpm(1) project. ', & ' ', & 'OPTIONS ', & - ' NAME(s) optional list of specific names to execute. ', & - ' The default is to run all the applications in app/ ', & - ' or the programs listed in the "fpm.toml" file. ', & + ' --target NAME(s) optional list of specific names to execute. ', & + ' The default is to run all the applications in app/ ', & + ' or the programs listed in the "fpm.toml" file. ', & ' --release selects the optimized build instead of the debug ', & ' build. ', & - ' --list list candidates instead of building or running them ', & + ' --compiler COMPILER_NAME Specify a compiler name. The default is ', & + ' "gfortran" unless set by the environment ', & + ' variable FPM_COMPILER. ', & ' --runner CMD A command to prefix the program execution paths with. ', & ' see "fpm help runner" for further details. ', & + ' --list list candidates instead of building or running them ', & ' -- ARGS optional arguments to pass to the program(s). ', & ' The same arguments are passed to all names ', & ' specified. ', & @@ -495,12 +604,16 @@ contains ' ', & ' # run default programs in /app or as specified in "fpm.toml" ', & ' fpm run ', & + + ' # run default programs in /app or as specified in "fpm.toml" ', & + ' # using the compiler command "f90". ', & + ' fpm run --compiler f90 ', & ' ', & ' # run a specific program and pass arguments to the command ', & ' fpm run mytest -- -x 10 -y 20 --title "my title line" ', & ' ', & ' # run production version of two applications ', & - ' fpm run prg1 prg2 --release ', & + ' fpm run --target prg1,prg2 --release ', & ' ', & ' # install executables in directory (assuming install(1) exists) ', & ' fpm run --runner ''install -b -m 0711 -p -t /usr/local/bin'' ', & @@ -510,7 +623,7 @@ contains ' build(1) - the fpm(1) subcommand to build a project ', & ' ', & 'SYNOPSIS ', & - ' fpm build [--release]|[-list] ', & + ' fpm build [--release][--compiler COMPILER_NAME] [-list] ', & ' ', & ' fpm build --help|--version ', & ' ', & @@ -533,6 +646,9 @@ contains 'OPTIONS ', & ' --release build in build/*_release instead of build/*_debug with ', & ' high optimization instead of full debug options. ', & + ' --compiler COMPILER_NAME Specify a compiler name. The default is ', & + ' "gfortran" unless set by the environment ', & + ' variable FPM_COMPILER. ', & ' --list list candidates instead of building or running them ', & ' --help print this help and exit ', & ' --version print program version information and exit ', & @@ -654,7 +770,8 @@ contains ' test(1) - the fpm(1) subcommand to run project tests ', & ' ', & 'SYNOPSIS ', & - ' fpm test [NAME(s)] [--release] [--list] [--runner "CMD"] [-- ARGS] ', & + ' fpm test [[--target] NAME(s)][--release][--compiler COMPILER_NAME ] ', & + ' [--runner "CMD"] [--list][-- ARGS] ', & ' ', & ' fpm test --help|--version ', & ' ', & @@ -662,14 +779,17 @@ contains ' Run applications you have built to test your project. ', & ' ', & 'OPTIONS ', & - ' 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. ', & + ' --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. ', & ' --release selects the optimized build instead of the debug ', & ' build. ', & - ' --list list candidates instead of building or running them ', & + ' --compiler COMPILER_NAME Specify a compiler name. The default is ', & + ' "gfortran" unless set by the environment ', & + ' variable FPM_COMPILER. ', & ' --runner CMD A command to prefix the program execution paths with. ', & ' see "fpm help runner" for further details. ', & + ' --list list candidates instead of building or running them ', & ' -- ARGS optional arguments to pass to the test program(s). ', & ' The same arguments are passed to all test names ', & ' specified. ', & @@ -680,15 +800,18 @@ contains ' # 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 --release # production version of two tests ', & + ' fpm test tst1 tst2 --release # run production version of two tests ', & '' ] help_install=[character(len=80) :: & ' fpm(1) subcommand "install" ', & ' ', & - ' USAGE: fpm install NAME ', & + '<USAGE> fpm install NAME ', & '' ] end subroutine set_help diff --git a/fpm/src/fpm_compiler.f90 b/fpm/src/fpm_compiler.f90 new file mode 100644 index 0000000..6336e4e --- /dev/null +++ b/fpm/src/fpm_compiler.f90 @@ -0,0 +1,236 @@ +module fpm_compiler +use fpm_model, only: fpm_model_t +use fpm_filesystem, only: join_path +public add_compile_flag_defaults + +contains +subroutine add_compile_flag_defaults(build_name,compiler,model) +! Choose compile flags based on cli settings & manifest inputs +character(len=*),intent(in) :: build_name, compiler + +type(fpm_model_t), intent(inout) :: model +! could just be a function to return a string instead of passing model +! but likely to change other components like matching C compiler + +character(len=:),allocatable :: fflags ! optional flags that might be overridden by user +character(len=:),allocatable :: modpath +character(len=:),allocatable :: mandatory ! flags required for fpm to function properly; + ! ie. add module path and module include directory as appropriate + +! special reserved names "debug" and "release" are for supported compilers with no user-specified compile or load flags + +! vendor Fortran C Module output Module include OpenMP Free for OSS +! compiler compiler directory directory +! Gnu gfortran gcc -J -I -fopenmp X +! Intel ifort icc -module -I -qopenmp X +! Intel(Windows) ifort icc /module:path /I /Qopenmp X +! Intel oneAPI ifx icx -module -I -qopenmp X +! PGI pgfortran pgcc -module -I -mp X +! NVIDIA nvfortran nvc -module -I -mp X +! LLVM flang flang clang -module -I -mp X +! LFortran lfortran --- ? ? ? X +! Lahey/Futjitsu lfc ? -M -I -openmp ? +! NAG nagfor ? -mdir -I -openmp x +! Cray crayftn craycc -J -I -homp ? +! IBM xlf90 ? -qmoddir -I -qsmp X +! Oracle/Sun ? ? -moddir= -M -xopenmp ? +! Silverfrost FTN95 ftn95 ? ? /MOD_PATH ? ? +! Elbrus ? lcc -J -I -fopenmp ? +! Hewlett Packard ? ? ? ? ? discontinued +! Watcom ? ? ? ? ? discontinued +! PathScale ? ? -module -I -mp discontinued +! G95 ? ? -fmod= -I -fopenmp discontinued +! Open64 ? ? -module -I -mp discontinued +! Unisys ? ? ? ? ? discontinued + modpath=join_path(model%output_directory,model%package_name) + fflags='' + mandatory='' + + select case(build_name//'_'//compiler) + + case('release_caf') + fflags='& + & -O3& + & -Wimplicit-interface& + & -fPIC& + & -fmax-errors=1& + & -ffast-math& + & -funroll-loops& + &' + mandatory=' -J '//modpath//' -I '//modpath + case('debug_caf') + fflags = '& + & -Wall& + & -Wextra& + & -Wimplicit-interface& + & -fPIC -fmax-errors=1& + & -g& + & -fbounds-check& + & -fcheck-array-temporaries& + & -fbacktrace& + &' + mandatory=' -J '//modpath//' -I '//modpath + case('release_gfortran') + fflags='& + & -O3& + & -Wimplicit-interface& + & -fPIC& + & -fmax-errors=1& + & -ffast-math& + & -funroll-loops& + & -fcoarray=single& + &' + mandatory=' -J '//modpath//' -I '//modpath + case('debug_gfortran') + fflags = '& + & -Wall& + & -Wextra& + & -Wimplicit-interface& + & -fPIC -fmax-errors=1& + & -g& + & -fbounds-check& + & -fcheck-array-temporaries& + & -fbacktrace& + & -fcoarray=single& + &' + mandatory=' -J '//modpath//' -I '//modpath + + case('release_f95') + fflags='& + & -O3& + & -Wimplicit-interface& + & -fPIC& + & -fmax-errors=1& + & -ffast-math& + & -funroll-loops& + &' + mandatory=' -J '//modpath//' -I '//modpath + case('debug_f95') + fflags = '& + & -Wall& + & -Wextra& + & -Wimplicit-interface& + & -fPIC -fmax-errors=1& + & -g& + & -fbounds-check& + & -fcheck-array-temporaries& + & -Wno-maybe-uninitialized -Wno-uninitialized& + & -fbacktrace& + &' + mandatory=' -J '//modpath//' -I '//modpath + + case('release_nvfortran') + fflags = '& + & -Mbackslash& + &' + mandatory=' -module '//modpath//' -I '//modpath + case('debug_nvfortran') + fflags = '& + & -Minform=inform& + & -Mbackslash& + & -g& + & -Mbounds& + & -Mchkptr& + & -Mchkstk& + & -traceback& + &' + mandatory=' -module '//modpath//' -I '//modpath + + case('release_ifort') + fflags = '& + & -fp-model precise& + & -pc 64& + & -align all& + & -coarray& + & -error-limit 1& + & -reentrancy threaded& + & -nogen-interfaces& + & -assume byterecl& + & -assume nounderscore& + &' + mandatory=' -module '//modpath//' -I '//modpath + case('debug_ifort') + fflags = '& + & -warn all& + & -check:all:noarg_temp_created& + & -coarray& + & -error-limit 1& + & -O0& + & -g& + & -assume byterecl& + & -traceback& + &' + mandatory=' -module '//modpath//' -I '//modpath + case('release_ifx') + fflags = ' ' + mandatory=' -module '//modpath//' -I '//modpath + case('debug_ifx') + fflags = ' ' + mandatory=' -module '//modpath//' -I '//modpath + + case('release_pgfortran','release_pgf90','release_pgf95') ! Portland Group F90/F95 compilers + fflags = ' ' + mandatory=' -module '//modpath//' -I '//modpath + case('debug_pgfortran','debug_pgf90','debug_pgf95') ! Portland Group F90/F95 compilers + fflags = ' ' + mandatory=' -module '//modpath//' -I '//modpath + + case('release_flang') + fflags = ' ' + mandatory=' -module '//modpath//' -I '//modpath + case('debug_flang') + fflags = ' ' + mandatory=' -module '//modpath//' -I '//modpath + + case('release_lfc') + fflags = ' ' + mandatory=' -M '//modpath//' -I '//modpath + case('debug_lfc') + fflags = ' ' + mandatory=' -M '//modpath//' -I '//modpath + + case('release_nagfor') + fflags = ' & + & -O4& + & -coarray=single& + & -PIC& + &' + mandatory=' -mdir '//modpath//' -I '//modpath ! + case('debug_nagfor') + fflags = '& + & -g& + & -C=all& + & -O0& + & -gline& + & -coarray=single& + & -PIC& + &' + mandatory=' -mdir '//modpath//' -I '//modpath ! + case('release_crayftn') + fflags = ' ' + mandatory=' -J '//modpath//' -I '//modpath + case('debug_crayftn') + fflags = ' ' + mandatory=' -J '//modpath//' -I '//modpath + + case('release_xlf90') + fflags = ' ' + mandatory=' -qmoddir '//modpath//' -I '//modpath + case('debug_xlf90') + fflags = ' ' + mandatory=' -qmoddir '//modpath//' -I '//modpath + + case default + fflags = ' ' + mandatory=' -module '//modpath//' -I '//modpath + write(*,*)'<WARNING> unknown compiler (',compiler,')' + write(*,*)' and build name (',build_name,')' + write(*,*)' combination.' + write(*,*)' known compilers are gfortran, nvfortran, ifort' + end select + + model%fortran_compile_flags = fflags//' '//mandatory + +end subroutine add_compile_flag_defaults + +end module fpm_compiler diff --git a/fpm/src/fpm_environment.f90 b/fpm/src/fpm_environment.f90 index 553aa8b..1a8afef 100644 --- a/fpm/src/fpm_environment.f90 +++ b/fpm/src/fpm_environment.f90 @@ -3,6 +3,7 @@ module fpm_environment private public :: get_os_type public :: run + public :: get_env integer, parameter, public :: OS_UNKNOWN = 0 integer, parameter, public :: OS_LINUX = 1 @@ -114,4 +115,37 @@ contains error stop end if end subroutine run + + function get_env(NAME,DEFAULT) result(VALUE) + implicit none + character(len=*),intent(in) :: NAME + character(len=*),intent(in),optional :: DEFAULT + character(len=:),allocatable :: VALUE + integer :: howbig + integer :: stat + integer :: length + ! get length required to hold value + length=0 + if(NAME.ne.'')then + call get_environment_variable(NAME, length=howbig,status=stat,trim_name=.true.) + select case (stat) + case (1) + !*!print *, NAME, " is not defined in the environment. Strange..." + VALUE='' + case (2) + !*!print *, "This processor doesn't support environment variables. Boooh!" + VALUE='' + case default + ! make string to hold value of sufficient size + allocate(character(len=max(howbig,1)) :: VALUE) + ! get value + call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.) + if(stat.ne.0)VALUE='' + end select + else + VALUE='' + endif + if(VALUE.eq.''.and.present(DEFAULT))VALUE=DEFAULT + end function get_env + end module fpm_environment diff --git a/fpm/src/fpm_filesystem.f90 b/fpm/src/fpm_filesystem.f90 index 4c12314..ce0867e 100644 --- a/fpm/src/fpm_filesystem.f90 +++ b/fpm/src/fpm_filesystem.f90 @@ -31,10 +31,18 @@ function basename(path,suffix) result (base) if (with_suffix) then call split(path,file_parts,delimiters='\/') - base = trim(file_parts(size(file_parts))) + if(size(file_parts).gt.0)then + base = trim(file_parts(size(file_parts))) + else + base = '' + endif else call split(path,file_parts,delimiters='\/.') - base = trim(file_parts(size(file_parts)-1)) + if(size(file_parts).ge.2)then + base = trim(file_parts(size(file_parts)-1)) + else + base = '' + endif end if end function basename diff --git a/fpm/test/cli_test/cli_test.f90 b/fpm/test/cli_test/cli_test.f90 index 915d9da..fdb7979 100644 --- a/fpm/test/cli_test/cli_test.f90 +++ b/fpm/test/cli_test/cli_test.f90 @@ -28,9 +28,9 @@ 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 :: release,act_release ; namelist/act_cli/act_release +character(len=63) :: build_name,act_build_name ; namelist/act_cli/act_build_name character(len=:),allocatable :: args,act_args ; namelist/act_cli/act_args -namelist/expected/cmd,cstat,estat,w_e,w_t,name,release,args +namelist/expected/cmd,cstat,estat,w_e,w_t,name,build_name,args integer :: lun logical,allocatable :: tally(:) logical,allocatable :: subtally(:) @@ -50,19 +50,19 @@ character(len=*),parameter :: tests(*)= [ character(len=256) :: & 'CMD="run", ', & 'CMD="run my_project", NAME="my_project", ', & 'CMD="run proj1 p2 project3", NAME="proj1","p2","project3", ', & -'CMD="run proj1 p2 project3 --release", NAME="proj1","p2","project3",RELEASE=T,', & +'CMD="run proj1 p2 project3 --release", NAME="proj1","p2","project3",build_name="release",', & 'CMD="run proj1 p2 project3 --release -- arg1 -x ""and a long one""", & - &NAME="proj1","p2","project3",RELEASE=T ARGS="""arg1"" -x ""and a long one""", ', & + &NAME="proj1","p2","project3",build_name="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 --release", NAME="proj1","p2","project3",RELEASE=T,', & +'CMD="test proj1 p2 project3 --release", NAME="proj1","p2","project3",build_name="release",', & 'CMD="test proj1 p2 project3 --release -- arg1 -x ""and a long one""", & - &NAME="proj1","p2","project3",RELEASE=T ARGS="""arg1"" -x ""and a long one""", ', & + &NAME="proj1","p2","project3",build_name="release" ARGS="""arg1"" -x ""and a long one""", ', & -'CMD="build", NAME= RELEASE=F,ARGS="",', & -'CMD="build --release", NAME= RELEASE=T,ARGS="",', & +'CMD="build", NAME= build_name="debug",ARGS="",', & +'CMD="build --release", NAME= build_name="release",ARGS="",', & ' ' ] character(len=256) :: readme(3) @@ -90,7 +90,7 @@ if(command_argument_count().eq.0)then ! assume if called with no arguments to d endif ! blank out name group EXPECTED name=[(repeat(' ',len(name)),i=1,max_names)] ! the words on the command line sans the subcommand name - release=.false. ! --release + build_name="debug" ! --release w_e=.false. ! --app w_t=.false. ! --test args=repeat(' ',132) ! -- ARGS @@ -107,7 +107,7 @@ if(command_argument_count().eq.0)then ! assume if called with no arguments to d if(estat.eq.0)then open(file='_test_cli',newunit=lun,delim='quote') act_name=[(repeat(' ',len(act_name)),i=1,max_names)] - act_release=.false. + act_build_name='debug' act_w_e=.false. act_w_t=.false. act_args=repeat(' ',132) @@ -119,7 +119,7 @@ if(command_argument_count().eq.0)then ! assume if called with no arguments to d ! compare results to expected values subtally=[logical ::] call test_test('NAME',all(act_name.eq.name)) - call test_test('RELEASE',act_release.eqv.release) + call test_test('RELEASE',act_build_name.eq.build_name) 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) @@ -203,7 +203,7 @@ allocate (character(len=len(name)) :: act_name(0) ) act_args='' act_w_e=.false. act_w_t=.false. -act_release=.false. +act_build_name='debug' select type(settings=>cmd_settings) type is (fpm_new_settings) @@ -211,13 +211,13 @@ type is (fpm_new_settings) act_w_t=settings%with_test act_name=[trim(settings%name)] type is (fpm_build_settings) - act_release=settings%release + act_build_name=settings%build_name type is (fpm_run_settings) - act_release=settings%release + act_build_name=settings%build_name act_name=settings%name act_args=settings%args type is (fpm_test_settings) - act_release=settings%release + act_build_name=settings%build_name act_name=settings%name act_args=settings%args type is (fpm_install_settings) diff --git a/fpm/test/help_test/help_test.f90 b/fpm/test/help_test/help_test.f90 new file mode 100644 index 0000000..390b274 --- /dev/null +++ b/fpm/test/help_test/help_test.f90 @@ -0,0 +1,311 @@ +program help_test +! note hardcoded len=512 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 +implicit none +integer :: i, j +integer :: be, af +character(len=:),allocatable :: path +integer :: estat, cstat +character(len=512) :: message +logical,allocatable :: tally(:) +!intel-bug!character(len=:),allocatable :: book1(:), book2(:) +character(len=512),allocatable :: book1(:), book2(:), book3(:) +!intel-bug!character(len=:),allocatable :: page1(:) +character(len=512),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 +'fpm run -- --version ',& ! verify fpm version being used +'fpm run -- --help > fpm_scratch_help.txt',& +'fpm run -- help new >> fpm_scratch_help.txt',& +'fpm run -- build --help >> fpm_scratch_help.txt',& +'fpm run -- help run >> fpm_scratch_help.txt',& +'fpm run -- help test >> fpm_scratch_help.txt',& +'fpm run -- help runner >> fpm_scratch_help.txt',& +'fpm run -- help list >> fpm_scratch_help.txt',& +'fpm run -- help help >> fpm_scratch_help.txt',& +'fpm run -- --version >> fpm_scratch_help.txt',& +! release version +'fpm run --release -- --version ',& ! verify fpm version being used +'fpm run --release -- --help > fpm_scratch_help3.txt',& +'fpm run --release -- help new >> fpm_scratch_help3.txt',& +'fpm run --release -- build --help >> fpm_scratch_help3.txt',& +'fpm run --release -- help run >> fpm_scratch_help3.txt',& +'fpm run --release -- help test >> fpm_scratch_help3.txt',& +'fpm run --release -- help runner >> fpm_scratch_help3.txt',& +'fpm run --release -- help list >> fpm_scratch_help3.txt',& +'fpm run --release -- help help >> fpm_scratch_help3.txt',& +'fpm run --release -- --version >> fpm_scratch_help3.txt',& +! generate manual +'fpm run -- 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','build','run','test','runner','list','help'] +character(len=:),allocatable :: add + + write(*,'(g0:,1x)')'<INFO>TEST help SUBCOMMAND STARTED' + if(allocated(tally))deallocate(tally) + allocate(tally(0)) + call wipe('fpm_scratch_help.txt') + call wipe('fpm_scratch_help3.txt') + call wipe('fpm_scratch_manual.txt') + + ! check that output has NAME SYNOPSIS DESCRIPTION + do j=1,2 + if(j.eq.1)then + ADD=' ' + else + ADD=' --release ' + endif + do i=1,size(names) + write(*,*)'<INFO>check '//names(i)//' for NAME SYNOPSIS DESCRIPTION' + path= 'fpm run '//add//' -- help '//names(i)//' >fpm_scratch_help.txt' + message='' + call execute_command_line(path,exitstat=estat,cmdstat=cstat,cmdmsg=message) + write(*,'(*(g0))')'<INFO>CMD=',path,' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message) + tally=[tally,all([estat.eq.0,cstat.eq.0])] + call swallow('fpm_scratch_help.txt',page1) + if(size(page1).lt.3)then + write(*,*)'<ERROR>help for '//names(i)//' ridiculiously small' + tally=[tally,.false.] + exit + endif + !!write(*,*)findloc(page1,'NAME').eq.1 + be=count(.not.tally) + tally=[tally,count(page1.eq.'NAME').eq.1] + tally=[tally,count(page1.eq.'SYNOPSIS').eq.1] + tally=[tally,count(page1.eq.'DESCRIPTION').eq.1] + af=count(.not.tally) + if(be.ne.af)then + write(*,*)'<ERROR>missing expected sections in ',names(i) + write(*,*)page1(1) ! assuming at least size 1 for debugging mingw + write(*,*)count(page1.eq.'NAME') + write(*,*)count(page1.eq.'SYNOPSIS') + write(*,*)count(page1.eq.'DESCRIPTION') + write(*,'(a)')page1 + endif + write(*,*)'<INFO>have completed ',count(tally),' tests' + call wipe('fpm_scratch_help.txt') + enddo + enddo + + + ! execute the fpm(1) commands + do i=1,size(cmds) + message='' + path= cmds(i) + call execute_command_line(path,exitstat=estat,cmdstat=cstat,cmdmsg=message) + write(*,'(*(g0))')'<INFO>CMD=',path,' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message) + tally=[tally,all([estat.eq.0,cstat.eq.0])] + enddo + + ! compare book written in fragments with manual + call swallow('fpm_scratch_help.txt',book1) + call swallow('fpm_scratch_manual.txt',book2) + call swallow('fpm_scratch_help3.txt',book3) + ! get rid of lines from run() which is not on stderr at the moment + book1=pack(book1,index(book1,' + build/').eq.0) + book2=pack(book1,index(book2,' + build/').eq.0) + book3=pack(book3,index(book3,' + build/').eq.0) + write(*,*)'<INFO>book1 ',size(book1), len(book1) + write(*,*)'<INFO>book2 ',size(book2), len(book2) + write(*,*)'<INFO>book2 ',size(book3), len(book3) + if(size(book1).ne.size(book2))then + write(*,*)'<ERROR>manual and "debug" appended pages are not the same size' + tally=[tally,.false.] + else + if(all(book1.ne.book2))then + tally=[tally,.false.] + write(*,*)'<ERROR>manual and "debug" appended pages are not the same' + else + write(*,*)'<INFO>manual and "debug" appended pages are the same' + tally=[tally,.true.] + endif + endif + if(size(book3).ne.size(book2))then + write(*,*)'<ERROR>manual and "release" appended pages are not the same size' + tally=[tally,.false.] + else + if(all(book3.ne.book2))then + tally=[tally,.false.] + write(*,*)'<ERROR>manual and "release" appended pages are not the same' + else + write(*,*)'<INFO>manual and "release" appended pages are the same' + tally=[tally,.true.] + endif + endif + + ! overall size of manual + !chars=size(book2) + !lines=max(count(char(10).eq.book2),count(char(13).eq.book2)) + chars=sum(len_trim(book2)) ! SUM TRIMMED LENGTH + lines=size(book2) + if( (chars.lt.12000) .or. (lines.lt.350) )then + write(*,*)'<ERROR>"debug" manual is suspiciously small, bytes=',chars,' lines=',lines + tally=[tally,.false.] + else + write(*,*)'<INFO>"debug" manual size in bytes=',chars,' lines=',lines + tally=[tally,.true.] + endif + chars=sum(len_trim(book3)) ! SUM TRIMMED LENGTH + lines=size(book3) + if( (chars.lt.12000) .or. (lines.lt.350) )then + write(*,*)'<ERROR>"release" manual is suspiciously small, bytes=',chars,' lines=',lines + tally=[tally,.false.] + else + write(*,*)'<INFO>"release" manual size in bytes=',chars,' lines=',lines + tally=[tally,.true.] + endif + + write(*,'("<INFO>HELP TEST TALLY=",*(g0))')tally + call wipe('fpm_scratch_help.txt') + call wipe('fpm_scratch_help3.txt') + call wipe('fpm_scratch_manual.txt') + if(all(tally))then + write(*,'(*(g0))')'<INFO>PASSED: all ',count(tally),' tests passed ' + else + write(*,*)'<INFO>FAILED: PASSED=',count(tally),' FAILED=',count(.not.tally) + stop 5 + endif + write(*,'(g0:,1x)')'<INFO>TEST help SUBCOMMAND COMPLETE' +contains + +subroutine wipe(filename) +character(len=*),intent(in) :: filename +integer :: ios +integer :: lun +character(len=512) :: message +open(file=filename,newunit=lun,iostat=ios,iomsg=message) +if(ios.eq.0)then + close(unit=lun,iostat=ios,status='delete',iomsg=message) + if(ios.ne.0)then + write(*,*)'<ERROR>'//trim(message) + endif +else + write(*,*)'<ERROR>'//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=512) :: message +character(len=4096) :: local_filename + ios=0 + nchars=0 + message='' + open(newunit=igetunit, file=trim(filename), action="read", iomsg=message,& + &form="unformatted", access="stream",status='old',iostat=ios) + local_filename=filename + if(ios.eq.0)then ! if file was successfully opened + inquire(unit=igetunit, size=nchars) + if(nchars.le.0)then + call stderr_local( '*slurp* empty file '//trim(local_filename) ) + return + endif + ! read file into text array + if(allocated(text))deallocate(text) ! make sure text array not allocated + allocate ( text(nchars) ) ! make enough storage to hold file + read(igetunit,iostat=ios,iomsg=message) text ! load input file -> text array + if(ios.ne.0)then + call stderr_local( '*slurp* bad read of '//trim(local_filename)//':'//trim(message) ) + endif + else + call stderr_local('*slurp* '//message) + allocate ( text(0) ) ! make enough storage to hold file + endif + close(iostat=ios,unit=igetunit) ! close if opened successfully or not +end subroutine slurp + +subroutine stderr_local(message) +character(len=*) :: message + write(*,'(a)')trim(message) ! write message to standard error +end subroutine stderr_local + +subroutine swallow(FILENAME,pageout) +implicit none +character(len=*),intent(in) :: FILENAME ! file to read +!intel-bug!character(len=:),allocatable,intent(out) :: pageout(:) ! page to hold file in memory +character(len=512),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(*,*)'<ERROR>*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=512),allocatable :: table(:) +integer :: i +integer :: linelength +integer :: length +integer :: lines +integer :: linecount +integer :: position +integer :: sz +!!character(len=1),parameter :: nl=new_line('A') +character(len=1),parameter :: nl=char(10) +character(len=1),parameter :: cr=char(13) + lines=0 + linelength=0 + length=0 + sz=size(array) + do i=1,sz + if(array(i).eq.nl)then + linelength=max(linelength,length) + lines=lines+1 + length=0 + else + length=length+1 + endif + enddo + if(sz.gt.0)then + if(array(sz).ne.nl)then + lines=lines+1 + endif + endif + + if(allocated(table))deallocate(table) + !intel-bug!allocate(character(len=linelength) :: table(lines)) + allocate(character(len=512) :: table(lines)) + table=' ' + linecount=1 + position=1 + do i=1,sz + if(array(i).eq.nl)then + linecount=linecount+1 + position=1 + elseif(array(i).eq.cr)then + elseif(linelength.ne.0)then + if(position.gt.len(table))then + write(*,*)'<ERROR> adding character past edge of text',table(linecount),array(i) + elseif(linecount.gt.size(table))then + write(*,*)'<ERROR> 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 |