From 25c96eefc9764bf54a02a8286671b57851a239e9 Mon Sep 17 00:00:00 2001 From: "John S. Urban" Date: Wed, 15 Jan 2025 18:58:49 -0500 Subject: [PATCH 1/3] Cosmetic reformatting o changed to free format from fixed format o removed redundant implicit nones o changed from real(kind=8) to real(kind=wp) and defined WP in the main block of the module o renamed included files to .finc suffix instead of .f o added fpm manifest file and stub directories for test, example, app o added Makefile template --- app/main.f90 | 6 + aux/fpm.F90 | 44482 +++++++++++++++++++++ fpm.toml | 19 + src/libadd.finc | 84 + src/libasabqarray.finc | 34 + src/libasarray.finc | 54 + src/libassignarray.finc | 89 + src/libassignscalar.finc | 89 + src/libassignten2sym.finc | 35 + src/libcrossdyadic.finc | 42 + src/libddot.finc | 164 + src/libdet.finc | 25 + src/libdev.finc | 19 + src/libdiv.finc | 100 + src/libdot.finc | 308 + src/libdyadic.finc | 29 + src/libidentity.finc | 43 + src/libinv.finc | 73 + src/libnorm.finc | 26 + src/libpermute.finc | 63 + src/libpiola.finc | 85 + src/libpower.finc | 50 + src/libreducedim.finc | 19 + src/librotation.finc | 23 + src/libsqrt.finc | 86 + src/libstrainstore.finc | 42 + src/libsub.finc | 84 + src/libsymstore.finc | 88 + src/libtenstore.finc | 67 + src/libtools.finc | 12 + src/libtrace.finc | 17 + src/libtransp.finc | 38 + src/libunimodular.finc | 49 + ttb/ttb_library.f => src/ttb_library.f90 | 408 +- test/check.f90 | 5 + ttb/libadd.f | 94 - ttb/libasabqarray.f | 37 - ttb/libasarray.f | 59 - ttb/libassignarray.f | 99 - ttb/libassignscalar.f | 99 - ttb/libassignten2sym.f | 39 - ttb/libcrossdyadic.f | 44 - ttb/libddot.f | 177 - ttb/libdet.f | 27 - ttb/libdev.f | 21 - ttb/libdiv.f | 110 - ttb/libdot.f | 341 - ttb/libdyadic.f | 33 - ttb/libidentity.f | 47 - ttb/libinv.f | 77 - ttb/libnorm.f | 29 - ttb/libpermute.f | 71 - ttb/libpiola.f | 89 - ttb/libpower.f | 52 - ttb/libreducedim.f | 21 - ttb/librotation.f | 25 - ttb/libsqrt.f | 91 - ttb/libstrainstore.f | 43 - ttb/libsub.f | 93 - ttb/libsymstore.f | 93 - ttb/libtenstore.f | 74 - ttb/libtools.f | 12 - ttb/libtrace.f | 19 - ttb/libtransp.f | 43 - ttb/libunimodular.f | 53 - 65 files changed, 46654 insertions(+), 2315 deletions(-) create mode 100644 app/main.f90 create mode 100644 aux/fpm.F90 create mode 100644 fpm.toml create mode 100644 src/libadd.finc create mode 100644 src/libasabqarray.finc create mode 100644 src/libasarray.finc create mode 100644 src/libassignarray.finc create mode 100644 src/libassignscalar.finc create mode 100644 src/libassignten2sym.finc create mode 100644 src/libcrossdyadic.finc create mode 100644 src/libddot.finc create mode 100644 src/libdet.finc create mode 100644 src/libdev.finc create mode 100644 src/libdiv.finc create mode 100644 src/libdot.finc create mode 100644 src/libdyadic.finc create mode 100644 src/libidentity.finc create mode 100644 src/libinv.finc create mode 100644 src/libnorm.finc create mode 100644 src/libpermute.finc create mode 100644 src/libpiola.finc create mode 100644 src/libpower.finc create mode 100644 src/libreducedim.finc create mode 100644 src/librotation.finc create mode 100644 src/libsqrt.finc create mode 100644 src/libstrainstore.finc create mode 100644 src/libsub.finc create mode 100644 src/libsymstore.finc create mode 100644 src/libtenstore.finc create mode 100644 src/libtools.finc create mode 100644 src/libtrace.finc create mode 100644 src/libtransp.finc create mode 100644 src/libunimodular.finc rename ttb/ttb_library.f => src/ttb_library.f90 (61%) create mode 100644 test/check.f90 delete mode 100644 ttb/libadd.f delete mode 100644 ttb/libasabqarray.f delete mode 100644 ttb/libasarray.f delete mode 100644 ttb/libassignarray.f delete mode 100644 ttb/libassignscalar.f delete mode 100644 ttb/libassignten2sym.f delete mode 100644 ttb/libcrossdyadic.f delete mode 100644 ttb/libddot.f delete mode 100644 ttb/libdet.f delete mode 100644 ttb/libdev.f delete mode 100644 ttb/libdiv.f delete mode 100644 ttb/libdot.f delete mode 100644 ttb/libdyadic.f delete mode 100644 ttb/libidentity.f delete mode 100644 ttb/libinv.f delete mode 100644 ttb/libnorm.f delete mode 100644 ttb/libpermute.f delete mode 100644 ttb/libpiola.f delete mode 100644 ttb/libpower.f delete mode 100644 ttb/libreducedim.f delete mode 100644 ttb/librotation.f delete mode 100644 ttb/libsqrt.f delete mode 100644 ttb/libstrainstore.f delete mode 100644 ttb/libsub.f delete mode 100644 ttb/libsymstore.f delete mode 100644 ttb/libtenstore.f delete mode 100644 ttb/libtools.f delete mode 100644 ttb/libtrace.f delete mode 100644 ttb/libtransp.f delete mode 100644 ttb/libunimodular.f diff --git a/app/main.f90 b/app/main.f90 new file mode 100644 index 00000000..c7b00f7a --- /dev/null +++ b/app/main.f90 @@ -0,0 +1,6 @@ +program main +use Tensor +implicit none + + print *, "hello from project ttb" +end program main diff --git a/aux/fpm.F90 b/aux/fpm.F90 new file mode 100644 index 00000000..530f09b1 --- /dev/null +++ b/aux/fpm.F90 @@ -0,0 +1,44482 @@ +#define FPM_RELEASE_VERSION 0.10.1 +#define FPM_BOOTSTRAP +#undef linux +#undef unix +!>>>>> ././src/fpm_backend_console.f90 + +!># Build Backend Console +!> This module provides a lightweight implementation for printing to the console +!> and updating previously-printed console lines. It used by `[[fpm_backend_output]]` +!> for pretty-printing build status and progress. +!> +!> @note The implementation for updating previous lines relies on no other output +!> going to `stdout`/`stderr` except through the `console_t` object provided. +!> +!> @note All write statements to `stdout` are enclosed within OpenMP `critical` regions +!> +module fpm_backend_console +use iso_fortran_env, only: stdout=>output_unit +implicit none + +private +public :: console_t +public :: LINE_RESET +public :: COLOR_RED, COLOR_GREEN, COLOR_YELLOW, COLOR_RESET + +character(len=*), parameter :: ESC = char(27) +!> Escape code for erasing current line +character(len=*), parameter :: LINE_RESET = ESC//"[2K"//ESC//"[1G" +!> Escape code for moving up one line +character(len=*), parameter :: LINE_UP = ESC//"[1A" +!> Escape code for moving down one line +character(len=*), parameter :: LINE_DOWN = ESC//"[1B" +!> Escape code for red foreground color +character(len=*), parameter :: COLOR_RED = ESC//"[31m" +!> Escape code for green foreground color +character(len=*), parameter :: COLOR_GREEN = ESC//"[32m" +!> Escape code for yellow foreground color +character(len=*), parameter :: COLOR_YELLOW = ESC//"[93m" +!> Escape code to reset foreground color +character(len=*), parameter :: COLOR_RESET = ESC//"[0m" + +!> Console object +type console_t + !> Number of lines printed + integer :: n_line = 1 + +contains + !> Write a single line to the console + procedure :: write_line => console_write_line + !> Update a previously-written console line + procedure :: update_line => console_update_line +end type console_t + +contains + +!> Write a single line to the standard output +subroutine console_write_line(console,str,line,advance) + !> Console object + class(console_t), intent(inout) :: console + !> String to write + character(*), intent(in) :: str + !> Integer needed to later update console line + integer, intent(out), optional :: line + !> Advancing output (print newline?) + logical, intent(in), optional :: advance + + character(3) :: adv + + adv = "yes" + if (present(advance)) then + if (.not.advance) then + adv = "no" + end if + end if + + !$omp critical + + if (present(line)) then + line = console%n_line + end if + + write(stdout,'(A)',advance=trim(adv)) LINE_RESET//str + + if (adv=="yes") then + console%n_line = console%n_line + 1 + end if + + !$omp end critical + +end subroutine console_write_line + +!> Overwrite a previously-written line in standard output +subroutine console_update_line(console,line_no,str) + !> Console object + class(console_t), intent(in) :: console + !> Integer output from `[[console_write_line]]` + integer, intent(in) :: line_no + !> New string to overwrite line + character(*), intent(in) :: str + + integer :: n + + !$omp critical + + n = console%n_line - line_no + + ! Step back to line + write(stdout,'(A)',advance="no") repeat(LINE_UP,n)//LINE_RESET + + write(stdout,'(A)',advance="no") str + + ! Step forward to end + write(stdout,'(A)',advance="no") repeat(LINE_DOWN,n)//LINE_RESET + + !$omp end critical + +end subroutine console_update_line + +end module fpm_backend_console + +!>>>>> ././src/fpm_strings.f90 + +!> This module defines general procedures for **string operations** for both CHARACTER and +!! TYPE(STRING_T) variables +! +!>## general routines for performing __string operations__ +!! +!!### Types +!! - **TYPE(STRING_T)** define a type to contain strings of variable length +!!### Type Conversions +!! - [[F_STRING]] return Fortran **CHARACTER** variable when given a C-like array of +!! single characters terminated with a C_NULL_CHAR **CHARACTER** +!! - [[STR]] Converts **INTEGER** or** LOGICAL** to **CHARACTER** string +!!### Case +!! - [[LOWER]] Changes a string to lowercase over optional specified column range +!!### Parsing and joining +!! - [[SPLIT]] parse string on delimiter characters and store tokens into an allocatable array +!! - [[SPLIT_FIRST_LAST]] Computes the first and last indices of tokens in input string, delimited by the characters in set, +!! and stores them into first and last output arrays. +!! - [[STRING_CAT]] Concatenate an array of **type(string_t)** into a single **CHARACTER** variable +!! - [[JOIN]] append an array of **CHARACTER** variables into a single **CHARACTER** variable +!!### Testing +!! - [[STR_ENDS_WITH]] test if a **CHARACTER** string or array ends with a specified suffix +!! - [[STRING_ARRAY_CONTAINS]] Check if array of **TYPE(STRING_T)** matches a particular **CHARACTER** string +!! - **OPERATOR(.IN.)** Check if array of **TYPE(STRING_T)** matches a particular **CHARACTER** string +!! - [[GLOB]] function compares text strings, one of which can have wildcards ('*' or '?'). +!! - [[IS_FORTRAN_NAME]] determine whether a string is an acceptable Fortran entity name +!! - [[TO_FORTRAN_NAME]] replace allowed special but unusuable characters in names with underscore +!!### Whitespace +!! - [[NOTABS]] subroutine to expand tab characters assuming a tab space every eight characters +!! - [[DILATE]] function to expand tab characters assuming a tab space every eight characters +!! - [[LEN_TRIM]] Determine total trimmed length of **STRING_T** array +!!### Miscellaneous +!! - [[FNV_1A]] Hash a **CHARACTER(*)** string of default kind or a **TYPE(STRING_T)** array +!! - [[REPLACE]] Returns string with characters in charset replaced with target_char. +!! - [[RESIZE]] increase the size of a **TYPE(STRING_T)** array by N elements +!! +module fpm_strings +use iso_fortran_env, only: int64 +use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & + & stdout=>output_unit, & + & stderr=>error_unit +use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer, c_size_t +implicit none + +private +public :: f_string, lower, upper, split, split_first_last, str_ends_with, string_t, str_begins_with_str +public :: to_fortran_name, is_fortran_name +public :: string_array_contains, string_cat, len_trim, operator(.in.), fnv_1a +public :: replace, resize, str, join, glob +public :: notabs, dilate, remove_newline_characters, remove_characters_in_set +public :: operator(==) + +!> Module naming +public :: is_valid_module_name, is_valid_module_prefix, & + has_valid_custom_prefix, has_valid_standard_prefix, & + module_prefix_template, module_prefix_type + +type string_t + character(len=:), allocatable :: s +end type + +interface len_trim + module procedure :: string_len_trim + module procedure :: strings_len_trim +end interface len_trim + +interface resize + module procedure :: resize_string +end interface + +interface operator(.in.) + module procedure string_array_contains +end interface + +interface fnv_1a + procedure :: fnv_1a_char + procedure :: fnv_1a_string_t +end interface fnv_1a + +interface str_ends_with + procedure :: str_ends_with_str + procedure :: str_ends_with_any + procedure :: str_ends_with_any_string +end interface str_ends_with + +interface str + module procedure str_int, str_int64, str_logical +end interface + +interface string_t + module procedure new_string_t +end interface string_t + +interface f_string + module procedure f_string, f_string_cptr, f_string_cptr_n +end interface f_string + +interface operator(==) + module procedure string_is_same + module procedure string_arrays_same +end interface + +contains + +!> test if a CHARACTER string ends with a specified suffix +pure logical function str_ends_with_str(s, e) result(r) + character(*), intent(in) :: s, e + integer :: n1, n2 + n1 = len(s)-len(e)+1 + n2 = len(s) + if (n1 < 1) then + r = .false. + else + r = (s(n1:n2) == e) + end if +end function str_ends_with_str + +!> test if a CHARACTER string ends with any of an array of suffixs +pure logical function str_ends_with_any(s, e) result(r) + character(*), intent(in) :: s + character(*), intent(in) :: e(:) + + integer :: i + + r = .true. + do i=1,size(e) + + if (str_ends_with(s,trim(e(i)))) return + + end do + r = .false. + +end function str_ends_with_any + +!> Test if a CHARACTER string ends with any of an array of string suffixs +pure logical function str_ends_with_any_string(s, e) result(r) + character(*), intent(in) :: s + type(string_t), intent(in) :: e(:) + + integer :: i + + r = .true. + do i=1,size(e) + + if (str_ends_with(s,trim(e(i)%s))) return + + end do + r = .false. + +end function str_ends_with_any_string + +!> test if a CHARACTER string begins with a specified prefix +pure logical function str_begins_with_str(s, e, case_sensitive) result(r) + character(*), intent(in) :: s, e + logical, optional, intent(in) :: case_sensitive ! Default option: case sensitive + integer :: n1, n2 + logical :: lower_case + + ! Check if case sensitive + if (present(case_sensitive)) then + lower_case = .not.case_sensitive + else + lower_case = .false. + end if + + n1 = 1 + n2 = 1 + len(e)-1 + if (n2 > len(s)) then + r = .false. + elseif (lower_case) then + r = lower(s(n1:n2)) == lower(e) + else + r = (s(n1:n2) == e) + end if +end function str_begins_with_str + +!> return Fortran character variable when given a C-like array of +!! single characters terminated with a C_NULL_CHAR character +function f_string(c_string) + use iso_c_binding + character(len=1), intent(in) :: c_string(:) + character(:), allocatable :: f_string + + integer :: i, n + + i = 0 + do while(c_string(i+1) /= C_NULL_CHAR) + i = i + 1 + end do + n = i + + allocate(character(n) :: f_string) + do i=1,n + f_string(i:i) = c_string(i) + end do + +end function f_string + +!> return Fortran character variable when given a null-terminated c_ptr +function f_string_cptr(cptr) result(s) + type(c_ptr), intent(in), value :: cptr + character(len=:,kind=c_char), allocatable :: s + + interface + function c_strlen(s) result(r) bind(c, name="strlen") + import c_size_t, c_ptr + type(c_ptr), intent(in), value :: s + integer(kind=c_size_t) :: r + end function + end interface + + s = f_string_cptr_n(cptr, c_strlen(cptr)) +end function + +!> return Fortran character variable when given a null-terminated c_ptr and its length +function f_string_cptr_n(cptr, n) result(s) + type(c_ptr), intent(in), value :: cptr + integer(kind=c_size_t), intent(in) :: n + character(len=n,kind=c_char) :: s + character(len=n,kind=c_char), pointer :: sptr + + call c_f_pointer(cptr, sptr) + s = sptr +end function + +!> Hash a character(*) string of default kind +pure function fnv_1a_char(input, seed) result(hash) + character(*), intent(in) :: input + integer(int64), intent(in), optional :: seed + integer(int64) :: hash + + integer :: i + integer(int64), parameter :: FNV_OFFSET_32 = 2166136261_int64 + integer(int64), parameter :: FNV_PRIME_32 = 16777619_int64 + + if (present(seed)) then + hash = seed + else + hash = FNV_OFFSET_32 + end if + + do i=1,len(input) + hash = ieor(hash,iachar(input(i:i),int64)) * FNV_PRIME_32 + end do + +end function fnv_1a_char + +!> Hash a string_t array of default kind +pure function fnv_1a_string_t(input, seed) result(hash) + type(string_t), intent(in) :: input(:) + integer(int64), intent(in), optional :: seed + integer(int64) :: hash + + integer :: i + + hash = fnv_1a(input(1)%s,seed) + + do i=2,size(input) + hash = fnv_1a(input(i)%s,hash) + end do + +end function fnv_1a_string_t + +!>Author: John S. Urban +!!License: Public Domain +!! Changes a string to lowercase over optional specified column range +elemental pure function lower(str,begin,end) result (string) + + character(*), intent(In) :: str + character(len(str)) :: string + integer,intent(in),optional :: begin, end + integer :: i + integer :: ibegin, iend + string = str + + ibegin = 1 + if (present(begin))then + ibegin = max(ibegin,begin) + endif + + iend = len_trim(str) + if (present(end))then + iend= min(iend,end) + endif + + do i = ibegin, iend ! step thru each letter in the string in specified range + select case (str(i:i)) + case ('A':'Z') + string(i:i) = char(iachar(str(i:i))+32) ! change letter to miniscule + case default + end select + end do + +end function lower + + !!License: Public Domain + !! Changes a string to upprtcase over optional specified column range +elemental pure function upper(str,begin,end) result (string) + + character(*), intent(In) :: str + character(len(str)) :: string + integer,intent(in),optional :: begin, end + integer :: i + integer :: ibegin, iend + string = str + + ibegin = 1 + if (present(begin))then + ibegin = max(ibegin,begin) + endif + + iend = len_trim(str) + if (present(end))then + iend= min(iend,end) + endif + + do i = ibegin, iend ! step thru each letter in the string in specified range + select case (str(i:i)) + case ('a':'z') + string(i:i) = char(iachar(str(i:i))-32) ! change letter to capitalized + case default + end select + end do + +end function upper + +!> Helper function to generate a new string_t instance +!> (Required due to the allocatable component) +function new_string_t(s) result(string) + character(*), intent(in) :: s + type(string_t) :: string + + string%s = s + +end function new_string_t + +!> Check if array of TYPE(STRING_T) matches a particular CHARACTER string +!! +logical function string_array_contains(search_string,array) + character(*), intent(in) :: search_string + type(string_t), intent(in) :: array(:) + + integer :: i + + string_array_contains = any([(array(i)%s==search_string, & + i=1,size(array))]) + +end function string_array_contains + +!> Concatenate an array of type(string_t) into +!> a single CHARACTER variable +function string_cat(strings,delim) result(cat) + type(string_t), intent(in) :: strings(:) + character(*), intent(in), optional :: delim + character(:), allocatable :: cat + + integer :: i + character(:), allocatable :: delim_str + + if (size(strings) < 1) then + cat = '' + return + end if + + if (present(delim)) then + delim_str = delim + else + delim_str = '' + end if + + cat = strings(1)%s + do i=2,size(strings) + + cat = cat//delim_str//strings(i)%s + + end do + +end function string_cat + +!> Determine total trimmed length of `string_t` array +pure function strings_len_trim(strings) result(n) + type(string_t), intent(in) :: strings(:) + integer :: i, n + + n = 0 + do i=1,size(strings) + n = n + len_trim(strings(i)%s) + end do + +end function strings_len_trim + +!> Determine total trimmed length of `string_t` array +elemental integer function string_len_trim(string) result(n) + type(string_t), intent(in) :: string + + if (allocated(string%s)) then + n = len_trim(string%s) + else + n = 0 + end if + +end function string_len_trim + +!>Author: John S. Urban +!!License: Public Domain +!! parse string on delimiter characters and store tokens into an allocatable array +subroutine split(input_line,array,delimiters,order,nulls) + !! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. + !! + !! * by default adjacent delimiters in the input string do not create an empty string in the output array + !! * no quoting of delimiters is supported + character(len=*),intent(in) :: input_line !! input string to tokenize + character(len=*),optional,intent(in) :: delimiters !! list of delimiter characters + character(len=*),optional,intent(in) :: order !! order of output array sequential|[reverse|right] + character(len=*),optional,intent(in) :: nulls !! return strings composed of delimiters or not ignore|return|ignoreend + character(len=:),allocatable,intent(out) :: array(:) !! output array of tokens + + integer :: n ! max number of strings INPUT_LINE could split into if all delimiter + integer,allocatable :: ibegin(:) ! positions in input string where tokens start + integer,allocatable :: iterm(:) ! positions in input string where tokens end + character(len=:),allocatable :: dlim ! string containing delimiter characters + character(len=:),allocatable :: ordr ! string containing order keyword + character(len=:),allocatable :: nlls ! string containing nulls keyword + integer :: ii,iiii ! loop parameters used to control print order + integer :: icount ! number of tokens found + integer :: ilen ! length of input string with trailing spaces trimmed + integer :: i10,i20,i30 ! loop counters + integer :: icol ! pointer into input string as it is being parsed + integer :: idlim ! number of delimiter characters + integer :: ifound ! where next delimiter character is found in remaining input string data + integer :: inotnull ! count strings not composed of delimiters + integer :: ireturn ! number of tokens returned + integer :: imax ! length of longest token + + ! decide on value for optional DELIMITERS parameter + if (present(delimiters)) then ! optional delimiter list was present + if(delimiters/='')then ! if DELIMITERS was specified and not null use it + dlim=delimiters + else ! DELIMITERS was specified on call as empty string + dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified + endif + else ! no delimiter value was specified + dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified + endif + idlim=len(dlim) ! dlim a lot of blanks on some machines if dlim is a big string + + if(present(order))then; ordr=lower(adjustl(order)); else; ordr='sequential'; endif ! decide on value for optional ORDER parameter + if(present(nulls))then; nlls=lower(adjustl(nulls)); else; nlls='ignore' ; endif ! optional parameter + + n=len(input_line)+1 ! max number of strings INPUT_LINE could split into if all delimiter + allocate(ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens + allocate(iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens + ibegin(:)=1 + iterm(:)=1 + + ilen=len(input_line) ! ILEN is the column position of the last non-blank character + icount=0 ! how many tokens found + inotnull=0 ! how many tokens found not composed of delimiters + imax=0 ! length of longest token found + + select case (ilen) + + case (0) ! command was totally blank + + case default ! there is at least one non-delimiter in INPUT_LINE if get here + icol=1 ! initialize pointer into input line + INFINITE: do i30=1,ilen,1 ! store into each array element + ibegin(i30)=icol ! assume start new token on the character + if(index(dlim(1:idlim),input_line(icol:icol))==0)then ! if current character is not a delimiter + iterm(i30)=ilen ! initially assume no more tokens + do i10=1,idlim ! search for next delimiter + ifound=index(input_line(ibegin(i30):ilen),dlim(i10:i10)) + IF(ifound>0)then + iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2) + endif + enddo + icol=iterm(i30)+2 ! next place to look as found end of this token + inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters + else ! character is a delimiter for a null string + iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning + icol=icol+1 ! advance pointer into input string + endif + imax=max(imax,iterm(i30)-ibegin(i30)+1) + icount=i30 ! increment count of number of tokens found + if(icol>ilen)then ! no text left + exit INFINITE + endif + enddo INFINITE + + end select + + select case (trim(adjustl(nlls))) + case ('ignore','','ignoreend') + ireturn=inotnull + case default + ireturn=icount + end select + allocate(character(len=imax) :: array(ireturn)) ! allocate the array to return + !allocate(array(ireturn)) ! allocate the array to turn + + select case (trim(adjustl(ordr))) ! decide which order to store tokens + case ('reverse','right') ; ii=ireturn ; iiii=-1 ! last to first + case default ; ii=1 ; iiii=1 ! first to last + end select + + do i20=1,icount ! fill the array with the tokens that were found + if(iterm(i20) 0) then + p = 0 + do while (p < slen) + n = n + 1 + istart(n) = min(p + 1, slen) + call split_pos(string, set, p) + iend(n) = p - 1 + end do + end if + + first = istart(:n) + last = iend(:n) + +end subroutine split_first_last + +!! Author: Milan Curcic +!! If back is absent, computes the leftmost token delimiter in string whose +!! position is > pos. If back is present and true, computes the rightmost +!! token delimiter in string whose position is < pos. The result is stored +!! in pos. +pure subroutine split_pos(string, set, pos, back) + character(*), intent(in) :: string + character(*), intent(in) :: set + integer, intent(in out) :: pos + logical, intent(in), optional :: back + + logical :: backward + integer :: result_pos, bound + + if (len(string) == 0) then + pos = 1 + return + end if + + !TODO use optval when implemented in stdlib + !backward = optval(back, .false.) + backward = .false. + if (present(back)) backward = back + + if (backward) then + bound = min(len(string), max(pos - 1, 0)) + result_pos = scan(string(:bound), set, back=.true.) + else + result_pos = scan(string(min(pos + 1, len(string)):), set) + pos + if (result_pos < pos + 1) result_pos = len(string) + 1 + end if + + pos = result_pos + +end subroutine split_pos + +!> Returns string with characters in charset replaced with target_char. +pure function replace(string, charset, target_char) result(res) + character(*), intent(in) :: string + character, intent(in) :: charset(:), target_char + character(len(string)) :: res + integer :: n + res = string + do n = 1, len(string) + if (any(string(n:n) == charset)) then + res(n:n) = target_char + end if + end do +end function replace + +!> increase the size of a TYPE(STRING_T) array by N elements +subroutine resize_string(list, n) + !> Instance of the array to be resized + type(string_t), allocatable, intent(inout) :: list(:) + !> Dimension of the final array size + integer, intent(in), optional :: n + + type(string_t), allocatable :: tmp(:) + integer :: this_size, new_size, i + integer, parameter :: initial_size = 16 + + if (allocated(list)) then + this_size = size(list, 1) + call move_alloc(list, tmp) + else + this_size = initial_size + end if + + if (present(n)) then + new_size = n + else + new_size = this_size + this_size/2 + 1 + end if + + allocate(list(new_size)) + + if (allocated(tmp)) then + this_size = min(size(tmp, 1), size(list, 1)) + do i = 1, this_size + call move_alloc(tmp(i)%s, list(i)%s) + end do + deallocate(tmp) + end if + +end subroutine resize_string + +!>AUTHOR: John S. Urban +!!LICENSE: Public Domain +!> +!!##NAME +!! join(3f) - [M_strings:EDITING] append CHARACTER variable array into +!! a single CHARACTER variable with specified separator +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! pure function join(str,sep,trm,left,right,start,end) result (string) +!! +!! character(len=*),intent(in) :: str(:) +!! character(len=*),intent(in),optional :: sep +!! logical,intent(in),optional :: trm +!! character(len=*),intent(in),optional :: right +!! character(len=*),intent(in),optional :: left +!! character(len=*),intent(in),optional :: start +!! character(len=*),intent(in),optional :: end +!! character(len=:),allocatable :: string +!! +!!##DESCRIPTION +!! JOIN(3f) appends the elements of a CHARACTER array into a single +!! CHARACTER variable, with elements 1 to N joined from left to right. +!! By default each element is trimmed of trailing spaces and the +!! default separator is a null string. +!! +!!##OPTIONS +!! STR(:) array of CHARACTER variables to be joined +!! SEP separator string to place between each variable. defaults +!! to a null string. +!! LEFT string to place at left of each element +!! RIGHT string to place at right of each element +!! START prefix string +!! END suffix string +!! TRM option to trim each element of STR of trailing +!! spaces. Defaults to .TRUE. +!! +!!##RESULT +!! STRING CHARACTER variable composed of all of the elements of STR() +!! appended together with the optional separator SEP placed +!! between the elements. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_join +!! use M_strings, only: join +!! implicit none +!! character(len=:),allocatable :: s(:) +!! character(len=:),allocatable :: out +!! integer :: i +!! s=[character(len=10) :: 'United',' we',' stand,', & +!! & ' divided',' we fall.'] +!! out=join(s) +!! write(*,'(a)') out +!! write(*,'(a)') join(s,trm=.false.) +!! write(*,'(a)') (join(s,trm=.false.,sep='|'),i=1,3) +!! write(*,'(a)') join(s,sep='<>') +!! write(*,'(a)') join(s,sep=';',left='[',right=']') +!! write(*,'(a)') join(s,left='[',right=']') +!! write(*,'(a)') join(s,left='>>') +!! end program demo_join +!! +!! Expected output: +!! +!! United we stand, divided we fall. +!! United we stand, divided we fall. +!! United | we | stand, | divided | we fall. +!! United | we | stand, | divided | we fall. +!! United | we | stand, | divided | we fall. +!! United<> we<> stand,<> divided<> we fall. +!! [United];[ we];[ stand,];[ divided];[ we fall.] +!! [United][ we][ stand,][ divided][ we fall.] +!! >>United>> we>> stand,>> divided>> we fall. +pure function join(str,sep,trm,left,right,start,end) result (string) + +! @(#)M_strings::join(3f): merge string array into a single CHARACTER value adding specified separators, caps, prefix and suffix + +character(len=*),intent(in) :: str(:) +character(len=*),intent(in),optional :: sep, right, left, start, end +logical,intent(in),optional :: trm +character(len=:),allocatable :: sep_local, left_local, right_local +character(len=:),allocatable :: string +logical :: trm_local +integer :: i + if(present(sep))then ; sep_local=sep ; else ; sep_local='' ; endif + if(present(trm))then ; trm_local=trm ; else ; trm_local=.true. ; endif + if(present(left))then ; left_local=left ; else ; left_local='' ; endif + if(present(right))then ; right_local=right ; else ; right_local='' ; endif + string='' + if(size(str)==0)then + string=string//left_local//right_local + else + do i = 1,size(str)-1 + if(trm_local)then + string=string//left_local//trim(str(i))//right_local//sep_local + else + string=string//left_local//str(i)//right_local//sep_local + endif + enddo + if(trm_local)then + string=string//left_local//trim(str(i))//right_local + else + string=string//left_local//str(i)//right_local + endif + endif + if(present(start))string=start//string + if(present(end))string=string//end +end function join + +!>AUTHOR: John S. Urban +!!LICENSE: Public Domain +!> +!!## NAME +!! glob(3f) - [fpm_strings:COMPARE] compare given string for match to +!! pattern which may contain wildcard characters +!! (LICENSE:PD) +!! +!!## SYNOPSIS +!! +!! logical function glob(string, pattern ) +!! +!! character(len=*),intent(in) :: string +!! character(len=*),intent(in) :: pattern +!! +!!## DESCRIPTION +!! glob(3f) compares given STRING for match to PATTERN which may +!! contain wildcard characters. +!! +!! In this version to get a match the entire string must be described +!! by PATTERN. Trailing whitespace is significant, so trim the input +!! string to have trailing whitespace ignored. +!! +!!## OPTIONS +!! string the input string to test to see if it contains the pattern. +!! pattern the following simple globbing options are available +!! +!! o "?" matching any one character +!! o "*" matching zero or more characters. +!! Do NOT use adjacent asterisks. +!! o Both strings may have trailing spaces which +!! are ignored. +!! o There is no escape character, so matching strings with +!! literal question mark and asterisk is problematic. +!! +!!## EXAMPLES +!! +!! Example program +!! +!! program demo_glob +!! implicit none +!! ! This main() routine passes a bunch of test strings +!! ! into the above code. In performance comparison mode, +!! ! it does that over and over. Otherwise, it does it just +!! ! once. Either way, it outputs a passed/failed result. +!! ! +!! integer :: nReps +!! logical :: allpassed +!! integer :: i +!! allpassed = .true. +!! +!! nReps = 10000 +!! ! Can choose as many repetitions as you're expecting +!! ! in the real world. +!! nReps = 1 +!! +!! do i=1,nReps +!! ! Cases with repeating character sequences. +!! allpassed=allpassed .and. test("a*abab", "a*b", .true.) +!! !!cycle +!! allpassed=allpassed .and. test("ab", "*?", .true.) +!! allpassed=allpassed .and. test("abc", "*?", .true.) +!! allpassed=allpassed .and. test("abcccd", "*ccd", .true.) +!! allpassed=allpassed .and. test("bLah", "bLaH", .false.) +!! allpassed=allpassed .and. test("mississippi", "*sip*", .true.) +!! allpassed=allpassed .and. & +!! & test("xxxx*zzzzzzzzy*f", "xxx*zzy*f", .true.) +!! allpassed=allpassed .and. & +!! & test("xxxx*zzzzzzzzy*f", "xxxx*zzy*fffff", .false.) +!! allpassed=allpassed .and. & +!! & test("mississipissippi", "*issip*ss*", .true.) +!! allpassed=allpassed .and. & +!! & test("xxxxzzzzzzzzyf", "xxxx*zzy*fffff", .false.) +!! allpassed=allpassed .and. & +!! & test("xxxxzzzzzzzzyf", "xxxx*zzy*f", .true.) +!! allpassed=allpassed .and. test("xyxyxyzyxyz", "xy*z*xyz", .true.) +!! allpassed=allpassed .and. test("xyxyxyxyz", "xy*xyz", .true.) +!! allpassed=allpassed .and. test("mississippi", "mi*sip*", .true.) +!! allpassed=allpassed .and. test("ababac", "*abac*", .true.) +!! allpassed=allpassed .and. test("aaazz", "a*zz*", .true.) +!! allpassed=allpassed .and. test("a12b12", "*12*23", .false.) +!! allpassed=allpassed .and. test("a12b12", "a12b", .false.) +!! allpassed=allpassed .and. test("a12b12", "*12*12*", .true.) +!! +!! ! Additional cases where the '*' char appears in the tame string. +!! allpassed=allpassed .and. test("*", "*", .true.) +!! allpassed=allpassed .and. test("a*r", "a*", .true.) +!! allpassed=allpassed .and. test("a*ar", "a*aar", .false.) +!! +!! ! More double wildcard scenarios. +!! allpassed=allpassed .and. test("XYXYXYZYXYz", "XY*Z*XYz", .true.) +!! allpassed=allpassed .and. test("missisSIPpi", "*SIP*", .true.) +!! allpassed=allpassed .and. test("mississipPI", "*issip*PI", .true.) +!! allpassed=allpassed .and. test("xyxyxyxyz", "xy*xyz", .true.) +!! allpassed=allpassed .and. test("miSsissippi", "mi*sip*", .true.) +!! allpassed=allpassed .and. test("miSsissippi", "mi*Sip*", .false.) +!! allpassed=allpassed .and. test("abAbac", "*Abac*", .true.) +!! allpassed=allpassed .and. test("aAazz", "a*zz*", .true.) +!! allpassed=allpassed .and. test("A12b12", "*12*23", .false.) +!! allpassed=allpassed .and. test("a12B12", "*12*12*", .true.) +!! allpassed=allpassed .and. test("oWn", "*oWn*", .true.) +!! +!! ! Completely tame (no wildcards) cases. +!! allpassed=allpassed .and. test("bLah", "bLah", .true.) +!! +!! ! Simple mixed wildcard tests suggested by IBMer Marlin Deckert. +!! allpassed=allpassed .and. test("a", "*?", .true.) +!! +!! ! More mixed wildcard tests including coverage for false positives. +!! allpassed=allpassed .and. test("a", "??", .false.) +!! allpassed=allpassed .and. test("ab", "?*?", .true.) +!! allpassed=allpassed .and. test("ab", "*?*?*", .true.) +!! allpassed=allpassed .and. test("abc", "?**?*?", .true.) +!! allpassed=allpassed .and. test("abc", "?**?*&?", .false.) +!! allpassed=allpassed .and. test("abcd", "?b*??", .true.) +!! allpassed=allpassed .and. test("abcd", "?a*??", .false.) +!! allpassed=allpassed .and. test("abcd", "?**?c?", .true.) +!! allpassed=allpassed .and. test("abcd", "?**?d?", .false.) +!! allpassed=allpassed .and. test("abcde", "?*b*?*d*?", .true.) +!! +!! ! Single-character-match cases. +!! allpassed=allpassed .and. test("bLah", "bL?h", .true.) +!! allpassed=allpassed .and. test("bLaaa", "bLa?", .false.) +!! allpassed=allpassed .and. test("bLah", "bLa?", .true.) +!! allpassed=allpassed .and. test("bLaH", "?Lah", .false.) +!! allpassed=allpassed .and. test("bLaH", "?LaH", .true.) +!! +!! ! Many-wildcard scenarios. +!! allpassed=allpassed .and. test(& +!! &"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa& +!! &aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaab",& +!! &"a*a*a*a*a*a*aa*aaa*a*a*b",& +!! &.true.) +!! allpassed=allpassed .and. test(& +!! &"abababababababababababababababababababaacacacacacacac& +!! &adaeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& +!! &"*a*b*ba*ca*a*aa*aaa*fa*ga*b*",& +!! &.true.) +!! allpassed=allpassed .and. test(& +!! &"abababababababababababababababababababaacacacacacaca& +!! &cadaeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& +!! &"*a*b*ba*ca*a*x*aaa*fa*ga*b*",& +!! &.false.) +!! allpassed=allpassed .and. test(& +!! &"abababababababababababababababababababaacacacacacacacad& +!! &aeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& +!! &"*a*b*ba*ca*aaaa*fa*ga*gggg*b*",& +!! &.false.) +!! allpassed=allpassed .and. test(& +!! &"abababababababababababababababababababaacacacacacacacad& +!! &aeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& +!! &"*a*b*ba*ca*aaaa*fa*ga*ggg*b*",& +!! &.true.) +!! allpassed=allpassed .and. test("aaabbaabbaab", "*aabbaa*a*", .true.) +!! allpassed=allpassed .and. & +!! test("a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*",& +!! &"a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .true.) +!! allpassed=allpassed .and. test("aaaaaaaaaaaaaaaaa",& +!! &"*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .true.) +!! allpassed=allpassed .and. test("aaaaaaaaaaaaaaaa",& +!! &"*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .false.) +!! allpassed=allpassed .and. test(& +!! &"abc*abcd*abcde*abcdef*abcdefg*abcdefgh*abcdefghi*abcdefghij& +!! &*abcdefghijk*abcdefghijkl*abcdefghijklm*abcdefghijklmn",& +!! & "abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc& +!! &*abc*abc*abc*",& +!! &.false.) +!! allpassed=allpassed .and. test(& +!! &"abc*abcd*abcde*abcdef*abcdefg*abcdefgh*abcdefghi*abcdefghij& +!! &*abcdefghijk*abcdefghijkl*abcdefghijklm*abcdefghijklmn",& +!! &"abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*",& +!! &.true.) +!! allpassed=allpassed .and. test("abc*abcd*abcd*abc*abcd",& +!! &"abc*abc*abc*abc*abc", .false.) +!! allpassed=allpassed .and. test( "abc*abcd*abcd*abc*abcd*abcd& +!! &*abc*abcd*abc*abc*abcd", & +!! &"abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abcd",& +!! &.true.) +!! allpassed=allpassed .and. test("abc",& +!! &"********a********b********c********", .true.) +!! allpassed=allpassed .and.& +!! &test("********a********b********c********", "abc", .false.) +!! allpassed=allpassed .and. & +!! &test("abc", "********a********b********b********", .false.) +!! allpassed=allpassed .and. test("*abc*", "***a*b*c***", .true.) +!! +!! ! A case-insensitive algorithm test. +!! ! allpassed=allpassed .and. test("mississippi", "*issip*PI", .true.) +!! enddo +!! +!! if (allpassed)then +!! write(*,'(a)')"Passed",nReps +!! else +!! write(*,'(a)')"Failed" +!! endif +!! contains +!! ! This is a test program for wildcard matching routines. +!! ! It can be used either to test a single routine for correctness, +!! ! or to compare the timings of two (or more) different wildcard +!! ! matching routines. +!! ! +!! function test(tame, wild, bExpectedResult) result(bpassed) +!! use fpm_strings, only : glob +!! character(len=*) :: tame +!! character(len=*) :: wild +!! logical :: bExpectedResult +!! logical :: bResult +!! logical :: bPassed +!! bResult = .true. ! We'll do "&=" cumulative checking. +!! bPassed = .false. ! Assume the worst. +!! write(*,*)repeat('=',79) +!! bResult = glob(tame, wild) ! Call a wildcard matching routine. +!! +!! ! To assist correctness checking, output the two strings in any +!! ! failing scenarios. +!! if (bExpectedResult .eqv. bResult) then +!! bPassed = .true. +!! if(nReps == 1) write(*,*)"Passed match on ",tame," vs. ", wild +!! else +!! if(nReps == 1) write(*,*)"Failed match on ",tame," vs. ", wild +!! endif +!! +!! end function test +!! end program demo_glob +!! +!! Expected output +!! +!! +!!## REFERENCE +!! The article "Matching Wildcards: An Empirical Way to Tame an Algorithm" +!! in Dr Dobb's Journal, By Kirk J. Krauss, October 07, 2014 +!! +function glob(tame,wild) + +! @(#)fpm_strings::glob(3f): function compares text strings, one of which can have wildcards ('*' or '?'). + +logical :: glob !! result of test +character(len=*) :: tame !! A string without wildcards to compare to the globbing expression +character(len=*) :: wild !! A (potentially) corresponding string with wildcards +character(len=len(tame)+1) :: tametext +character(len=len(wild)+1) :: wildtext +character(len=1),parameter :: NULL=char(0) +integer :: wlen +integer :: ti, wi +integer :: i +character(len=:),allocatable :: tbookmark, wbookmark +! These two values are set when we observe a wildcard character. They +! represent the locations, in the two strings, from which we start once we've observed it. + tametext=tame//NULL + wildtext=wild//NULL + tbookmark = NULL + wbookmark = NULL + wlen=len(wild) + wi=1 + ti=1 + do ! Walk the text strings one character at a time. + if(wildtext(wi:wi) == '*')then ! How do you match a unique text string? + do i=wi,wlen ! Easy: unique up on it! + if(wildtext(wi:wi)=='*')then + wi=wi+1 + else + exit + endif + enddo + if(wildtext(wi:wi)==NULL) then ! "x" matches "*" + glob=.true. + return + endif + if(wildtext(wi:wi) /= '?') then + ! Fast-forward to next possible match. + do while (tametext(ti:ti) /= wildtext(wi:wi)) + ti=ti+1 + if (tametext(ti:ti)==NULL)then + glob=.false. + return ! "x" doesn't match "*y*" + endif + enddo + endif + wbookmark = wildtext(wi:) + tbookmark = tametext(ti:) + elseif(tametext(ti:ti) /= wildtext(wi:wi) .and. wildtext(wi:wi) /= '?') then + ! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry. + if(wbookmark/=NULL) then + if(wildtext(wi:)/= wbookmark) then + wildtext = wbookmark; + wlen=len_trim(wbookmark) + wi=1 + ! Don't go this far back again. + if (tametext(ti:ti) /= wildtext(wi:wi)) then + tbookmark=tbookmark(2:) + tametext = tbookmark + ti=1 + cycle ! "xy" matches "*y" + else + wi=wi+1 + endif + endif + if (tametext(ti:ti)/=NULL) then + ti=ti+1 + cycle ! "mississippi" matches "*sip*" + endif + endif + glob=.false. + return ! "xy" doesn't match "x" + endif + ti=ti+1 + wi=wi+1 + if (tametext(ti:ti)==NULL) then ! How do you match a tame text string? + if(wildtext(wi:wi)/=NULL)then + do while (wildtext(wi:wi) == '*') ! The tame way: unique up on it! + wi=wi+1 ! "x" matches "x*" + if(wildtext(wi:wi)==NULL)exit + enddo + endif + if (wildtext(wi:wi)==NULL)then + glob=.true. + return ! "x" matches "x" + endif + glob=.false. + return ! "x" doesn't match "xy" + endif + enddo +end function glob + +!> Returns the length of the string representation of 'i' +pure integer function str_int_len(i) result(sz) +integer, intent(in) :: i +integer, parameter :: MAX_STR = 100 +character(MAX_STR) :: s +! If 's' is too short (MAX_STR too small), Fortran will abort with: +! "Fortran runtime error: End of record" +write(s, '(i0)') i +sz = len_trim(s) +end function + +!> Converts integer "i" to string +pure function str_int(i) result(s) +integer, intent(in) :: i +character(len=str_int_len(i)) :: s +write(s, '(i0)') i +end function + +!> Returns the length of the string representation of 'i' +pure integer function str_int64_len(i) result(sz) +integer(int64), intent(in) :: i +integer, parameter :: MAX_STR = 100 +character(MAX_STR) :: s +! If 's' is too short (MAX_STR too small), Fortran will abort with: +! "Fortran runtime error: End of record" +write(s, '(i0)') i +sz = len_trim(s) +end function + +!> Converts integer "i" to string +pure function str_int64(i) result(s) +integer(int64), intent(in) :: i +character(len=str_int64_len(i)) :: s +write(s, '(i0)') i +end function + +!> Returns the length of the string representation of 'l' +pure integer function str_logical_len(l) result(sz) +logical, intent(in) :: l +if (l) then + sz = 6 +else + sz = 7 +end if +end function + +!> Converts logical "l" to string +pure function str_logical(l) result(s) +logical, intent(in) :: l +character(len=str_logical_len(l)) :: s +if (l) then + s = ".true." +else + s = ".false." +end if +end function + +!> Returns string with special characters replaced with an underscore. +!! For now, only a hyphen is treated as a special character, but this can be +!! expanded to other characters if needed. +pure function to_fortran_name(string) result(res) + character(*), intent(in) :: string + character(len(string)) :: res + character, parameter :: SPECIAL_CHARACTERS(*) = ['-'] + res = replace(string, SPECIAL_CHARACTERS, '_') +end function to_fortran_name + +elemental function is_fortran_name(line) result (lout) +! determine if a string is a valid Fortran name ignoring trailing spaces +! (but not leading spaces) + character(len=*),parameter :: int='0123456789' + character(len=*),parameter :: lower='abcdefghijklmnopqrstuvwxyz' + character(len=*),parameter :: upper='ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(len=*),parameter :: allowed=upper//lower//int//'_' + character(len=*),intent(in) :: line + character(len=:),allocatable :: name + logical :: lout + name=trim(line) + if(len(name)/=0)then + lout = .true. & + & .and. verify(name(1:1), lower//upper) == 0 & + & .and. verify(name,allowed) == 0 & + & .and. len(name) <= 63 + else + lout = .false. + endif +end function is_fortran_name + +!> Check that a module name fits the current naming rules: +!> 1) It must be a valid FORTRAN name (<=63 chars, begin with letter, "_" is only allowed non-alphanumeric) +!> 2) It must begin with the package name +!> 3) If longer, package name must be followed by default separator plus at least one char +logical function is_valid_module_name(module_name,package_name,custom_prefix,enforce_module_names) result(valid) + + type(string_t), intent(in) :: module_name + type(string_t), intent(in) :: package_name + type(string_t), intent(in) :: custom_prefix + logical , intent(in) :: enforce_module_names + + !> Basic check: check the name is Fortran-compliant + valid = is_fortran_name(module_name%s); if (.not.valid) return + + !> FPM package enforcing: check that the module name begins with the package name + if (enforce_module_names) then + + ! Default prefixing is always valid + valid = has_valid_standard_prefix(module_name,package_name) + + ! If a custom prefix was validated, it provides additional naming options + ! Because they never overlap with the default prefix, the former is always an option + if (len_trim(custom_prefix)>0 .and. .not.valid) & + valid = has_valid_custom_prefix(module_name,custom_prefix) + + end if + +end function is_valid_module_name + +!> Check that a custom module prefix fits the current naming rules: +!> 1) Only alphanumeric characters (no spaces, dashes, underscores or other characters) +!> 2) Does not begin with a number (Fortran-compatible syntax) +logical function is_valid_module_prefix(module_prefix) result(valid) + + type(string_t), intent(in) :: module_prefix + + character(len=*),parameter :: num='0123456789' + character(len=*),parameter :: lower='abcdefghijklmnopqrstuvwxyz' + character(len=*),parameter :: upper='ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(len=*),parameter :: alpha =upper//lower + character(len=*),parameter :: allowed=alpha//num + + character(len=:),allocatable :: name + + name = trim(module_prefix%s) + + if (len(name)>0 .and. len(name)<=63) then + valid = verify(name(1:1), alpha) == 0 .and. & + verify(name,allowed) == 0 + else + valid = .false. + endif + +end function is_valid_module_prefix + +type(string_t) function module_prefix_template(project_name,custom_prefix) result(prefix) + type(string_t), intent(in) :: project_name + type(string_t), intent(in) :: custom_prefix + + if (is_valid_module_prefix(custom_prefix)) then + + prefix = string_t(trim(custom_prefix%s)//"_") + + else + + prefix = string_t(to_fortran_name(project_name%s)//"__") + + end if + +end function module_prefix_template + +type(string_t) function module_prefix_type(project_name,custom_prefix) result(ptype) + type(string_t), intent(in) :: project_name + type(string_t), intent(in) :: custom_prefix + + if (is_valid_module_prefix(custom_prefix)) then + ptype = string_t("custom") + else + ptype = string_t("default") + end if + +end function module_prefix_type + +!> Check that a module name is prefixed with a custom prefix: +!> 1) It must be a valid FORTRAN name subset (<=63 chars, begin with letter, only alphanumeric allowed) +!> 2) It must begin with the prefix +!> 3) If longer, package name must be followed by default separator ("_") plus at least one char +logical function has_valid_custom_prefix(module_name,custom_prefix) result(valid) + + type(string_t), intent(in) :: module_name + type(string_t), intent(in) :: custom_prefix + + !> custom_module separator: single underscore + character(*), parameter :: SEP = "_" + + logical :: is_same,has_separator,same_beginning + integer :: lpkg,lmod,lsep + + !> Basic check: check that both names are individually valid + valid = is_fortran_name(module_name%s) .and. & + is_valid_module_prefix(custom_prefix) + + !> FPM package enforcing: check that the module name begins with the custom prefix + if (valid) then + + !> Query string lengths + lpkg = len_trim(custom_prefix) + lmod = len_trim(module_name) + lsep = len_trim(SEP) + + same_beginning = str_begins_with_str(module_name%s,custom_prefix%s,case_sensitive=.false.) + + is_same = lpkg==lmod .and. same_beginning + + if (lmod>=lpkg+lsep) then + has_separator = str_begins_with_str(module_name%s(lpkg+1:lpkg+lsep),SEP) + else + has_separator = .false. + endif + + !> 2) It must begin with the package name. + !> 3) It can be equal to the package name, or, if longer, must be followed by the + ! default separator plus at least one character + !> 4) Package name must not end with an underscore + valid = same_beginning .and. (is_same .or. (lmod>lpkg+lsep .and. has_separator)) + + end if + +end function has_valid_custom_prefix + +!> Check that a module name is prefixed with the default package prefix: +!> 1) It must be a valid FORTRAN name (<=63 chars, begin with letter, "_" is only allowed non-alphanumeric) +!> 2) It must begin with the package name +!> 3) If longer, package name must be followed by default separator plus at least one char +logical function has_valid_standard_prefix(module_name,package_name) result(valid) + + type(string_t), intent(in) :: module_name + type(string_t), intent(in) :: package_name + + !> Default package__module separator: two underscores + character(*), parameter :: SEP = "__" + + character(len=:), allocatable :: fortranized_pkg + logical :: is_same,has_separator,same_beginning + integer :: lpkg,lmod,lsep + + !> Basic check: check the name is Fortran-compliant + valid = is_fortran_name(module_name%s) + + !> FPM package enforcing: check that the module name begins with the package name + if (valid) then + + fortranized_pkg = to_fortran_name(package_name%s) + + !> Query string lengths + lpkg = len_trim(fortranized_pkg) + lmod = len_trim(module_name) + lsep = len_trim(SEP) + + same_beginning = str_begins_with_str(module_name%s,fortranized_pkg,case_sensitive=.false.) + + is_same = lpkg==lmod .and. same_beginning + + if (lmod>=lpkg+lsep) then + has_separator = str_begins_with_str(module_name%s(lpkg+1:lpkg+lsep),SEP) + else + has_separator = .false. + endif + + !> 2) It must begin with the package name. + !> 3) It can be equal to the package name, or, if longer, must be followed by the + ! default separator plus at least one character + !> 4) Package name must not end with an underscore + valid = is_fortran_name(fortranized_pkg) .and. & + fortranized_pkg(lpkg:lpkg)/='_' .and. & + (same_beginning .and. (is_same .or. (lmod>lpkg+lsep .and. has_separator))) + + end if + +end function has_valid_standard_prefix + +!> Check that two string _objects_ are exactly identical +pure logical function string_is_same(this,that) + !> two strings to be compared + type(string_t), intent(in) :: this, that + + integer :: i + + string_is_same = .false. + + if (allocated(this%s).neqv.allocated(that%s)) return + if (allocated(this%s)) then + if (.not.len(this%s)==len(that%s)) return + if (.not.len_trim(this%s)==len_trim(that%s)) return + do i=1,len_trim(this%s) + if (.not.(this%s(i:i)==that%s(i:i))) return + end do + end if + + ! All checks passed + string_is_same = .true. + +end function string_is_same + +!> Check that two allocatable string _object_ arrays are exactly identical +pure logical function string_arrays_same(this,that) + !> two string arrays to be compared + type(string_t), allocatable, intent(in) :: this(:), that(:) + + integer :: i + + string_arrays_same = .false. + + if (allocated(this).neqv.allocated(that)) return + if (allocated(this)) then + if (.not.(size(this)==size(that))) return + if (.not.(ubound(this,1)==ubound(that,1))) return + if (.not.(lbound(this,1)==lbound(that,1))) return + do i=lbound(this,1),ubound(this,1) + if (.not.string_is_same(this(i),that(i))) return + end do + end if + + ! All checks passed + string_arrays_same = .true. + +end function string_arrays_same + +! Remove all characters from a set from a string +subroutine remove_characters_in_set(string,set,replace_with) + character(len=:), allocatable, intent(inout) :: string + character(*), intent(in) :: set + character, optional, intent(in) :: replace_with ! Replace with this character instead of removing + + integer :: feed,length + + if (.not.allocated(string)) return + if (len(set)<=0) return + + length = len(string) + feed = scan(string,set) + + do while (length>0 .and. feed>0) + + ! Remove heading + if (length==1) then + string = "" + + elseif (feed==1) then + string = string(2:length) + + ! Remove trailing + elseif (feed==length) then + string = string(1:length-1) + + ! In between: replace with given character + elseif (present(replace_with)) then + string(feed:feed) = replace_with + ! Or just remove + else + string = string(1:feed-1)//string(feed+1:length) + end if + + length = len(string) + feed = scan(string,set) + + end do + +end subroutine remove_characters_in_set + +! Remove all new line characters from the current string, replace them with spaces +subroutine remove_newline_characters(string) + type(string_t), intent(inout) :: string + + integer :: feed,length + + character(*), parameter :: CRLF = achar(13)//new_line('a') + character(*), parameter :: SPACE = ' ' + + call remove_characters_in_set(string%s,set=CRLF,replace_with=SPACE) + +end subroutine remove_newline_characters + +!>AUTHOR: John S. Urban +!!LICENSE: Public Domain +!> +!!### NAME +!! notabs(3f) - [fpm_strings:NONALPHA] expand tab characters +!! (LICENSE:PD) +!! +!!### SYNOPSIS +!! +!! subroutine notabs(INSTR,OUTSTR,ILEN) +!! +!! character(len=*),intent=(in) :: INSTR +!! character(len=*),intent=(out) :: OUTSTR +!! integer,intent=(out) :: ILEN +!! +!!### DESCRIPTION +!! NOTABS() converts tabs in INSTR to spaces in OUTSTR while maintaining +!! columns. It assumes a tab is set every 8 characters. Trailing spaces +!! are removed. +!! +!! In addition, trailing carriage returns and line feeds are removed +!! (they are usually a problem created by going to and from MSWindows). +!! +!! What are some reasons for removing tab characters from an input line? +!! Some Fortran compilers have problems with tabs, as tabs are not +!! part of the Fortran character set. Some editors and printers will +!! have problems with tabs. It is often useful to expand tabs in input +!! files to simplify further processing such as tokenizing an input line. +!! +!!### OPTIONS +!! instr Input line to remove tabs from +!! +!!### RESULTS +!! outstr Output string with tabs expanded. Assumed to be of sufficient +!! length +!! ilen Significant length of returned string +!! +!!### EXAMPLES +!! +!! Sample program: +!! +!! program demo_notabs +!! +!! ! test filter to remove tabs and trailing white space from input +!! ! on files up to 1024 characters wide +!! use fpm_strings, only : notabs +!! character(len=1024) :: in,out +!! integer :: ios,iout +!! do +!! read(*,'(A)',iostat=ios)in +!! if(ios /= 0) exit +!! call notabs(in,out,iout) +!! write(*,'(a)')out(:iout) +!! enddo +!! end program demo_notabs +!! +!!### SEE ALSO +!! GNU/Unix commands expand(1) and unexpand(1) +!! +elemental impure subroutine notabs(instr,outstr,ilen) + +! ident_31="@(#)fpm_strings::notabs(3f): convert tabs to spaces while maintaining columns, remove CRLF chars" + +character(len=*),intent(in) :: instr ! input line to scan for tab characters +character(len=*),intent(out) :: outstr ! tab-expanded version of INSTR produced +integer,intent(out) :: ilen ! column position of last character put into output string + ! that is, ILEN holds the position of the last non-blank character in OUTSTR + +integer,parameter :: tabsize=8 ! assume a tab stop is set every 8th column +integer :: ipos ! position in OUTSTR to put next character of INSTR +integer :: lenin ! length of input string trimmed of trailing spaces +integer :: lenout ! number of characters output string can hold +integer :: istep ! counter that advances thru input string INSTR one character at a time +character(len=1) :: c ! character in input line being processed +integer :: iade ! ADE (ASCII Decimal Equivalent) of character being tested + + ipos=1 ! where to put next character in output string OUTSTR + lenin=len_trim(instr( 1:len(instr) )) ! length of INSTR trimmed of trailing spaces + lenout=len(outstr) ! number of characters output string OUTSTR can hold + outstr=" " ! this SHOULD blank-fill string, a buggy machine required a loop to set all characters + + SCAN_LINE: do istep=1,lenin ! look through input string one character at a time + c=instr(istep:istep) ! get next character + iade=ichar(c) ! get ADE of the character + EXPAND_TABS : select case (iade) ! take different actions depending on which character was found + case(9) ! test if character is a tab and move pointer out to appropriate column + ipos = ipos + (tabsize - (mod(ipos-1,tabsize))) + case(10,13) ! convert carriage-return and new-line to space ,typically to handle DOS-format files + ipos=ipos+1 + case default ! c is anything else other than a tab,newline,or return insert it in output string + if(ipos > lenout)then + write(stderr,*)"*notabs* output string overflow" + exit + else + outstr(ipos:ipos)=c + ipos=ipos+1 + endif + end select EXPAND_TABS + enddo SCAN_LINE + + ipos=min(ipos,lenout) ! tabs or newline or return characters or last character might have gone too far + ilen=len_trim(outstr(:ipos)) ! trim trailing spaces + +end subroutine notabs + +!>AUTHOR: John S. Urban +!!LICENSE: Public Domain +!> +!!##NAME +!! dilate(3f) - [M_strings:NONALPHA] expand tab characters +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! function dilate(INSTR) result(OUTSTR) +!! +!! character(len=*),intent=(in) :: INSTR +!! character(len=:),allocatable :: OUTSTR +!! +!!##DESCRIPTION +!! dilate() converts tabs in INSTR to spaces in OUTSTR. It assumes a +!! tab is set every 8 characters. Trailing spaces are removed. +!! +!! In addition, trailing carriage returns and line feeds are removed +!! (they are usually a problem created by going to and from MSWindows). +!! +!!##OPTIONS +!! instr Input line to remove tabs from +!! +!!##RESULTS +!! outstr Output string with tabs expanded. +!! +!!##EXAMPLES +!! +!! Sample program: +!! +!! program demo_dilate +!! +!! use M_strings, only : dilate +!! implicit none +!! character(len=:),allocatable :: in +!! integer :: i +!! in=' this is my string ' +!! ! change spaces to tabs to make a sample input +!! do i=1,len(in) +!! if(in(i:i) == ' ')in(i:i)=char(9) +!! enddo +!! write(*,'(a)')in,dilate(in) +!! end program demo_dilate +!! +function dilate(instr) result(outstr) + + character(len=*), intent(in) :: instr ! input line to scan for tab characters + character(len=:), allocatable :: outstr ! tab-expanded version of INSTR produced + integer :: i + integer :: icount + integer :: lgth + icount = 0 + do i = 1, len(instr) + if (instr(i:i) == char(9)) icount = icount + 1 + end do + allocate (character(len=(len(instr) + 8*icount)) :: outstr) + call notabs(instr, outstr, lgth) + outstr = outstr(:lgth) + +end function dilate + +end module fpm_strings + +!>>>>> build/dependencies/toml-f/src/tomlf/constants.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +module tomlf_constants + use, intrinsic :: iso_fortran_env, only : output_unit + implicit none + private + + !> Single precision real numbers + integer, public, parameter :: tf_sp = selected_real_kind(6) + + !> Double precision real numbers + integer, public, parameter :: tf_dp = selected_real_kind(15) + + !> Char length for integers + integer, public, parameter :: tf_i1 = selected_int_kind(2) + + !> Short length for integers + integer, public, parameter :: tf_i2 = selected_int_kind(4) + + !> Length of default integers + integer, public, parameter :: tf_i4 = selected_int_kind(9) + + !> Long length for integers + integer, public, parameter :: tf_i8 = selected_int_kind(18) + + !> Default character kind + integer, public, parameter :: tfc = selected_char_kind('DEFAULT') + + !> Default float precision, IEEE 754 binary64 values expected + integer, public, parameter :: tfr = tf_dp + + !> Default integer precision, 64 bit (signed long) range expected + integer, public, parameter :: tfi = tf_i8 + + !> Default output channel + integer, public, parameter :: tfout = output_unit + + !> Possible escape characters in TOML + type :: enum_escape + + !> Backslash is used to escape other characters + character(kind=tfc, len=1) :: backslash = tfc_'\' + + !> Double quotes signal strings with escape characters enabled + character(kind=tfc, len=1) :: dquote = tfc_'"' + + !> Single quotes signal strings without escape characters enabled + character(kind=tfc, len=1) :: squote = tfc_'''' + + !> Newline character + character(kind=tfc, len=1) :: newline = achar(10, kind=tfc) + + !> Formfeed character is allowed in strings + character(kind=tfc, len=1) :: formfeed = achar(12, kind=tfc) + + !> Carriage return is allowed as part of the newline and in strings + character(kind=tfc, len=1) :: carriage_return = achar(13, kind=tfc) + + !> Backspace is allowed in strings + character(kind=tfc, len=1) :: bspace = achar(8, kind=tfc) + + !> Tabulators are allowed as whitespace and in strings + character(kind=tfc, len=1) :: tabulator = achar(9, kind=tfc) + + end type enum_escape + + !> Actual enumerator with TOML escape characters + type(enum_escape), public, parameter :: toml_escape = enum_escape() + + !> Possible kinds of TOML values in key-value pairs + type :: enum_type + + !> Invalid type + integer :: invalid = 100 + + !> String type + integer :: string = 101 + + !> Boolean type + integer :: boolean = 102 + + !> Integer type + integer :: int = 103 + + !> Float type + integer :: float = 104 + + !> Datetime type + integer :: datetime = 105 + + end type enum_type + + !> Actual enumerator with TOML value types + type(enum_type), public, parameter :: toml_type = enum_type() + + !> Single quotes denote literal strings + character(kind=tfc, len=*), public, parameter :: TOML_SQUOTE = "'" + !> Double quotes denote strings (with escape character possible) + character(kind=tfc, len=*), public, parameter :: TOML_DQUOTE = '"' + character(kind=tfc, len=*), public, parameter :: TOML_NEWLINE = new_line('a') ! \n + character(kind=tfc, len=*), public, parameter :: TOML_TABULATOR = achar(9) ! \t + character(kind=tfc, len=*), public, parameter :: TOML_FORMFEED = achar(12) ! \f + character(kind=tfc, len=*), public, parameter :: TOML_CARRIAGE_RETURN = achar(13) ! \r + character(kind=tfc, len=*), public, parameter :: TOML_BACKSPACE = achar(8) ! \b + character(kind=tfc, len=*), public, parameter :: TOML_LOWERCASE = & + & 'abcdefghijklmnopqrstuvwxyz' + character(kind=tfc, len=*), public, parameter :: TOML_UPPERCASE = & + & 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(kind=tfc, len=*), public, parameter :: TOML_LETTERS = & + & TOML_LOWERCASE//TOML_UPPERCASE + !> Whitespace in TOML are blanks and tabs. + character(kind=tfc, len=*), public, parameter :: TOML_WHITESPACE = & + & ' '//toml_escape%tabulator + character(kind=tfc, len=*), public, parameter :: TOML_DIGITS = '0123456789' + character(kind=tfc, len=*), public, parameter :: TOML_BINDIGITS = & + & '01' + character(kind=tfc, len=*), public, parameter :: TOML_OCTDIGITS = & + & '01234567' + character(kind=tfc, len=*), public, parameter :: TOML_HEXDIGITS = & + & '0123456789ABCDEFabcdef' + character(kind=tfc, len=*), public, parameter :: TOML_TIMESTAMP = & + & TOML_DIGITS//'.:+-T Zz' + !> Allowed characters in TOML bare keys. + character(kind=tfc, len=*), public, parameter :: TOML_BAREKEY = & + & TOML_LETTERS//TOML_DIGITS//'_-' + character(kind=tfc, len=*), public, parameter :: TOML_LITERALS = & + & TOML_LETTERS//TOML_DIGITS//'_-+.' + +end module tomlf_constants + +!>>>>> build/dependencies/toml-f/src/tomlf/version.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Version information on TOML-Fortran +module tomlf_version + implicit none + private + + public :: get_tomlf_version + public :: tomlf_version_string, tomlf_version_compact + + !> String representation of the TOML-Fortran version + character(len=*), parameter :: tomlf_version_string = "0.4.2" + + !> Major version number of the above TOML-Fortran version + integer, parameter :: tomlf_major = 0 + + !> Minor version number of the above TOML-Fortran version + integer, parameter :: tomlf_minor = 4 + + !> Patch version number of the above TOML-Fortran version + integer, parameter :: tomlf_patch = 2 + + !> Compact numeric representation of the TOML-Fortran version + integer, parameter :: tomlf_version_compact = & + & tomlf_major*10000 + tomlf_minor*100 + tomlf_patch + +contains + +!> Getter function to retrieve TOML-Fortran version +subroutine get_tomlf_version(major, minor, patch, string) + + !> Major version number of the TOML-Fortran version + integer, intent(out), optional :: major + + !> Minor version number of the TOML-Fortran version + integer, intent(out), optional :: minor + + !> Patch version number of the TOML-Fortran version + integer, intent(out), optional :: patch + + !> String representation of the TOML-Fortran version + character(len=:), allocatable, intent(out), optional :: string + + if (present(major)) then + major = tomlf_major + end if + if (present(minor)) then + minor = tomlf_minor + end if + if (present(patch)) then + patch = tomlf_patch + end if + if (present(string)) then + string = tomlf_version_string + end if + +end subroutine get_tomlf_version + +end module tomlf_version + +!>>>>> build/dependencies/toml-f/src/tomlf/de/token.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Provides a definition for a token +module tomlf_de_token + implicit none + private + + public :: toml_token, stringify, token_kind, resize + + !> Possible token kinds + type :: enum_token + !> Invalid token found + integer :: invalid = -1 + !> End of file + integer :: eof = -2 + !> Unclosed group from inline table or array + integer :: unclosed = -3 + !> Whitespace (space, tab) + integer :: whitespace = 0 + !> Newline character (\r\n, \n) + integer :: newline = 1 + !> Comments (#) + integer :: comment = 2 + !> Separator in table path (.) + integer :: dot = 3 + !> Separator in inline arrays and inline tables (,) + integer :: comma = 4 + !> Separator in key-value pairs (=) + integer :: equal = 5 + !> Beginning of an inline table ({) + integer :: lbrace = 6 + !> End of an inline table (}) + integer :: rbrace = 7 + !> Beginning of an inline array or table header ([) + integer :: lbracket = 8 + !> End of an inline array or table header (]) + integer :: rbracket = 9 + !> String literal + integer :: string = 10 + !> String literal + integer :: mstring = 11 + !> String literal + integer :: literal = 12 + !> String literal + integer :: mliteral = 13 + !> String literal + integer :: keypath = 14 + !> Floating point value + integer :: float = 15 + !> Integer value + integer :: int = 16 + !> Boolean value + integer :: bool = 17 + !> Datetime value + integer :: datetime = 18 + !> Absence of value + integer :: nil = 19 + end type enum_token + + !> Actual enumerator for token kinds + type(enum_token), parameter :: token_kind = enum_token() + + !> Token containing + type :: toml_token + !> Kind of token + integer :: kind = token_kind%newline + !> Starting position of the token in character stream + integer :: first = 0 + !> Last position of the token in character stream + integer :: last = 0 + !> Identifier for the chunk index in case of buffered reading + integer :: chunk = 0 + end type toml_token + + !> Reallocate a list of tokens + interface resize + module procedure :: resize_token + end interface + +contains + +!> Reallocate list of tokens +pure subroutine resize_token(var, n) + !> Instance of the array to be resized + type(toml_token), allocatable, intent(inout) :: var(:) + !> Dimension of the final array size + integer, intent(in), optional :: n + + type(toml_token), allocatable :: tmp(:) + integer :: this_size, new_size + integer, parameter :: initial_size = 8 + + if (allocated(var)) then + this_size = size(var, 1) + call move_alloc(var, tmp) + else + this_size = initial_size + end if + + if (present(n)) then + new_size = n + else + new_size = this_size + this_size/2 + 1 + end if + + allocate(var(new_size)) + + if (allocated(tmp)) then + this_size = min(size(tmp, 1), size(var, 1)) + var(:this_size) = tmp(:this_size) + deallocate(tmp) + end if + +end subroutine resize_token + +!> Represent a token as string +pure function stringify(token) result(str) + !> Token to represent as string + type(toml_token), intent(in) :: token + !> String representation of token + character(len=:), allocatable :: str + + select case(token%kind) + case default; str = "unknown" + case(token_kind%invalid); str = "invalid sequence" + case(token_kind%eof); str = "end of file" + case(token_kind%unclosed); str = "unclosed group" + case(token_kind%whitespace); str = "whitespace" + case(token_kind%comment); str = "comment" + case(token_kind%newline); str = "newline" + case(token_kind%dot); str = "dot" + case(token_kind%comma); str = "comma" + case(token_kind%equal); str = "equal" + case(token_kind%lbrace); str = "opening brace" + case(token_kind%rbrace); str = "closing brace" + case(token_kind%lbracket); str = "opening bracket" + case(token_kind%rbracket); str = "closing bracket" + case(token_kind%string); str = "string" + case(token_kind%mstring); str = "multiline string" + case(token_kind%literal); str = "literal" + case(token_kind%mliteral); str = "multiline-literal" + case(token_kind%keypath); str = "keypath" + case(token_kind%int); str = "integer" + case(token_kind%float); str = "float" + case(token_kind%bool); str = "bool" + case(token_kind%datetime); str = "datetime" + end select +end function stringify + +end module tomlf_de_token + +!>>>>> build/dependencies/M_CLI2/src/M_CLI2.F90 + +!VERSION 1.0 20200115 +!VERSION 2.0 20200802 +!VERSION 3.0 20201021 LONG:SHORT syntax +!VERSION 3.1 20201115 LONG:SHORT:: syntax +!VERSION 3.2 20230205 set_mode() +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! M_CLI2(3fm) - [ARGUMENTS::M_CLI2::INTRO] command line argument +!! parsing using a prototype command +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! Available procedures and variables: +!! +!! ! basic procedures +!! use M_CLI2, only : set_args, get_args, specified, set_mode +!! ! convenience functions +!! use M_CLI2, only : dget, iget, lget, rget, sget, cget +!! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets +!! ! variables +!! use M_CLI2, only : unnamed, remaining, args +!! ! working with non-allocatable strings and arrays +!! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size +!! ! special function for creating subcommands +!! use M_CLI2, only : get_subcommand(3f) +!! +!!##DESCRIPTION +!! The M_CLI2 module cracks a Unix-style command line. +!! +!! Typically one call to SET_ARGS(3f) is made to define the command +!! arguments, set default values and parse the command line. Then a call +!! is made to the convenience procedures or GET_ARGS(3f) proper for each +!! command keyword to obtain the argument values. +!! +!! Detailed descriptions of each procedure and example programs are +!! included. +!! +!!##EXAMPLE +!! +!! +!! Sample minimal program: +!! +!! program minimal +!! use M_CLI2, only : set_args, lget, rget, sgets +!! implicit none +!! real :: x, y +!! integer :: i +!! character(len=:),allocatable :: version_text(:), help_text(:) +!! character(len=:),allocatable :: filenames(:) +!! ! define and crack command line. +!! ! creates argument --yvalue with short name y with default value 0 +!! ! creates argument --xvalue with short name x with default value 0 +!! ! creates boolean argument +!! call setup() ! define help text and version text +!! call set_args(' --yvalue:y 0.0 --xvalue:x 0.0 --debug F',& +!! & help_text=help_text,& +!! & version_text=version_text) +!! ! get values +!! x=rget('xvalue') +!! y=rget('yvalue') +!! if(lget('debug'))then +!! write(*,*)'X=',x +!! write(*,*)'Y=',y +!! write(*,*)'ATAN2(Y,X)=',atan2(x=x,y=y) +!! else +!! write(*,*)atan2(x=x,y=y) +!! endif +!! filenames=sgets() ! sgets(3f) with no name gets "unnamed" values +!! if(size(filenames) > 0)then +!! write(*,'(g0)')'filenames:' +!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) +!! endif +!! contains +!! subroutine setup() +!! +!! help_text=[character(len=80) :: & +!! & "wish I put instructions", & +!! & "here I suppose. ", & +!! & " "] +!! +!! version_text=[character(len=80) :: "version 1.0","author: me"] +!! +!! end subroutine setup +!! end program minimal +!! +!! which may be called in various ways: +!! +!! mimimal -x 100.3 -y 3.0e4 +!! mimimal --xvalue=300 --debug +!! mimimal --yvalue 400 +!! mimimal -x 10 file1 file2 file3 +!! +!! Sample program using get_args() and variants +!! +!! program demo_M_CLI2 +!! use M_CLI2, only : set_args, get_args +!! use M_CLI2, only : filenames=>unnamed +!! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size +!! implicit none +!! integer,parameter :: dp=kind(0.0d0) +!! integer :: i +!! ! +!! ! Define ARGS +!! real :: x, y, z +!! logical :: l, lbig +!! character(len=40) :: label ! FIXED LENGTH +!! real(kind=dp),allocatable :: point(:) +!! logical,allocatable :: logicals(:) +!! character(len=:),allocatable :: title ! VARIABLE LENGTH +!! real :: p(3) ! FIXED SIZE +!! logical :: logi(3) ! FIXED SIZE +!! ! +!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE +!! ! o set a value for all keywords. +!! ! o double-quote strings, strings must be at least one space +!! ! because adjacent double-quotes designate a double-quote +!! ! in the value. +!! ! o set all logical values to F +!! ! o numeric values support an "e" or "E" exponent +!! ! o for lists delimit with a comma, colon, or space +!! call set_args(' & +!! & -x 1 -y 2 -z 3 & +!! & -p -1 -2 -3 & +!! & --point 11.11, 22.22, 33.33e0 & +!! & --title "my title" -l F -L F & +!! & --logicals F F F F F & +!! & --logi F T F & +!! & --label " " & +!! ! note space between quotes is required +!! & ') +!! ! Assign values to elements using G_ARGS(3f). +!! ! non-allocatable scalars can be done up to twenty per call +!! call get_args('x',x, 'y',y, 'z',z, 'l',l, 'L',lbig) +!! ! As a convenience multiple pairs of keywords and variables may be +!! ! specified if and only if all the values are scalars and the CHARACTER +!! ! variables are fixed-length or pre-allocated. +!! ! +!! ! After SET_ARGS(3f) has parsed the command line +!! ! GET_ARGS(3f) retrieves the value of keywords accept for +!! ! two special cases. For fixed-length CHARACTER variables +!! ! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see +!! ! GET_ARGS_FIXED_SIZE(3f). +!! ! +!! ! allocatables should be done one at a time +!! call get_args('title',title) ! allocatable string +!! call get_args('point',point) ! allocatable arrays +!! call get_args('logicals',logicals) +!! ! +!! ! less commonly ... +!! +!! ! for fixed-length strings +!! call get_args_fixed_length('label',label) +!! +!! ! for non-allocatable arrays +!! call get_args_fixed_size('p',p) +!! call get_args_fixed_size('logi',logi) +!! ! +!! ! all done parsing, use values +!! write(*,*)'x=',x, 'y=',y, 'z=',z, x+y+z +!! write(*,*)'p=',p +!! write(*,*)'point=',point +!! write(*,*)'title=',title +!! write(*,*)'label=',label +!! write(*,*)'l=',l +!! write(*,*)'L=',lbig +!! write(*,*)'logicals=',logicals +!! write(*,*)'logi=',logi +!! ! +!! ! unnamed strings +!! ! +!! if(size(filenames) > 0)then +!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) +!! endif +!! ! +!! end program demo_M_CLI2 +!! +!! Results: +!! +!! > x=1.00000000 y=2.00000000 z=3.00000000 6.00000000 +!! > p= -1.00000000 -2.00000000 -3.00000000 +!! > point= 11.109999999999999 22.219999999999999 33.329999999999998 +!! > title=my title +!! > label= +!! > l= F +!! > L= F +!! > logicals= F F F F F +!! > logi= F T F +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!!##SEE ALSO +!! + get_args(3f) +!! + get_args_fixed_size(3f) +!! + get_args_fixed_length(3f) +!! + get_subcommand(3f) +!! + set_mode(3f) +!! + specified(3f) +!! +!! Note that the convenience routines are described under get_args(3f): +!! dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), cget(3f) dgets(3f), +!! igets(3f), lgets(3f), rgets(3f), sgets(3f), cgets(3f) +!=================================================================================================================================== +module M_CLI2 +use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT, warn=>OUTPUT_UNIT +implicit none +private + +integer,parameter,private :: dp=kind(0.0d0) +integer,parameter,private :: sp=kind(0.0) + +character(len=*),parameter :: gen='(*(g0))' +character(len=:),allocatable,public :: unnamed(:) +character(len=:),allocatable,public :: args(:) +character(len=:),allocatable,public :: remaining +public :: set_mode +public :: set_args +public :: get_subcommand +public :: get_args +public :: get_args_fixed_size +public :: get_args_fixed_length +public :: specified +public :: print_dictionary + +public :: dget, iget, lget, rget, sget, cget +public :: dgets, igets, lgets, rgets, sgets, cgets + +type option + character(:),allocatable :: shortname + character(:),allocatable :: longname + character(:),allocatable :: value + integer :: length + logical :: present_in + logical :: mandatory +end type option + +character(len=:),allocatable,save :: keywords(:) +character(len=:),allocatable,save :: shorts(:) +character(len=:),allocatable,save :: values(:) +integer,allocatable,save :: counts(:) +logical,allocatable,save :: present_in(:) +logical,allocatable,save :: mandatory(:) + +logical,save :: G_DEBUG=.false. +logical,save :: G_UNDERDASH=.false. +logical,save :: G_NODASHUNDER=.false. +logical,save :: G_IGNORELONGCASE=.false. ! ignore case of long keywords +logical,save :: G_IGNOREALLCASE=.false. ! ignore case of long and short keywords +logical,save :: G_STRICT=.false. ! strict short and long rules or allow -longname and --shortname +logical,save :: G_APPEND=.true. ! whether to append or replace when duplicate keywords found + +logical,save :: G_keyword_single_letter=.true. +character(len=:),allocatable,save :: G_passed_in +logical,save :: G_remaining_on, G_remaining_option_allowed +character(len=:),allocatable,save :: G_remaining +character(len=:),allocatable,save :: G_subcommand ! possible candidate for a subcommand +character(len=:),allocatable,save :: G_STOP_MESSAGE +integer,save :: G_STOP +logical,save :: G_QUIET +character(len=:),allocatable,save :: G_PREFIX + +! try out response files +! CLI_RESPONSE_FILE is left public for backward compatibility, but should be set via "set_mode('response_file') +logical,save,public :: CLI_RESPONSE_FILE=.false. ! allow @name abbreviations +logical,save :: G_OPTIONS_ONLY ! process response file only looking for options for get_subcommand() +logical,save :: G_RESPONSE ! allow @name abbreviations +character(len=:),allocatable,save :: G_RESPONSE_IGNORED +character(len=:),allocatable,save :: G_RESPONSE_PREFIX + +! return allocatable arrays +interface get_args; module procedure get_anyarray_d; end interface ! any size array +interface get_args; module procedure get_anyarray_i; end interface ! any size array +interface get_args; module procedure get_anyarray_r; end interface ! any size array +interface get_args; module procedure get_anyarray_x; end interface ! any size array +interface get_args; module procedure get_anyarray_c; end interface ! any size array and any length +interface get_args; module procedure get_anyarray_l; end interface ! any size array + +! return scalars +interface get_args; module procedure get_scalar_d; end interface +interface get_args; module procedure get_scalar_i; end interface +interface get_args; module procedure get_scalar_real; end interface +interface get_args; module procedure get_scalar_complex; end interface +interface get_args; module procedure get_scalar_logical; end interface +interface get_args; module procedure get_scalar_anylength_c; end interface ! any length + +! multiple scalars +interface get_args; module procedure many_args; end interface + +! return non-allocatable arrays +! said in conflict with get_args_*. Using class to get around that. +! that did not work either. Adding size parameter as optional parameter works; but using a different name +interface get_args_fixed_size; module procedure get_fixedarray_class; end interface ! any length, fixed size array +!interface get_args; module procedure get_fixedarray_d; end interface +!interface get_args; module procedure get_fixedarray_i; end interface +!interface get_args; module procedure get_fixedarray_r; end interface +!interface get_args; module procedure get_fixedarray_l; end interface +!interface get_args; module procedure get_fixedarray_fixed_length_c; end interface + +interface get_args_fixed_length; module procedure get_args_fixed_length_a_array; end interface ! fixed length any size array +interface get_args_fixed_length; module procedure get_args_fixed_length_scalar_c; end interface ! fixed length + +! Generic subroutine inserts element into allocatable array at specified position + +! find PLACE in sorted character array where value can be found or should be placed +interface locate_; module procedure locate_c ; end interface + +! insert entry into a sorted allocatable array at specified position +interface insert_; module procedure insert_c, insert_i, insert_l ; end interface + +! replace entry by index from a sorted allocatable array if it is present +interface replace_; module procedure replace_c, replace_i, replace_l ; end interface + +! delete entry by index from a sorted allocatable array if it is present +interface remove_; module procedure remove_c, remove_i, remove_l ; end interface + +! convenience functions +interface cgets;module procedure cgs, cg;end interface +interface dgets;module procedure dgs, dg;end interface +interface igets;module procedure igs, ig;end interface +interface lgets;module procedure lgs, lg;end interface +interface rgets;module procedure rgs, rg;end interface +interface sgets;module procedure sgs, sg;end interface + +contains +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! check_commandline(3f) - [ARGUMENTS:M_CLI2]check command and process +!! pre-defined options +!! +!!##SYNOPSIS +!! +!! subroutine check_commandline(help_text,version_text,ierr,errmsg) +!! +!! character(len=*),intent(in),optional :: help_text(:) +!! character(len=*),intent(in),optional :: version_text(:) +!! +!!##DESCRIPTION +!! Checks the commandline and processes the implicit --help, --version, +!! --verbose, and --usage parameters. +!! +!! If the optional text values are supplied they will be displayed by +!! --help and --version command-line options, respectively. +!! +!!##OPTIONS +!! +!! HELP_TEXT if present, will be displayed if program is called with +!! --help switch, and then the program will terminate. If +!! not supplied, the command line initialized string will be +!! shown when --help is used on the commandline. +!! +!! VERSION_TEXT if present, will be displayed if program is called with +!! --version switch, and then the program will terminate. +!! +!! If the first four characters of each line are "@(#)" this prefix +!! will not be displayed and the last non-blank letter will be +!! removed from each line. This if for support of the SCCS what(1) +!! command. If you do not have the what(1) command on GNU/Linux and +!! Unix platforms you can probably see how it can be used to place +!! metadata in a binary by entering: +!! +!! strings demo_commandline|grep '@(#)'|tr '>' '\n'|sed -e 's/ */ /g' +!! +!!##EXAMPLE +!! +!! +!! Typical usage: +!! +!! program check_commandline +!! use M_CLI2, only : unnamed, set_args, get_args +!! implicit none +!! integer :: i +!! character(len=:),allocatable :: version_text(:), help_text(:) +!! real :: x, y, z +!! character(len=*),parameter :: cmd='-x 1 -y 2 -z 3' +!! version_text=[character(len=80) :: "version: 1.0","author: me"] +!! help_text=[character(len=80) :: & +!! & "wish I put instructions","here","I suppose?"] +!! call set_args(cmd,help_text,version_text) +!! call get_args('x',x,'y',y,'z',z) +!! ! All done cracking the command line. Use the values in your program. +!! write (*,*)x,y,z +!! ! the optional unnamed values on the command line are +!! ! accumulated in the character array "UNNAMED" +!! if(size(unnamed) > 0)then +!! write (*,'(a)')'files:' +!! write (*,'(i6.6,3a)') (i,'[',unnamed(i),']',i=1,size(unnamed)) +!! endif +!! end program check_commandline +!=================================================================================================================================== +subroutine check_commandline(help_text,version_text) +character(len=*),intent(in),optional :: help_text(:) +character(len=*),intent(in),optional :: version_text(:) +character(len=:),allocatable :: line +integer :: i +integer :: istart +integer :: iback +character(len=255) :: string + if(get('usage') == 'T')then + ! kludge to test interactive mode concept + ! do + ! call print_dictionary_usage() + ! read(*,'(a)')string + ! if(string.eq.'.')exit + ! call prototype_to_dictionary(string) + ! enddo + call print_dictionary_usage() + call mystop(32) + return + endif + if(present(help_text))then + if(get('help') == 'T')then + do i=1,size(help_text) + call journal(help_text(i)) + enddo + call mystop(1,'displayed help text') + return + endif + elseif(get('help') == 'T')then + call default_help() + call mystop(2,'displayed default help text') + return + endif + if(present(version_text))then + if(get('version') == 'T')then + istart=1 + iback=0 + if(size(version_text) > 0)then + if(index(version_text(1),'@'//'(#)') == 1)then ! allow for what(1) syntax + istart=5 + iback=1 + endif + endif + do i=1,size(version_text) + !xINTEL BUG*!call journal(version_text(i)(istart:len_trim(version_text(i))-iback)) + line=version_text(i)(istart:len_trim(version_text(i))-iback) + call journal(line) + enddo + call mystop(3,'displayed version text') + return + endif + elseif(get('version') == 'T')then + + if(G_QUIET)then + G_STOP_MESSAGE = 'no version text' + else + call journal('*check_commandline* no version text') + endif + call mystop(4,'displayed default version text') + return + endif +contains +subroutine default_help() +character(len=:),allocatable :: cmd_name +integer :: ilength + call get_command_argument(number=0,length=ilength) + if(allocated(cmd_name))deallocate(cmd_name) + allocate(character(len=ilength) :: cmd_name) + call get_command_argument(number=0,value=cmd_name) + G_passed_in=G_passed_in//repeat(' ',len(G_passed_in)) + G_passed_in=replace_str(G_passed_in, ' --', NEW_LINE('A')//' --') + if(.not.G_QUIET)then + call journal(cmd_name,G_passed_in) ! no help text, echo command and default options + endif + deallocate(cmd_name) +end subroutine default_help +end subroutine check_commandline +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! set_args(3f) - [ARGUMENTS:M_CLI2] command line argument parsing +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine set_args(prototype,help_text,version_text,ierr,errmsg) +!! +!! character(len=*),intent(in),optional :: prototype +!! character(len=*),intent(in),optional :: help_text(:) +!! character(len=*),intent(in),optional :: version_text(:) +!! integer,intent(out),optional :: ierr +!! character(len=:),intent(out),allocatable,optional :: errmsg +!!##DESCRIPTION +!! +!! SET_ARGS(3f) requires a unix-like command prototype which defines +!! the command-line options and their default values. When the program +!! is executed this and the command-line options are applied and the +!! resulting values are placed in an internal table for retrieval via +!! GET_ARGS(3f). +!! +!! The built-in --help and --version options require optional help_text +!! and version_text values to be provided to be particularly useful. +!! +!!##OPTIONS +!! +!! PROTOTYPE composed of all command arguments concatenated +!! into a Unix-like command prototype string. For example: +!! +!! call set_args('-L F --ints 1,2,3 --title "my title" -R 10.3') +!! +!! Note that the following options are predefined for all +!! commands: +!! +!! --verbose F --usage F --help F --version F +!! +!! see "DEFINING THE PROTOTYPE" in the next section for +!! further details. +!! +!! HELP_TEXT if present, will be displayed when the program is called with +!! a --help switch, and then the program will terminate. If +!! help text is not supplied the command line initialization +!! string will be echoed. +!! +!! VERSION_TEXT if present, any version text defined will be displayed +!! when the program is called with a --version switch, +!! and then the program will terminate. +!! IERR if present a non-zero option is returned when an +!! error occurs instead of the program terminating. +!! ERRMSG a description of the error if ierr is present. +!! +!!##DEFINING THE PROTOTYPE +!! +!! o Keywords start with a single dash for short single-character +!! keywords, and with two dashes for longer keywords. +!! +!! o all keywords on the prototype MUST get a value. +!! +!! * logicals must be set to an unquoted F. +!! +!! * strings must be delimited with double-quotes. +!! Since internal double-quotes are represented with two +!! double-quotes the string must be at least one space. +!! +!! o numeric keywords are not allowed; but this allows +!! negative numbers to be used as values. +!! +!! o lists of values should be comma-delimited unless a +!! user-specified delimiter is used. The prototype +!! must use the same array delimiters as the call to +!! get the value. +!! +!! o to define a zero-length allocatable array make the +!! value a delimiter (usually a comma) or an empty set +!! of braces ("[]"). +!! +!! LONG AND SHORT NAMES +!! +!! Long keywords start with two dashes followed by more than one letter. +!! Short keywords are a dash followed by a single letter. +!! +!! o It is recommended long names (--keyword) should be all lowercase +!! but are case-sensitive by default, unless +!! "set_mode('ignorelongcase')" or "set_mode('ignoreallcase')" is +!! in effect. +!! +!! o Long names should always be more than one character. +!! +!! o The recommended way to have short names is to suffix the long +!! name with :LETTER in the definition. +!! +!! If this syntax is used then logical shorts may be combined on the +!! command line when "set_mode('strict')" is in effect. +!! +!! SPECIAL BEHAVIORS +!! +!! o A special behavior occurs if a keyword name ends in ::. +!! When the program is called the next parameter is taken as a value +!! even if it starts with -. This is not generally needed but is +!! useful in rare cases where non-numeric values starting with a dash +!! are desired. +!! +!! o If the prototype ends with "--" a special mode is turned +!! on where anything after "--" on input goes into the variable +!! REMAINING with values double-quoted and also into the array ARGS +!! instead of becoming elements in the UNNAMED array. This is not +!! needed for normal processing, but was needed for a program that +!! needed this behavior for its subcommands. +!! +!! That is, for a normal call all unnamed values go into UNNAMED +!! and ARGS and REMAINING are ignored. So for +!! +!! call set_args('-x 10 -y 20 ') +!! +!! A program invocation such as +!! +!! xx a b c -- A B C " dd " +!! +!! results in +!! +!! UNNAMED= ['a','b','c','A','B','C',' dd'] +!! REMAINING= '' +!! ARGS= [character(len=0) :: ] ! ie, an empty character array +!! +!! Whereas +!! +!! call set_args('-x 10 -y 20 --') +!! +!! generates the following output from the same program execution: +!! +!! UNNAMED= ['a','b','c'] +!! REMAINING= '"A" "B" "C" " dd "' +!! ARGS= ['A','B','C,' dd'] +!! +!!##USAGE NOTES +!! When invoking the program line note the following restrictions +!! (which often differ between various command-line parsers and are +!! subject to change): +!! +!! o By defaul tvalues for duplicate keywords are appended together +!! with a space separator. +!! +!! o shuffling is not supported. Values immediately follow their +!! keywords. +!! +!! o Only short Boolean keywords can be bundled together. +!! If allowing bundling is desired call "set_mode('strict')". +!! This will require prefixing long names with "--" and short +!! names with "-". Otherwise M_CLI2 relaxes that requirement +!! and mostly does not care what prefix is used for a keyword. +!! But this would make it unclear what was meant by "-ox" if +!! allowed options were "-o F -x F --ox F " for example, so +!! "strict" mode is required to remove the ambiguity. +!! +!! o if a parameter value of just "-" is supplied it is +!! converted to the string "stdin". +!! +!! o values not needed for a keyword value go into the character +!! array "UNNAMED". +!! +!! In addition if the keyword "--" is encountered on the command +!! line the rest of the command line goes into the character array +!! "UNNAMED". +!! +!!##EXAMPLE +!! +!! +!! Sample program: +!! +!! program demo_set_args +!! use M_CLI2, only : filenames=>unnamed, set_args, get_args +!! use M_CLI2, only : get_args_fixed_size +!! implicit none +!! integer :: i +!! ! DEFINE ARGS +!! real :: x, y, z +!! real :: p(3) +!! character(len=:),allocatable :: title +!! logical :: l, lbig +!! integer,allocatable :: ints(:) +!! ! +!! ! DEFINE COMMAND (TO SET INITIAL VALUES AND ALLOWED KEYWORDS) +!! ! AND READ COMMAND LINE +!! call set_args(' & +!! ! reals +!! & -x 1 -y 2.3 -z 3.4e2 & +!! ! integer array +!! & -p -1,-2,-3 & +!! ! always double-quote strings +!! & --title "my title" & +!! ! string should be a single character at a minimum +!! & --label " ", & +!! ! set all logical values to F +!! & -l F -L F & +!! ! set allocatable size to zero if you like by using a delimiter +!! & --ints , & +!! & ') +!! ! ASSIGN VALUES TO ELEMENTS +!! ! SCALARS +!! call get_args('x',x) +!! call get_args('y',y) +!! call get_args('z',z) +!! call get_args('l',l) +!! call get_args('L',lbig) +!! call get_args('ints',ints) ! ALLOCATABLE ARRAY +!! call get_args('title',title) ! ALLOCATABLE STRING +!! call get_args_fixed_size('p',p) ! NON-ALLOCATABLE ARRAY +!! ! USE VALUES +!! write(*,*)'x=',x +!! write(*,*)'y=',y +!! write(*,*)'z=',z +!! write(*,*)'p=',p +!! write(*,*)'title=',title +!! write(*,*)'ints=',ints +!! write(*,*)'l=',l +!! write(*,*)'L=',lbig +!! ! UNNAMED VALUES +!! if(size(filenames) > 0)then +!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) +!! endif +!! end program demo_set_args +!! +!!##RESPONSE FILES +!! +!! If you have no interest in using external files as abbreviations +!! you can ignore this section. Otherwise, before calling set_args(3f) +!! add: +!! +!! use M_CLI2, only : set_mode +!! call set_mode('response_file') +!! +!! M_CLI2 Response files are small files containing CLI (Command Line +!! Interface) arguments that end with ".rsp" that can be used when command +!! lines are so long that they would exceed line length limits or so complex +!! that it is useful to have a platform-independent method of creating +!! an abbreviation. +!! +!! Shell aliases and scripts are often used for similar purposes (and +!! allow for much more complex conditional execution, of course), but +!! they generally cannot be used to overcome line length limits and are +!! typically platform-specific. +!! +!! Examples of commands that support similar response files are the Clang +!! and Intel compilers, although there is no standard format for the files. +!! +!! They are read if you add options of the syntax "@NAME" as the FIRST +!! parameters on your program command line calls. They are not recursive -- +!! that is, an option in a response file cannot be given the value "@NAME2" +!! to call another response file. +!! +!! More than one response name may appear on a command line. +!! +!! They are case-sensitive names. +!! +!! Note "@" is a special character in Powershell, and there requires being +!! escaped with a grave character or placed in double-quotes if the name +!! is alphanumeric (using names like "a-b" or other non-alphanumeric +!! characters also prevents the "@" from being treated specially). To +!! accomodate this the "@" character may alternatively appear on the end +!! of the name instead of the beginning. It will be internally moved to +!! the beginning before processing commences. +!! +!! It is not recommended in general but the response name prefix may +!! be changed via the environment variable CLI_RESPONSE_PREFIX if in an +!! environment preventing the use of the "@" character. Typically "^" or +!! "%" or "_" are unused characters. In the very worst case an arbitrary +!! string is allowed such as "rsp_". +!! +!! LOCATING RESPONSE FILES +!! +!! A search for the response file always starts with the current directory. +!! The search then proceeds to look in any additional directories specified +!! with the colon-delimited environment variable CLI_RESPONSE_PATH. +!! +!! The first resource file found that results in lines being processed +!! will be used and processing stops after that first match is found. If +!! no match is found an error occurs and the program is stopped. +!! +!! RESPONSE FILE SECTIONS +!! +!! A simple response file just has options for calling the program in it +!! prefixed with the word "options". +!! But they can also contain section headers to denote selections that are +!! only executed when a specific OS is being used, print messages, and +!! execute system commands. +!! +!! SEARCHING FOR OSTYPE IN REGULAR FILES +!! +!! So assuming the name @NAME was specified on the command line a file +!! named NAME.rsp will be searched for in all the search directories +!! and then in that file a string that starts with the string @OSTYPE +!! (if the environment variables $OS and $OSTYPE are not blank. $OSTYPE +!! takes precedence over $OS). +!! +!! SEARCHING FOR UNLABELED DIRECTIVES IN REGULAR FILES +!! +!! Then, the same files will be searched for lines above any line starting +!! with "@". That is, if there is no special section for the current OS +!! it just looks at the top of the file for unlabeled options. +!! +!! SEARCHING FOR OSTYPE AND NAME IN THE COMPOUND FILE +!! +!! In addition or instead of files with the same name as the @NAME option +!! on the command line, you can have one file named after the executable +!! name that contains multiple abbreviation names. +!! +!! So if your program executable is named EXEC you create a single file +!! called EXEC.rsp and can append all the simple files described above +!! separating them with lines of the form @OSTYPE@NAME or just @NAME. +!! +!! So if no specific file for the abbreviation is found a file called +!! "EXEC.rsp" is searched for where "EXEC" is the name of the executable. +!! This file is always a "compound" response file that uses the following format: +!! +!! Any compound EXEC.rsp file found in the current or searched directories +!! will be searched for the string @OSTYPE@NAME first. +!! +!! Then if nothing is found, the less specific line @NAME is searched for. +!! +!! THE SEARCH IS OVER +!! +!! Sounds complicated but actually works quite intuitively. Make a file in +!! the current directory and put options in it and it will be used. If that +!! file ends up needing different cases for different platforms add a line +!! like "@Linux" to the file and some more lines and that will only be +!! executed if the environment variable OSTYPE or OS is "Linux". If no match +!! is found for named sections the lines at the top before any "@" lines +!! will be used as a default if no match is found. +!! +!! If you end up using a lot of files like this you can combine them all +!! together and put them into a file called "program_name".rsp and just +!! put lines like @NAME or @OSTYPE@NAME at that top of each selection. +!! +!! Now, back to the details on just what you can put in the files. +!! +!!##SPECIFICATION FOR RESPONSE FILES +!! +!! SIMPLE RESPONSE FILES +!! +!! The first word of a line is special and has the following meanings: +!! +!! options|- Command options following the rules of the SET_ARGS(3f) +!! prototype. So +!! o It is preferred to specify a value for all options. +!! o double-quote strings. +!! o give a blank string value as " ". +!! o use F|T for lists of logicals, +!! o lists of numbers should be comma-delimited. +!! o --usage, --help, --version, --verbose, and unknown +!! options are ignored. +!! +!! comment|# Line is a comment line +!! system|! System command. +!! System commands are executed as a simple call to +!! system (so a cd(1) or setting a shell variable +!! would not effect subsequent lines, for example) +!! BEFORE the command being processed. +!! print|> Message to screen +!! stop display message and stop program. +!! +!! NOTE: system commands are executed when encountered, but options are +!! gathered from multiple option lines and passed together at the end of +!! processing of the block; so all commands will be executed BEFORE the +!! command for which options are being supplied no matter where they occur. +!! +!! So if a program that does nothing but echos its parameters +!! +!! program testit +!! use M_CLI2, only : set_args, rget, sget, lget, set_mode +!! implicit none +!! real :: x,y ; namelist/args/ x,y +!! character(len=:),allocatable :: title ; namelist/args/ title +!! logical :: big ; namelist/args/ big +!! call set_mode('response_file') +!! call set_args('-x 10.0 -y 20.0 --title "my title" --big F') +!! x=rget('x') +!! y=rget('y') +!! title=sget('title') +!! big=lget('big') +!! write(*,nml=args) +!! end program testit +!! +!! And a file in the current directory called "a.rsp" contains +!! +!! # defaults for project A +!! options -x 1000 -y 9999 +!! options --title " " +!! options --big T +!! +!! The program could be called with +!! +!! $myprog # normal call +!! X=10.0 Y=20.0 TITLE="my title" +!! +!! $myprog @a # change defaults as specified in "a.rsp" +!! X=1000.0 Y=9999.0 TITLE=" " +!! +!! # change defaults but use any option as normal to override defaults +!! $myprog @a -y 1234 +!! X=1000.0 Y=1234.0 TITLE=" " +!! +!! COMPOUND RESPONSE FILES +!! +!! A compound response file has the same basename as the executable with a +!! ".rsp" suffix added. So if your program is named "myprg" the filename +!! must be "myprg.rsp". +!! +!! Note that here `basename` means the last leaf of the +!! name of the program as returned by the Fortran intrinsic +!! GET_COMMAND_ARGUMENT(0,...) trimmed of anything after a period ("."), +!! so it is a good idea not to use hidden files. +!! +!! Unlike simple response files compound response files can contain multiple +!! setting names. +!! +!! Specifically in a compound file +!! if the environment variable $OSTYPE (first) or $OS is set the first search +!! will be for a line of the form (no leading spaces should be used): +!! +!! @OSTYPE@alias_name +!! +!! If no match or if the environment variables $OSTYPE and $OS were not +!! set or a match is not found then a line of the form +!! +!! @alias_name +!! +!! is searched for in simple or compound files. If found subsequent lines +!! will be ignored that start with "@" until a line not starting with +!! "@" is encountered. Lines will then be processed until another line +!! starting with "@" is found or end-of-file is encountered. +!! +!! COMPOUND RESPONSE FILE EXAMPLE +!! An example compound file +!! +!! ################# +!! @if +!! > RUNNING TESTS USING RELEASE VERSION AND ifort +!! options test --release --compiler ifort +!! ################# +!! @gf +!! > RUNNING TESTS USING RELEASE VERSION AND gfortran +!! options test --release --compiler gfortran +!! ################# +!! @nv +!! > RUNNING TESTS USING RELEASE VERSION AND nvfortran +!! options test --release --compiler nvfortran +!! ################# +!! @nag +!! > RUNNING TESTS USING RELEASE VERSION AND nagfor +!! options test --release --compiler nagfor +!! # +!! ################# +!! # OS-specific example: +!! @Linux@install +!! # +!! # install executables in directory (assuming install(1) exists) +!! # +!! system mkdir -p ~/.local/bin +!! options run --release T --runner "install -vbp -m 0711 -t ~/.local/bin" +!! @install +!! STOP INSTALL NOT SUPPORTED ON THIS PLATFORM OR $OSTYPE NOT SET +!! # +!! ################# +!! @fpm@testall +!! # +!! !fpm test --compiler nvfortran +!! !fpm test --compiler ifort +!! !fpm test --compiler gfortran +!! !fpm test --compiler nagfor +!! STOP tests complete. Any additional parameters were ignored +!! ################# +!! +!! Would be used like +!! +!! fpm @install +!! fpm @nag -- +!! fpm @testall +!! +!! NOTES +!! +!! The intel Fortran compiler now calls the response files "indirect +!! files" and does not add the implied suffix ".rsp" to the files +!! anymore. It also allows the @NAME syntax anywhere on the command line, +!! not just at the beginning. -- 20201212 +!! +!!##AUTHOR +!! John S. Urban, 2019 +!! +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine set_args(prototype,help_text,version_text,string,prefix,ierr,errmsg) + +! ident_1="@(#) M_CLI2 set_args(3f) parse prototype string" + +character(len=*),intent(in) :: prototype +character(len=*),intent(in),optional :: help_text(:) +character(len=*),intent(in),optional :: version_text(:) +character(len=*),intent(in),optional :: string +character(len=*),intent(in),optional :: prefix +integer,intent(out),optional :: ierr +character(len=:),intent(out),allocatable,optional :: errmsg +character(len=:),allocatable :: hold ! stores command line argument +integer :: ibig +character(len=:),allocatable :: debug_mode + + debug_mode= upper(get_env('CLI_DEBUG_MODE','FALSE'))//' ' + select case(debug_mode(1:1)) + case('Y','T') + G_DEBUG=.true. + end select + + G_response=CLI_RESPONSE_FILE + + G_options_only=.false. + G_passed_in='' + G_STOP=0 + G_STOP_MESSAGE='' + if(present(prefix))then + G_PREFIX=prefix + else + G_PREFIX='' + endif + if(present(ierr))then + G_QUIET=.true. + else + G_QUIET=.false. + endif + ibig=longest_command_argument() ! bug in gfortran. len=0 should be fine + IF(ALLOCATED(UNNAMED)) DEALLOCATE(UNNAMED) + ALLOCATE(CHARACTER(LEN=IBIG) :: UNNAMED(0)) + if(allocated(args)) deallocate(args) + allocate(character(len=ibig) :: args(0)) + + call wipe_dictionary() + hold='--version F --usage F --help F --version F '//adjustl(prototype) + call prototype_and_cmd_args_to_nlist(hold,string) + if(allocated(G_RESPONSE_IGNORED))then + if(G_DEBUG)write(*,gen)'SET_ARGS:G_RESPONSE_IGNORED:',G_RESPONSE_IGNORED + if(size(unnamed) /= 0)write(*,*)'LOGIC ERROR' + call split(G_RESPONSE_IGNORED,unnamed) + endif + + if(.not.allocated(unnamed))then + allocate(character(len=0) :: unnamed(0)) + endif + if(.not.allocated(args))then + allocate(character(len=0) :: args(0)) + endif + call check_commandline(help_text,version_text) ! process --help, --version, --usage + if(present(ierr))then + ierr=G_STOP + endif + if(present(errmsg))then + errmsg=G_STOP_MESSAGE + endif +end subroutine set_args +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! get_subcommand(3f) - [ARGUMENTS:M_CLI2] special-case routine for +!! handling subcommands on a command line +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! function get_subcommand() +!! +!! character(len=:),allocatable :: get_subcommand +!! +!!##DESCRIPTION +!! In the special case when creating a program with subcommands it +!! is assumed the first word on the command line is the subcommand. A +!! routine is required to handle response file processing, therefore +!! this routine (optionally processing response files) returns that +!! first word as the subcommand name. +!! +!! It should not be used by programs not building a more elaborate +!! command with subcommands. +!! +!!##RETURNS +!! NAME name of subcommand +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_get_subcommand +!! !x! SUBCOMMANDS +!! !x! For a command with subcommands like git(1) +!! !x! you can make separate namelists for each subcommand. +!! !x! You can call this program which has two subcommands (run, test), +!! !x! like this: +!! !x! demo_get_subcommand --help +!! !x! demo_get_subcommand run -x -y -z --title -l -L +!! !x! demo_get_subcommand test --title -l -L --testname +!! !x! demo_get_subcommand run --help +!! implicit none +!! !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES +!! real :: x=-999.0,y=-999.0,z=-999.0 +!! character(len=80) :: title="not set" +!! logical :: l=.false. +!! logical :: l_=.false. +!! character(len=80) :: testname="not set" +!! character(len=20) :: name +!! call parse(name) !x! DEFINE AND PARSE COMMAND LINE +!! !x! ALL DONE CRACKING THE COMMAND LINE. +!! !x! USE THE VALUES IN YOUR PROGRAM. +!! write(*,*)'command was ',name +!! write(*,*)'x,y,z .... ',x,y,z +!! write(*,*)'title .... ',title +!! write(*,*)'l,l_ ..... ',l,l_ +!! write(*,*)'testname . ',testname +!! contains +!! subroutine parse(name) +!! !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY +!! use M_CLI2, only : set_args, get_args, get_args_fixed_length +!! use M_CLI2, only : get_subcommand, set_mode +!! character(len=*) :: name ! the subcommand name +!! character(len=:),allocatable :: help_text(:), version_text(:) +!! call set_mode('response_file') +!! ! define version text +!! version_text=[character(len=80) :: & +!! '@(#)PROGRAM: demo_get_subcommand >', & +!! '@(#)DESCRIPTION: My demo program >', & +!! '@(#)VERSION: 1.0 20200715 >', & +!! '@(#)AUTHOR: me, myself, and I>', & +!! '@(#)LICENSE: Public Domain >', & +!! '' ] +!! ! general help for "demo_get_subcommand --help" +!! help_text=[character(len=80) :: & +!! ' allowed subcommands are ', & +!! ' * run -l -L --title -x -y -z ', & +!! ' * test -l -L --title ', & +!! '' ] +!! ! find the subcommand name by looking for first word on command +!! ! not starting with dash +!! name = get_subcommand() +!! select case(name) +!! case('run') +!! help_text=[character(len=80) :: & +!! ' ', & +!! ' Help for subcommand "run" ', & +!! ' ', & +!! '' ] +!! call set_args( & +!! & '-x 1 -y 2 -z 3 --title "my title" -l F -L F',& +!! & help_text,version_text) +!! call get_args('x',x) +!! call get_args('y',y) +!! call get_args('z',z) +!! call get_args_fixed_length('title',title) +!! call get_args('l',l) +!! call get_args('L',l_) +!! case('test') +!! help_text=[character(len=80) :: & +!! ' ', & +!! ' Help for subcommand "test" ', & +!! ' ', & +!! '' ] +!! call set_args(& +!! & '--title "my title" -l F -L F --testname "Test"',& +!! & help_text,version_text) +!! call get_args_fixed_length('title',title) +!! call get_args('l',l) +!! call get_args('L',l_) +!! call get_args_fixed_length('testname',testname) +!! case default +!! ! process help and version +!! call set_args(' ',help_text,version_text) +!! write(*,'(*(a))')'unknown or missing subcommand [',trim(name),']' +!! write(*,'(a)')[character(len=80) :: & +!! ' allowed subcommands are ', & +!! ' * run -l -L -title -x -y -z ', & +!! ' * test -l -L -title ', & +!! '' ] +!! stop +!! end select +!! end subroutine parse +!! end program demo_get_subcommand +!! +!!##AUTHOR +!! John S. Urban, 2019 +!! +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +function get_subcommand() result(sub) + +! ident_2="@(#) M_CLI2 get_subcommand(3f) parse prototype string to get subcommand allowing for response files" + +character(len=:),allocatable :: sub +character(len=:),allocatable :: cmdarg +character(len=:),allocatable :: array(:) +character(len=:),allocatable :: prototype +integer :: ilongest +integer :: i +integer :: j +integer :: iend + G_RESPONSE_PREFIX=get_env('CLI_RESPONSE_PREFIX','@') + G_subcommand='' + G_options_only=.true. + sub='' + + if(.not.allocated(unnamed))then + allocate(character(len=0) :: unnamed(0)) + endif + + ilongest=longest_command_argument() + allocate(character(len=max(63,ilongest)):: cmdarg) + cmdarg(:) = '' + ! look for @NAME if CLI_RESPONSE_FILE=.TRUE. AND LOAD THEM + do i = 1, command_argument_count() + call get_command_argument(i, cmdarg) + call move_from_end(cmdarg) + if(scan(adjustl(cmdarg(1:len(G_RESPONSE_PREFIX))),G_RESPONSE_PREFIX) == 1)then + call get_prototype(cmdarg,prototype) + call split(prototype,array) + ! assume that if using subcommands first word not starting with dash is the subcommand + do j=1,size(array) + if(adjustl(array(j)(1:1)) /= '-')then + G_subcommand=trim(array(j)) + sub=G_subcommand + exit + endif + enddo + endif + enddo + + if(G_subcommand /= '')then + sub=G_subcommand + elseif(size(unnamed) /= 0)then + sub=unnamed(1) + else + cmdarg(:) = '' + do i = 1, command_argument_count() + call get_command_argument(i, cmdarg) + if(adjustl(cmdarg(1:1)) /= '-')then + sub=trim(cmdarg) + exit + endif + enddo + endif + G_options_only=.false. +end function get_subcommand +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine move_from_end(string) +character(len=*) :: string +integer :: iend +! @ is treated as a special character in powershell so allow the prefix to be a suffix and move it to beginning of line + iend=len_trim(string) + if(string(iend-len(G_RESPONSE_PREFIX)+1:iend)== G_RESPONSE_PREFIX)then + string(:)= G_RESPONSE_PREFIX//string(1:iend-len(G_RESPONSE_PREFIX)) + endif +end subroutine move_from_end +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! set_usage(3f) - [ARGUMENTS:M_CLI2] allow setting a short description +!! of keywords for the --usage switch +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine set_usage(keyword,description) +!! +!! character(len=*),intent(in) :: keyword +!! character(len=*),intent(in) :: description +!! +!!##DESCRIPTION +!! +!!##OPTIONS +!! KEYWORD the name of a command keyword +!! DESCRIPTION a brief one-line description of the keyword +!! +!! +!!##EXAMPLE +!! +!! sample program: +!! +!! program demo_set_usage +!! use M_CLI2, only : set_args, igets, rgets, specified, sget, lget +!! implicit none +!! +!! integer,allocatable :: ints(:) +!! logical :: flag +!! call set_args(' --flag:f F --ints:i 1,10,11 ') +!! call set_usage('flag','This is my flag') +!! call set_usage('ints','These are my whole numbers') +!! flag=lget('flag') +!! ints=igets('ints') +!! write(*,*)'flag=',flag +!! write(*,*)'ints=',ints +!! end program demo_set_usage +!! +!! Results: +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +subroutine set_usage(keyword,description,value) +character(len=*),intent(in) :: keyword +character(len=*),intent(in) :: description +character(len=*),intent(in) :: value +write(*,*)keyword +write(*,*)description +write(*,*)value +! store the descriptions in an array and then apply them when set_args(3f) is called. +! alternatively, could allow for a value as well in lieu of the prototype +end subroutine set_usage +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! prototype_to_dictionary(3f) - [ARGUMENTS:M_CLI2] parse user command +!! and store tokens into dictionary +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! recursive subroutine prototype_to_dictionary(string) +!! +!! character(len=*),intent(in) :: string +!! +!!##DESCRIPTION +!! given a string of form +!! +!! -var value -var value +!! +!! define dictionary of form +!! +!! keyword(i), value(i) +!! +!! o string values +!! +!! o must be delimited with double quotes. +!! o adjacent double quotes put one double quote into value +!! o must not be null. A blank is specified as " ", not "". +!! +!! o logical values +!! +!! o logical values must have a value. Use F. +!! +!! o leading and trailing blanks are removed from unquoted values +!! +!! +!!##OPTIONS +!! STRING string is character input string to define command +!! +!!##RETURNS +!! +!!##EXAMPLE +!! +!! sample program: +!! +!! call prototype_to_dictionary(' -l F --ignorecase F --title "my title string" -x 10.20') +!! call prototype_to_dictionary(' --ints 1,2,3,4') +!! +!! Results: +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +recursive subroutine prototype_to_dictionary(string) + +! ident_3="@(#) M_CLI2 prototype_to_dictionary(3f) parse user command and store tokens into dictionary" + +character(len=*),intent(in) :: string ! string is character input string of options and values + +character(len=:),allocatable :: dummy ! working copy of string +character(len=:),allocatable :: value +character(len=:),allocatable :: keyword +character(len=3) :: delmt ! flag if in a delimited string or not +character(len=1) :: currnt ! current character being processed +character(len=1) :: prev ! character to left of CURRNT +character(len=1) :: forwrd ! character to right of CURRNT +integer,dimension(2) :: ipnt +integer :: islen ! number of characters in input string +integer :: ipoint +integer :: itype +integer,parameter :: VAL=1, KEYW=2 +integer :: ifwd +integer :: ibegin +integer :: iend +integer :: place + + islen=len_trim(string) ! find number of characters in input string + if(islen == 0)then ! if input string is blank, even default variable will not be changed + return + endif + dummy=adjustl(string)//' ' + + keyword="" ! initial variable name + value="" ! initial value of a string + ipoint=0 ! ipoint is the current character pointer for (dummy) + ipnt(2)=2 ! pointer to position in keyword + ipnt(1)=1 ! pointer to position in value + itype=VAL ! itype=1 for value, itype=2 for variable + + delmt="off" + prev=" " + + G_keyword_single_letter=.true. + do + ipoint=ipoint+1 ! move current character pointer forward + currnt=dummy(ipoint:ipoint) ! store current character into currnt + ifwd=min(ipoint+1,islen) ! ensure not past end of string + forwrd=dummy(ifwd:ifwd) ! next character (or duplicate if last) + + if((currnt=="-" .and. prev==" " .and. delmt == "off" .and. index("0123456789.",forwrd) == 0).or.ipoint > islen)then + ! beginning of a keyword + if(forwrd == '-')then ! change --var to -var so "long" syntax is supported + !x!dummy(ifwd:ifwd)='_' + ipoint=ipoint+1 ! ignore second - instead (was changing it to _) + G_keyword_single_letter=.false. ! flag this is a long keyword + else + G_keyword_single_letter=.true. ! flag this is a short (single letter) keyword + endif + if(ipnt(1)-1 >= 1)then ! position in value + ibegin=1 + iend=len_trim(value(:ipnt(1)-1)) + TESTIT: do + if(iend == 0)then ! len_trim returned 0, value is blank + iend=ibegin + exit TESTIT + elseif(value(ibegin:ibegin) == " ")then + ibegin=ibegin+1 + else + exit TESTIT + endif + enddo TESTIT + if(keyword /= ' ')then + if(value=='[]')value=',' + call update(keyword,value) ! store name and its value + elseif( G_remaining_option_allowed)then ! meaning "--" has been encountered + if(value=='[]')value=',' + call update('_args_',trim(value)) + else + !x!write(warn,'(*(g0))')'*prototype_to_dictionary* warning: ignoring string [',trim(value),'] for ',trim(keyword) + G_RESPONSE_IGNORED=TRIM(VALUE) + if(G_DEBUG)write(*,gen)'PROTOTYPE_TO_DICTIONARY:G_RESPONSE_IGNORED:',G_RESPONSE_IGNORED + endif + else + call locate_key(keyword,place) + if(keyword /= ' '.and.place < 0)then + call update(keyword,'F') ! store name and null value (first pass) + elseif(keyword /= ' ')then + call update(keyword,' ') ! store name and null value (second pass) + elseif(.not.G_keyword_single_letter.and.ipoint-2 == islen) then ! -- at end of line + G_remaining_option_allowed=.true. ! meaning for "--" is that everything on commandline goes into G_remaining + endif + endif + itype=KEYW ! change to expecting a keyword + value="" ! clear value for this variable + keyword="" ! clear variable name + ipnt(1)=1 ! restart variable value + ipnt(2)=1 ! restart variable name + + else ! currnt is not one of the special characters + ! the space after a keyword before the value + if(currnt == " " .and. itype == KEYW)then + ! switch from building a keyword string to building a value string + itype=VAL + ! beginning of a delimited value + elseif(currnt == """".and.itype == VAL)then + ! second of a double quote, put quote in + if(prev == """")then + if(itype == VAL)then + value=value//currnt + else + keyword=keyword//currnt + endif + ipnt(itype)=ipnt(itype)+1 + delmt="on" + elseif(delmt == "on")then ! first quote of a delimited string + delmt="off" + else + delmt="on" + endif + if(prev /= """")then ! leave quotes where found them + if(itype == VAL)then + value=value//currnt + else + keyword=keyword//currnt + endif + ipnt(itype)=ipnt(itype)+1 + endif + else ! add character to current keyword or value + if(itype == VAL)then + value=value//currnt + else + keyword=keyword//currnt + endif + ipnt(itype)=ipnt(itype)+1 + endif + + endif + + prev=currnt + if(ipoint <= islen)then + cycle + else + exit + endif + enddo + +end subroutine prototype_to_dictionary +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! specified(3f) - [ARGUMENTS:M_CLI2] return true if keyword was present +!! on command line +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! elemental impure function specified(name) +!! +!! character(len=*),intent(in) :: name +!! logical :: specified +!! +!!##DESCRIPTION +!! +!! specified(3f) returns .true. if the specified keyword was present on +!! the command line. +!! +!! M_CLI2 intentionally does not have validators except for SPECIFIED(3f) +!! and of course a check whether the input conforms to the type when +!! requesting a value (with get_args(3f) or the convenience functions +!! like inum(3f)). +!! +!! Fortran already has powerful validation capabilities. Logical +!! expressions ANY(3f) and ALL(3f) are standard Fortran features which +!! easily allow performing the common validations for command line +!! arguments without having to learn any additional syntax or methods. +!! +!!##OPTIONS +!! +!! NAME name of commandline argument to query the presence of. Long +!! names should always be used. +!! +!!##RETURNS +!! SPECIFIED returns .TRUE. if specified NAME was present on the command +!! line when the program was invoked. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_specified +!! use, intrinsic :: iso_fortran_env, only : & +!! & stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT +!! use M_CLI2, only : set_args, igets, rgets, specified, sget, lget +!! implicit none +!! +!! ! Define args +!! integer,allocatable :: ints(:) +!! real,allocatable :: floats(:) +!! logical :: flag +!! character(len=:),allocatable :: color +!! character(len=:),allocatable :: list(:) +!! integer :: i +!! +!! call set_args('& +!! & --color:c "red" & +!! & --flag:f F & +!! & --ints:i 1,10,11 & +!! & --floats:T 12.3, 4.56 & +!! & ') +!! ints=igets('ints') +!! floats=rgets('floats') +!! flag=lget('flag') +!! color=sget('color') +!! +!! write(*,*)'color=',color +!! write(*,*)'flag=',flag +!! write(*,*)'ints=',ints +!! write(*,*)'floats=',floats +!! +!! write(*,*)'was -flag specified?',specified('flag') +!! +!! ! elemental +!! write(*,*)specified(['floats','ints ']) +!! +!! ! If you want to know if groups of parameters were specified use +!! ! ANY(3f) and ALL(3f) +!! write(*,*)'ANY:',any(specified(['floats','ints '])) +!! write(*,*)'ALL:',all(specified(['floats','ints '])) +!! +!! ! For mutually exclusive +!! if (all(specified(['floats','ints '])))then +!! write(*,*)'You specified both names --ints and --floats' +!! endif +!! +!! ! For required parameter +!! if (.not.any(specified(['floats','ints '])))then +!! write(*,*)'You must specify --ints or --floats' +!! endif +!! +!! ! check if all values are in range from 10 to 30 and even +!! write(*,*)'are all numbers good?',all([ints>=10,ints<= 30,(ints/2)*2==ints]) +!! +!! ! perhaps you want to check one value at a time +!! do i=1,size(ints) +!! write(*,*)ints(i),[ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)] +!! if(all([ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)]) )then +!! write(*,*)ints(i),'is an even number from 10 to 30 inclusive' +!! else +!! write(*,*)ints(i),'is not an even number from 10 to 30 inclusive' +!! endif +!! enddo +!! +!! list = [character(len=10) :: 'red','white','blue'] +!! if( any(color == list) )then +!! write(*,*)color,'matches a value in the list' +!! else +!! write(*,*)color,'not in the list' +!! endif +!! +!! if(size(ints).eq.3)then +!! write(*,*)'ints(:) has expected number of values' +!! else +!! write(*,*)'ints(:) does not have expected number of values' +!! endif +!! +!! end program demo_specified +!! +!! Default output +!! +!! > color=red +!! > flag= F +!! > ints= 1 10 11 +!! > floats= 12.3000002 4.55999994 +!! > was -flag specified? F +!! > F F +!! > ANY: F +!! > ALL: F +!! > You must specify --ints or --floats +!! > 1 F T F +!! > 1 is not an even number from 10 to 30 inclusive +!! > 10 T T T +!! > 10 is an even number from 10 to 30 inclusive +!! > 11 T T F +!! > 11 is not an even number from 10 to 30 inclusive +!! > red matches a value in the list +!! > ints(:) has expected number of values +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +elemental impure function specified(key) +character(len=*),intent(in) :: key +logical :: specified +integer :: place + call locate_key(key,place) ! find where string is or should be + if(place < 1)then + specified=.false. + else + specified=present_in(place) + endif +end function specified +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! update(3f) - [ARGUMENTS:M_CLI2] update internal dictionary given +!! keyword and value +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine update(key,val) +!! +!! character(len=*),intent(in) :: key +!! character(len=*),intent(in),optional :: val +!!##DESCRIPTION +!! Update internal dictionary in M_CLI2(3fm) module. +!!##OPTIONS +!! key name of keyword to add, replace, or delete from dictionary +!! val if present add or replace value associated with keyword. If not +!! present remove keyword entry from dictionary. +!! +!! If "present" is true, a value will be appended +!!##EXAMPLE +!! +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +subroutine update(key,val) +character(len=*),intent(in) :: key +character(len=*),intent(in),optional :: val +integer :: place, ii +integer :: iilen +character(len=:),allocatable :: val_local +character(len=:),allocatable :: short +character(len=:),allocatable :: long +character(len=:),allocatable :: long_short(:) +integer :: isize +logical :: set_mandatory + set_mandatory=.false. + if(G_IGNOREALLCASE) then + call split(lower(trim(key)),long_short,':',nulls='return') ! split long:short keyword or long:short:: or long:: or short:: + else + call split(trim(key),long_short,':',nulls='return') ! split long:short keyword or long:short:: or long:: or short:: + endif + ! check for :: on end + isize=size(long_short) + + if(isize > 0)then ! very special-purpose syntax where if ends in :: next field is a value even + if(long_short(isize) == '')then ! if it starts with a dash, for --flags option on fpm(1). + set_mandatory=.true. + long_short=long_short(:isize-1) + endif + endif + + select case(size(long_short)) + case(0) + long='' + short='' + case(1) + long=trim(long_short(1)) + if(len_trim(long) == 1)then + !x!ii= findloc (shorts, long, dim=1) ! if parsing arguments on line and a short keyword look up long value + ii=maxloc([0,merge(1, 0, shorts == long)],dim=1) + if(ii > 1)then + long=keywords(ii-1) + endif + short=long + else + short='' + endif + case(2) + long=trim(long_short(1)) + short=trim(long_short(2)) + case default + write(warn,*)'WARNING: incorrect syntax for key: ',trim(key) + long=trim(long_short(1)) + short=trim(long_short(2)) + end select + if(G_UNDERDASH) long=replace_str(long,'-','_') + if(G_NODASHUNDER)then + long=replace_str(long,'-','') + long=replace_str(long,'_','') + endif + if(G_IGNORELONGCASE.and.len_trim(long) > 1)long=lower(long) + if(present(val))then + val_local=val + iilen=len_trim(val_local) + call locate_key(long,place) ! find where string is or should be + if(place < 1)then ! if string was not found insert it + call insert_(keywords,long,iabs(place)) + call insert_(values,val_local,iabs(place)) + call insert_(counts,iilen,iabs(place)) + call insert_(shorts,short,iabs(place)) + call insert_(present_in,.true.,iabs(place)) + call insert_(mandatory,set_mandatory,iabs(place)) + else + if(present_in(place))then ! if multiple keywords append values with space between them + if(G_append)then + if(values(place)(1:1) == '"')then + ! UNDESIRABLE: will ignore previous blank entries + val_local='"'//trim(unquote(values(place)))//' '//trim(unquote(val_local))//'"' + else + val_local=clipends(values(place))//' '//val_local + endif + endif + iilen=len_trim(val_local) + endif + call replace_(values,val_local,place) + call replace_(counts,iilen,place) + call replace_(present_in,.true.,place) + endif + else ! if no value is present remove the keyword and related values + call locate_key(long,place) ! check name as long and short + if(place > 0)then + call remove_(keywords,place) + call remove_(values,place) + call remove_(counts,place) + call remove_(shorts,place) + call remove_(present_in,place) + call remove_(mandatory,place) + endif + endif +end subroutine update +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! wipe_dictionary(3fp) - [ARGUMENTS:M_CLI2] reset private M_CLI2(3fm) +!! dictionary to empty +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine wipe_dictionary() +!!##DESCRIPTION +!! reset private M_CLI2(3fm) dictionary to empty +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_wipe_dictionary +!! use M_CLI2, only : dictionary +!! call wipe_dictionary() +!! end program demo_wipe_dictionary +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +subroutine wipe_dictionary() + if(allocated(keywords))deallocate(keywords) + allocate(character(len=0) :: keywords(0)) + if(allocated(values))deallocate(values) + allocate(character(len=0) :: values(0)) + if(allocated(counts))deallocate(counts) + allocate(counts(0)) + if(allocated(shorts))deallocate(shorts) + allocate(character(len=0) :: shorts(0)) + if(allocated(present_in))deallocate(present_in) + allocate(present_in(0)) + if(allocated(mandatory))deallocate(mandatory) + allocate(mandatory(0)) +end subroutine wipe_dictionary +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! get(3f) - [ARGUMENTS:M_CLI2] get dictionary value associated with +!! key name in private M_CLI2(3fm) dictionary +!!##SYNOPSIS +!! +!! +!!##DESCRIPTION +!! Get dictionary value associated with key name in private M_CLI2(3fm) +!! dictionary. +!!##OPTIONS +!!##RETURNS +!!##EXAMPLE +!! +!=================================================================================================================================== +function get(key) result(valout) +character(len=*),intent(in) :: key +character(len=:),allocatable :: valout +integer :: place + ! find where string is or should be + call locate_key(key,place) + if(place < 1)then + valout='' + else + valout=values(place)(:counts(place)) + endif +end function get +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! prototype_and_cmd_args_to_nlist(3f) - [ARGUMENTS:M_CLI2] convert +!! Unix-like command arguments to table +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine prototype_and_cmd_args_to_nlist(prototype) +!! +!! character(len=*) :: prototype +!!##DESCRIPTION +!! create dictionary with character keywords, values, and value lengths +!! using the routines for maintaining a list from command line arguments. +!!##OPTIONS +!! prototype +!!##EXAMPLE +!! +!! Sample program +!! +!! program demo_prototype_and_cmd_args_to_nlist +!! use M_CLI2, only : prototype_and_cmd_args_to_nlist, unnamed +!! implicit none +!! character(len=:),allocatable :: readme +!! character(len=256) :: message +!! integer :: ios +!! integer :: i +!! doubleprecision :: something +!! +!! ! define arguments +!! logical :: l,h,v +!! real :: p(2) +!! complex :: c +!! doubleprecision :: x,y,z +!! +!! ! uppercase keywords get an underscore to make it easier to remember +!! logical :: l_,h_,v_ +!! ! character variables must be long enough to hold returned value +!! character(len=256) :: a_,b_ +!! integer :: c_(3) +!! +!! ! give command template with default values +!! ! all values except logicals get a value. +!! ! strings must be delimited with double quotes +!! ! A string has to have at least one character as for -A +!! ! lists of numbers should be comma-delimited. +!! ! No spaces are allowed in lists of numbers +!! call prototype_and_cmd_args_to_nlist('& +!! & -l -v -h -LVH -x 0 -y 0.0 -z 0.0d0 -p 0,0 & +!! & -A " " -B "Value B" -C 10,20,30 -c (-123,-456)',readme) +!! +!! call get_args('x',x,'y',y,'z',z) +!! something=sqrt(x**2+y**2+z**2) +!! write (*,*)something,x,y,z +!! if(size(unnamed) > 0)then +!! write (*,'(a)')'files:' +!! write (*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed)) +!! endif +!! end program demo_prototype_and_cmd_args_to_nlist +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +subroutine prototype_and_cmd_args_to_nlist(prototype,string) + +! ident_4="@(#) M_CLI2 prototype_and_cmd_args_to_nlist create dictionary from prototype if not null and update from command line" + +character(len=*),intent(in) :: prototype +character(len=*),intent(in),optional :: string +integer :: ibig +integer :: itrim +integer :: iused + + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_NLIST:START' + G_passed_in=prototype ! make global copy for printing + ibig=longest_command_argument() ! bug in gfortran. len=0 should be fine + ibig=max(ibig,1) + IF(ALLOCATED(UNNAMED))DEALLOCATE(UNNAMED) + ALLOCATE(CHARACTER(LEN=IBIG) :: UNNAMED(0)) + if(allocated(args))deallocate(args) + allocate(character(len=ibig) :: args(0)) + + G_remaining_option_allowed=.false. + G_remaining_on=.false. + G_remaining='' + if(prototype /= '')then + call prototype_to_dictionary(prototype) ! build dictionary from prototype + + ! if short keywords not used by user allow them for standard options + + call locate_key('h',iused) + if(iused <= 0)then + call update('help') + call update('help:h','F') + endif + + call locate_key('v',iused) + if(iused <= 0)then + call update('version') + call update('version:v','F') + endif + + call locate_key('V',iused) + if(iused <= 0)then + call update('verbose') + call update('verbose:V','F') + endif + + call locate_key('u',iused) + if(iused <= 0)then + call update('usage') + call update('usage:u','F') + endif + + present_in=.false. ! reset all values to false so everything gets written + endif + + if(present(string))then ! instead of command line arguments use another prototype string + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_NLIST:CALL PROTOTYPE_TO_DICTIONARY:STRING=',STRING + call prototype_to_dictionary(string) ! build dictionary from prototype + else + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_NLIST:CALL CMD_ARGS_TO_DICTIONARY:CHECK=',.true. + call cmd_args_to_dictionary() + endif + + if( len(G_remaining) > 1)then ! if -- was in prototype then after -- on input return rest in this string + itrim=len(G_remaining) + if(G_remaining(itrim:itrim) == ' ')then ! was adding a space at end as building it, but do not want to remove blanks + G_remaining=G_remaining(:itrim-1) + endif + remaining=G_remaining + endif + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_NLIST:NORMAL END' +end subroutine prototype_and_cmd_args_to_nlist +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine expand_response(name) +character(len=*),intent(in) :: name +character(len=:),allocatable :: prototype +logical :: hold + + if(G_DEBUG)write(*,gen)'EXPAND_RESPONSE:START:NAME=',name + + call get_prototype(name,prototype) + + if(prototype /= '')then + hold=G_append + G_append=.false. + if(G_DEBUG)write(*,gen)'EXPAND_RESPONSE:CALL PROTOTYPE_TO_DICTIONARY:PROTOTYPE=',prototype + call prototype_to_dictionary(prototype) ! build dictionary from prototype + G_append=hold + endif + + if(G_DEBUG)write(*,gen)'EXPAND_RESPONSE:END' + +end subroutine expand_response +!=================================================================================================================================== +subroutine get_prototype(name,prototype) ! process @name abbreviations +character(len=*),intent(in) :: name +character(len=:),allocatable,intent(out) :: prototype +character(len=:),allocatable :: filename +character(len=:),allocatable :: os +character(len=:),allocatable :: plain_name +character(len=:),allocatable :: search_for +integer :: lun +integer :: ios +integer :: itrim +character(len=4096) :: line !x! assuming input never this long +character(len=256) :: message +character(len=:),allocatable :: array(:) ! output array of tokens +integer :: lines_processed + + G_RESPONSE_PREFIX=get_env('CLI_RESPONSE_PREFIX','@') + lines_processed=0 + plain_name=name//' ' + plain_name=trim(name(len(G_RESPONSE_PREFIX)+1:)) + os= G_RESPONSE_PREFIX // get_env('OSTYPE',get_env('OS')) + if(G_DEBUG)write(*,gen)'GET_PROTOTYPE:OS=',OS + + search_for='' + ! look for NAME.rsp and see if there is an @OS section in it and position to it and read + if(os /= G_RESPONSE_PREFIX)then + search_for=os + call find_and_read_response_file(plain_name) + if(lines_processed /= 0)return + endif + + ! look for NAME.rsp and see if there is anything before an OS-specific section + search_for='' + call find_and_read_response_file(plain_name) + if(lines_processed /= 0)return + + ! look for ARG0.rsp with @OS@NAME section in it and position to it + if(os /= G_RESPONSE_PREFIX)then + search_for=os//name + call find_and_read_response_file(basename(get_name(),keep_suffix=.false.)) + if(lines_processed /= 0)return + endif + + ! look for ARG0.rsp with a section called @NAME in it and position to it + search_for=name + call find_and_read_response_file(basename(get_name(),keep_suffix=.false.)) + if(lines_processed /= 0)return + + write(*,gen)' response name ['//trim(name)//'] not found' + stop 1 +contains +!=================================================================================================================================== +subroutine find_and_read_response_file(rname) +! search for a simple file named the same as the @NAME field with one entry assumed in it +character(len=*),intent(in) :: rname +character(len=:),allocatable :: paths(:) +character(len=:),allocatable :: testpath +character(len=256) :: message +integer :: i +integer :: ios + prototype='' + ! look for NAME.rsp + ! assume if have / or \ a full filename was supplied to support ifort(1) + if((index(rname,'/') /= 0.or.index(rname,'\') /= 0) .and. len(rname) > 1 )then + filename=rname + lun=fileopen(filename,message) + if(lun /= -1)then + call process_response() + close(unit=lun,iostat=ios) + endif + return + else + filename=rname//'.rsp' + endif + if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:FILENAME=',filename + + ! look for name.rsp in directories from environment variable assumed to be a colon-separated list of directories + call split(get_env('CLI_RESPONSE_PATH',join_path(get_env('HOME'),'/.local/share/rsp')),paths) + paths=[character(len=len(paths)) :: ' ',paths] + if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:PATHS=',paths + + do i=1,size(paths) + testpath=join_path(paths(i),filename) + lun=fileopen(testpath,message) + if(lun /= -1)then + if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:SEARCH_FOR=',search_for + if(search_for /= '') call position_response() ! set to end of file or where string was found + call process_response() + if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:LINES_PROCESSED=',LINES_PROCESSED + close(unit=lun,iostat=ios) + if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:CLOSE:LUN=',LUN,' IOSTAT=',IOS + if(lines_processed /= 0)exit + endif + enddo + +end subroutine find_and_read_response_file +!=================================================================================================================================== +subroutine position_response() +integer :: ios + line='' + INFINITE: do + read(unit=lun,fmt='(a)',iostat=ios,iomsg=message)line + if(is_iostat_end(ios))then + if(G_DEBUG)write(*,gen)'POSITION_RESPONSE:EOF' + backspace(lun,iostat=ios) + exit INFINITE + elseif(ios /= 0)then + write(*,gen)'*position_response*:'//trim(message) + exit INFINITE + endif + line=adjustl(line) + if(line == search_for)return + enddo INFINITE +end subroutine position_response +!=================================================================================================================================== +subroutine process_response() +character(len=:),allocatable :: padded +character(len=:),allocatable :: temp + G_RESPONSE_PREFIX=get_env('CLI_RESPONSE_PREFIX','@') + line='' + lines_processed=0 + INFINITE: do + read(unit=lun,fmt='(a)',iostat=ios,iomsg=message)line + if(is_iostat_end(ios))then + backspace(lun,iostat=ios) + exit INFINITE + elseif(ios /= 0)then + write(*,gen)'*process_response*:'//trim(message) + exit INFINITE + endif + line=clipends(line) + temp=line + if(index(temp//' ','#') == 1)cycle + if(temp /= '')then + + if(index(temp,G_RESPONSE_PREFIX) == 1.and.lines_processed /= 0)exit INFINITE + + call split(temp,array) ! get first word + itrim=len_trim(array(1))+2 + temp=temp(itrim:) + + PROCESS: select case(lower(array(1))) + case('comment','#','') + case('system','!','$') + if(G_options_only)exit PROCESS + lines_processed= lines_processed+1 + call execute_command_line(temp) + case('options','option','-') + lines_processed= lines_processed+1 + prototype=prototype//' '//trim(temp) + case('print','>','echo') + if(G_options_only)exit PROCESS + lines_processed= lines_processed+1 + write(*,'(a)')trim(temp) + case('stop') + if(G_options_only)exit PROCESS + write(*,'(a)')trim(temp) + stop + case default + if(array(1)(1:1) == '-')then + ! assume these are simply options to support ifort(1) + ! if starts with a single dash must assume a single argument + ! and rest is value to support -Dname and -Ifile option + ! which currently is not supported, so multiple short keywords + ! does not work. Just a ifort(1) test at this point, so do not document + if(G_options_only)exit PROCESS + padded=trim(line)//' ' + if(padded(2:2) == '-')then + prototype=prototype//' '//trim(line) + else + prototype=prototype//' '//padded(1:2)//' '//trim(padded(3:)) + endif + lines_processed= lines_processed+1 + else + if(array(1)(1:len(G_RESPONSE_PREFIX)) == G_RESPONSE_PREFIX)cycle INFINITE !skip adjacent @ lines from first + lines_processed= lines_processed+1 + write(*,'(*(g0))')'unknown response keyword [',array(1),'] with options of [',trim(temp),']' + endif + end select PROCESS + + endif + enddo INFINITE +end subroutine process_response + +end subroutine get_prototype +!=================================================================================================================================== +function fileopen(filename,message) result(lun) +character(len=*),intent(in) :: filename +character(len=*),intent(out),optional :: message +integer :: lun +integer :: ios +character(len=256) :: message_local + + ios=0 + message_local='' + open(file=filename,newunit=lun,& + & form='formatted',access='sequential',action='read',& + & position='rewind',status='old',iostat=ios,iomsg=message_local) + + if(ios /= 0)then + lun=-1 + if(present(message))then + message=trim(message_local) + else + write(*,gen)trim(message_local) + endif + endif + if(G_DEBUG)write(*,gen)'FILEOPEN:FILENAME=',filename,' LUN=',lun,' IOS=',IOS,' MESSAGE=',trim(message_local) + +end function fileopen +!=================================================================================================================================== +function get_env(NAME,DEFAULT) result(VALUE) +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 /= '')then + call get_environment_variable(NAME, length=howbig,status=stat,trim_name=.true.) + select case (stat) + case (1) + !x!print *, NAME, " is not defined in the environment. Strange..." + VALUE='' + case (2) + !x!print *, "This processor doesn't support environment variables. Boooh!" + VALUE='' + case default + ! make string to hold value of sufficient size + if(allocated(value))deallocate(value) + allocate(character(len=max(howbig,1)) :: VALUE) + ! get value + call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.) + if(stat /= 0)VALUE='' + end select + else + VALUE='' + endif + if(VALUE == ''.and.present(DEFAULT))VALUE=DEFAULT +end function get_env +!=================================================================================================================================== +function join_path(a1,a2,a3,a4,a5) result(path) + ! Construct path by joining strings with os file separator + ! + character(len=*), intent(in) :: a1, a2 + character(len=*), intent(in), optional :: a3, a4, a5 + character(len=:), allocatable :: path + character(len=1) :: filesep + + filesep = separator() + if(a1 /= '')then + path = trim(a1) // filesep // trim(a2) + else + path = trim(a2) + endif + if (present(a3)) path = path // filesep // trim(a3) + if (present(a4)) path = path // filesep // trim(a4) + if (present(a5)) path = path // filesep // trim(a5) + path=adjustl(path//' ') + ! clean up duplicate adjacent separators + path=path(1:2)//replace_str(path(3:),filesep//filesep,filesep) ! some systems allow filepath starting with // or \ path=trim(path) + +end function join_path +!=================================================================================================================================== +function get_name() result(name) +! get the pathname of arg0 +character(len=:),allocatable :: arg0 +integer :: arg0_length +integer :: istat +character(len=4096) :: long_name +character(len=:),allocatable :: name + arg0_length=0 + name='' + long_name='' + call get_command_argument(0,length=arg0_length,status=istat) + if(istat == 0)then + if(allocated(arg0))deallocate(arg0) + allocate(character(len=arg0_length) :: arg0) + call get_command_argument(0,arg0,status=istat) + if(istat == 0)then + inquire(file=arg0,iostat=istat,name=long_name) + name=trim(long_name) + else + name=arg0 + endif + endif +end function get_name +!=================================================================================================================================== +function basename(path,keep_suffix) result (base) + ! Extract filename from path with/without keep_suffix + ! +character(*), intent(In) :: path +logical, intent(in), optional :: keep_suffix +character(:), allocatable :: base + +character(:), allocatable :: file_parts(:) +logical :: return_with_suffix +integer :: iend + + if (.not.present(keep_suffix)) then + return_with_suffix = .true. + else + return_with_suffix = keep_suffix + endif + + call split(path,file_parts,delimiters='\/') + if(size(file_parts) > 0)then + base = trim(file_parts(size(file_parts))) + else + base = '' + endif + if(.not.return_with_suffix)then + iend=index(base,'.',back=.true.) + if(iend.gt.1)then + base=base(:iend-1) + endif + endif +end function basename +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!! !> +!!##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 testing for the existence of "/.", then if that fails a list +!! of variable names assumed to contain directory paths {PATH|HOME} are +!! examined first for a backslash, then a slash. Assuming basically the +!! choice is a ULS or MSWindows system, and users can do weird things like +!! put a backslash in a ULS path and break it. +!! +!! Therefore 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 +!=================================================================================================================================== +function separator() result(sep) +! use the pathname returned as arg0 to determine pathname separator +integer :: ios +integer :: i +logical :: existing=.false. +character(len=1) :: sep +!x!IFORT BUG:character(len=1),save :: sep_cache=' ' +integer,save :: isep=-1 +character(len=4096) :: name +character(len=:),allocatable :: envnames(:) + + ! NOTE: A parallel code might theoretically use multiple OS + !x!FORT BUG:if(sep_cache /= ' ')then ! use cached value. + !x!FORT BUG: sep=sep_cache + !x!FORT BUG: return + !x!FORT BUG:endif + if(isep /= -1)then ! use cached value. + sep=char(isep) + return + endif + FOUND: block + ! simple, but does not work with ifort + ! most MSWindows environments see to work with backslash even when + ! using POSIX filenames to do not rely on '\.'. + inquire(file='/.',exist=existing,iostat=ios,name=name) + if(existing.and.ios == 0)then + sep='/' + exit FOUND + endif + ! check variables names common to many platforms that usually have a + ! directory path in them although a ULS file can contain a backslash + ! and vice-versa (eg. "touch A\\B\\C"). Removed HOMEPATH because it + ! returned a name with backslash on CygWin, Mingw, WLS even when using + ! POSIX filenames in the environment. + envnames=[character(len=10) :: 'PATH', 'HOME'] + do i=1,size(envnames) + if(index(get_env(envnames(i)),'\') /= 0)then + sep='\' + exit FOUND + elseif(index(get_env(envnames(i)),'/') /= 0)then + sep='/' + exit FOUND + endif + enddo + + write(*,*)'unknown system directory path separator' + sep='\' + endblock FOUND + !x!IFORT BUG:sep_cache=sep + isep=ichar(sep) +end function separator +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine cmd_args_to_dictionary() +! convert command line arguments to dictionary entries +!x!logical :: guess_if_value +integer :: pointer +character(len=:),allocatable :: lastkeyword +integer :: i, jj, kk +integer :: ilength, istatus, imax +character(len=1) :: letter +character(len=:),allocatable :: current_argument +character(len=:),allocatable :: current_argument_padded +character(len=:),allocatable :: dummy +character(len=:),allocatable :: oldvalue +logical :: nomore +logical :: next_mandatory + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:START' + G_RESPONSE_PREFIX=get_env('CLI_RESPONSE_PREFIX','@') + next_mandatory=.false. + nomore=.false. + pointer=0 + lastkeyword=' ' + G_keyword_single_letter=.true. + i=1 + current_argument='' + GET_ARGS: do while (get_next_argument()) ! insert and replace entries + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:WHILE:CURRENT_ARGUMENT=',current_argument + + if( current_argument == '-' .and. nomore .eqv. .true. )then ! sort of + elseif( current_argument == '-')then ! sort of + current_argument='"stdin"' + endif + if( current_argument == '--' .and. nomore .eqv. .true. )then ! -- was already encountered + elseif( current_argument == '--' )then ! everything after this goes into the unnamed array + nomore=.true. + pointer=0 + if(G_remaining_option_allowed)then + G_remaining_on=.true. + endif + cycle GET_ARGS + endif + + dummy=current_argument//' ' + current_argument_padded=current_argument//' ' + + if(.not.next_mandatory.and..not.nomore.and.current_argument_padded(1:2) == '--')then ! beginning of long word + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:START_LONG:' + G_keyword_single_letter=.false. + if(lastkeyword /= '')then + call ifnull() + endif + call locate_key(current_argument_padded(3:),pointer) + if(pointer <= 0)then + if(G_QUIET)then + lastkeyword="UNKNOWN" + pointer=0 + cycle GET_ARGS + endif + call print_dictionary('UNKNOWN LONG KEYWORD: '//current_argument) + call mystop(1) + return + endif + lastkeyword=trim(current_argument_padded(3:)) + next_mandatory=mandatory(pointer) + elseif(.not.next_mandatory & + & .and..not.nomore & + & .and.current_argument_padded(1:1) == '-' & + & .and.index("0123456789.",dummy(2:2)) == 0)then + ! short word + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:START_SHORT' + G_keyword_single_letter=.true. + if(lastkeyword /= '')then + call ifnull() + endif + call locate_key(current_argument_padded(2:),pointer) + jj=len(current_argument) + if( (pointer <= 0.or.jj.ge.3).and.(G_STRICT) )then ! name not found + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:SHORT NOT FOUND:',current_argument_padded(2:) + ! in strict mode this might be multiple single-character values + do kk=2,jj + letter=current_argument_padded(kk:kk) + call locate_key(letter,pointer) + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:LETTER:',letter,pointer + if(pointer > 0)then + call update(keywords(pointer),'T') + else + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:UNKNOWN SHORT:',letter + call print_dictionary('UNKNOWN SHORT KEYWORD:'//letter) ! //' in '//current_argument) + if(G_QUIET)then + lastkeyword="UNKNOWN" + pointer=0 + cycle GET_ARGS + endif + call mystop(2) + return + endif + current_argument='-'//current_argument_padded(jj:jj) + enddo + !-------------- + lastkeyword="" + pointer=0 + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:SHORT_END:2:' + cycle GET_ARGS + !-------------- + elseif(pointer<0)then + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:UNKNOWN SHORT_CONFIRMED:',letter + call print_dictionary('UNKNOWN SHORT KEYWORD:'//current_argument_padded(2:)) + if(G_QUIET)then + lastkeyword="UNKNOWN" + pointer=0 + cycle GET_ARGS + endif + call mystop(2) + return + endif + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:SHORT_END:1:' + lastkeyword=trim(current_argument_padded(2:)) + next_mandatory=mandatory(pointer) + elseif(pointer == 0)then ! unnamed arguments + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:UNNAMED ARGUMENT:',current_argument + if(G_remaining_on)then + if(len(current_argument) < 1)then + G_remaining=G_remaining//'"" ' + elseif(current_argument(1:1) == '-')then + !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//' ' + G_remaining=G_remaining//'"'//current_argument//'" ' + else + G_remaining=G_remaining//'"'//current_argument//'" ' + endif + imax=max(len(args),len(current_argument)) + args=[character(len=imax) :: args,current_argument] + else + imax=max(len(unnamed),len(current_argument)) + if(scan(current_argument//' ',G_RESPONSE_PREFIX) == 1.and.G_response)then + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:1:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument + call expand_response(current_argument) + else + unnamed=[character(len=imax) :: unnamed,current_argument] + endif + endif + else + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:FOUND:',current_argument + oldvalue=get(keywords(pointer))//' ' + if(oldvalue(1:1) == '"')then + current_argument=quote(current_argument(:ilength)) + endif + if(upper(oldvalue) == 'F'.or.upper(oldvalue) == 'T')then ! assume boolean parameter + if(current_argument /= ' ')then + if(G_remaining_on)then + if(len(current_argument) < 1)then + G_remaining=G_remaining//'"" ' + elseif(current_argument(1:1) == '-')then + !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//' ' + G_remaining=G_remaining//'"'//current_argument//'" ' + else + G_remaining=G_remaining//'"'//current_argument//'" ' + endif + imax=max(len(args),len(current_argument)) + args=[character(len=imax) :: args,current_argument] + else + imax=max(len(unnamed),len(current_argument)) + if(scan(current_argument//' ',G_RESPONSE_PREFIX) == 1.and.G_response)then + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:2:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument + call expand_response(current_argument) + else + unnamed=[character(len=imax) :: unnamed,current_argument] + endif + endif + endif + current_argument='T' + endif + call update(keywords(pointer),current_argument) + pointer=0 + lastkeyword='' + next_mandatory=.false. + endif + enddo GET_ARGS + if(lastkeyword /= '')then + call ifnull() + endif + if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:NORMAL END' + +contains + +subroutine ifnull() + + oldvalue=clipends(get(lastkeyword))//' ' + + if(upper(oldvalue(1:1)) == 'F'.or.upper(oldvalue(1:1)) == 'T')then + call update(lastkeyword,'T') + elseif(oldvalue(1:1) == '"')then + call update(lastkeyword,'" "') + else + call update(lastkeyword,' ') + endif + +end subroutine ifnull + +function get_next_argument() +! +! get next argument from command line into allocated variable current_argument +! +logical,save :: hadequal=.false. +character(len=:),allocatable,save :: right_hand_side +logical :: get_next_argument +integer :: iright +integer :: iequal + + if(hadequal)then ! use left-over value from previous -NAME=VALUE syntax + current_argument=right_hand_side + right_hand_side='' + hadequal=.false. + get_next_argument=.true. + ilength=len(current_argument) + return + endif + + if(i>command_argument_count())then + get_next_argument=.false. + return + else + get_next_argument=.true. + endif + + call get_command_argument(number=i,length=ilength,status=istatus) ! get next argument + if(istatus /= 0) then ! on error + write(warn,*)'*prototype_and_cmd_args_to_nlist* error obtaining argument ',i,& + &'status=',istatus,& + &'length=',ilength + get_next_argument=.false. + else + ilength=max(ilength,1) + if(allocated(current_argument))deallocate(current_argument) + allocate(character(len=ilength) :: current_argument) + call get_command_argument(number=i,value=current_argument,length=ilength,status=istatus) ! get next argument + if(istatus /= 0) then ! on error + write(warn,*)'*prototype_and_cmd_args_to_nlist* error obtaining argument ',i,& + &'status=',istatus,& + &'length=',ilength,& + &'target length=',len(current_argument) + get_next_argument=.false. + endif + + ! if an argument keyword and an equal before a space split on equal and save right hand side for next call + if(nomore)then + elseif( len(current_argument) == 0)then + else + iright=index(current_argument,' ') + if(iright == 0)iright=len(current_argument) + iequal=index(current_argument(:iright),'=') + if(next_mandatory)then + elseif(iequal /= 0.and.current_argument(1:1) == '-')then + if(iequal /= len(current_argument))then + right_hand_side=current_argument(iequal+1:) + else + right_hand_side='' + endif + hadequal=.true. + current_argument=current_argument(:iequal-1) + endif + endif + endif + i=i+1 +end function get_next_argument + +end subroutine cmd_args_to_dictionary +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! print_dictionary(3f) - [ARGUMENTS:M_CLI2] print internal dictionary +!! created by calls to set_args(3f) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine print_dictionary(header,stop) +!! +!! character(len=*),intent(in),optional :: header +!! logical,intent(in),optional :: stop +!!##DESCRIPTION +!! Print the internal dictionary created by calls to set_args(3f). +!! This routine is intended to print the state of the argument list +!! if an error occurs in using the set_args(3f) procedure. +!!##OPTIONS +!! HEADER label to print before printing the state of the command +!! argument list. +!! STOP logical value that if true stops the program after displaying +!! the dictionary. +!!##EXAMPLE +!! +!! +!! +!! Typical usage: +!! +!! program demo_print_dictionary +!! use M_CLI2, only : set_args, get_args +!! implicit none +!! real :: x, y, z +!! call set_args('-x 10 -y 20 -z 30') +!! call get_args('x',x,'y',y,'z',z) +!! ! all done cracking the command line; use the values in your program. +!! write(*,*)x,y,z +!! end program demo_print_dictionary +!! +!! Sample output +!! +!! Calling the sample program with an unknown parameter or the --usage +!! switch produces the following: +!! +!! $ ./demo_print_dictionary -A +!! UNKNOWN SHORT KEYWORD: -A +!! KEYWORD PRESENT VALUE +!! z F [3] +!! y F [2] +!! x F [1] +!! help F [F] +!! version F [F] +!! usage F [F] +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +subroutine print_dictionary(header,stop) +character(len=*),intent(in),optional :: header +logical,intent(in),optional :: stop +integer :: i + if(G_QUIET)return + if(present(header))then + if(header /= '')then + write(warn,'(a)')header + endif + endif + if(allocated(keywords))then + if(size(keywords) > 0)then + write(warn,'(a,1x,a,1x,a,1x,a)')atleast('KEYWORD',max(len(keywords),8)),'SHORT','PRESENT','VALUE' + write(warn,'(*(a,1x,a5,1x,l1,8x,"[",a,"]",/))') & + & (atleast(keywords(i),max(len(keywords),8)),shorts(i),present_in(i),values(i)(:counts(i)),i=size(keywords),1,-1) + endif + endif + if(allocated(unnamed))then + if(size(unnamed) > 0)then + write(warn,'(a)')'UNNAMED' + write(warn,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed)) + endif + endif + if(allocated(args))then + if(size(args) > 0)then + write(warn,'(a)')'ARGS' + write(warn,'(i6.6,3a)')(i,'[',args(i),']',i=1,size(args)) + endif + endif + if(G_remaining /= '')then + write(warn,'(a)')'REMAINING' + write(warn,'(a)')G_remaining + endif + if(present(stop))then + if(stop) call mystop(5) + endif +end subroutine print_dictionary +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! get_args(3f) - [ARGUMENTS:M_CLI2] return keyword values when parsing +!! command line arguments +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! get_args(3f) and its convenience functions: +!! +!! use M_CLI2, only : get_args +!! ! convenience functions +!! use M_CLI2, only : dget, iget, lget, rget, sget, cget +!! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets +!! +!! subroutine get_args(name,value,delimiters) +!! +!! character(len=*),intent(in) :: name +!! +!! type(${TYPE}),allocatable,intent(out) :: value(:) +!! ! or +!! type(${TYPE}),allocatable,intent(out) :: value +!! +!! character(len=*),intent(in),optional :: delimiters +!! +!! where ${TYPE} may be from the set +!! {real,doubleprecision,integer,logical,complex,character(len=:)} +!!##DESCRIPTION +!! +!! GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f) has +!! been called to parse the command line. For fixed-length CHARACTER +!! variables see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see +!! GET_ARGS_FIXED_SIZE(3f). +!! +!! As a convenience multiple pairs of keywords and variables may be +!! specified if and only if all the values are scalars and the CHARACTER +!! variables are fixed-length or pre-allocated. +!! +!!##OPTIONS +!! +!! NAME name of commandline argument to obtain the value of +!! VALUE variable to hold returned value. The kind of the value +!! is used to determine the type of returned value. May +!! be a scalar or allocatable array. If type is CHARACTER +!! the scalar must have an allocatable length. +!! DELIMITERS By default the delimiter for array values are comma, +!! colon, and whitespace. A string containing an alternate +!! list of delimiter characters may be supplied. +!! +!!##CONVENIENCE FUNCTIONS +!! There are convenience functions that are replacements for calls to +!! get_args(3f) for each supported default intrinsic type +!! +!! o scalars -- dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), +!! cget(3f) +!! o vectors -- dgets(3f), igets(3f), lgets(3f), rgets(3f), +!! sgets(3f), cgets(3f) +!! +!! D is for DOUBLEPRECISION, I for INTEGER, L for LOGICAL, R for REAL, +!! S for string (CHARACTER), and C for COMPLEX. +!! +!! If the functions are called with no argument they will return the +!! UNNAMED array converted to the specified type. +!! +!!##EXAMPLE +!! +!! +!! Sample program: +!! +!! program demo_get_args +!! use M_CLI2, only : filenames=>unnamed, set_args, get_args +!! implicit none +!! integer :: i +!! ! Define ARGS +!! real :: x, y, z +!! real,allocatable :: p(:) +!! character(len=:),allocatable :: title +!! logical :: l, lbig +!! ! Define and parse (to set initial values) command line +!! ! o only quote strings and use double-quotes +!! ! o set all logical values to F or T. +!! call set_args(' & +!! & -x 1 -y 2 -z 3 & +!! & -p -1,-2,-3 & +!! & --title "my title" & +!! & -l F -L F & +!! & --label " " & +!! & ') +!! ! Assign values to elements +!! ! Scalars +!! call get_args( 'x',x, 'y',y, 'z',z, 'l',l, 'L',lbig ) +!! ! Allocatable string +!! call get_args('title',title) +!! ! Allocatable arrays +!! call get_args('p',p) +!! ! Use values +!! write(*,'(1x,g0,"=",g0)')'x',x, 'y',y, 'z',z +!! write(*,*)'p=',p +!! write(*,*)'title=',title +!! write(*,*)'l=',l +!! write(*,*)'L=',lbig +!! if(size(filenames) > 0)then +!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) +!! endif +!! end program demo_get_args +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +!> +!!##NAME +!! get_args_fixed_length(3f) - [ARGUMENTS:M_CLI2] return keyword values +!! for fixed-length string when parsing command line +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine get_args_fixed_length(name,value) +!! +!! character(len=*),intent(in) :: name +!! character(len=:),allocatable :: value +!! character(len=*),intent(in),optional :: delimiters +!! +!!##DESCRIPTION +!! +!! get_args_fixed_length(3f) returns the value of a string +!! keyword when the string value is a fixed-length CHARACTER +!! variable. +!! +!!##OPTIONS +!! +!! NAME name of commandline argument to obtain the value of +!! +!! VALUE variable to hold returned value. +!! Must be a fixed-length CHARACTER variable. +!! +!! DELIMITERS By default the delimiter for array values are comma, +!! colon, and whitespace. A string containing an alternate +!! list of delimiter characters may be supplied. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_get_args_fixed_length +!! use M_CLI2, only : set_args, get_args_fixed_length +!! implicit none +!! +!! ! Define args +!! character(len=80) :: title +!! ! Parse command line +!! call set_args(' --title "my title" ') +!! ! Assign values to variables +!! call get_args_fixed_length('title',title) +!! ! Use values +!! write(*,*)'title=',title +!! +!! end program demo_get_args_fixed_length +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +!> +!!##NAME +!! get_args_fixed_size(3f) - [ARGUMENTS:M_CLI2] return keyword values +!! for fixed-size array when parsing command line arguments +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine get_args_fixed_size(name,value) +!! +!! character(len=*),intent(in) :: name +!! [real|doubleprecision|integer|logical|complex] :: value(NNN) +!! or +!! character(len=MMM) :: value(NNN) +!! +!! character(len=*),intent(in),optional :: delimiters +!! +!!##DESCRIPTION +!! +!! get_args_fixed_size(3f) returns the value of keywords for fixed-size +!! arrays after set_args(3f) has been called. On input on the command +!! line all values of the array must be specified. +!! +!!##OPTIONS +!! NAME name of commandline argument to obtain the value of +!! +!! VALUE variable to hold returned values. The kind of the value +!! is used to determine the type of returned value. Must be +!! a fixed-size array. If type is CHARACTER the length must +!! also be fixed. +!! +!! DELIMITERS By default the delimiter for array values are comma, +!! colon, and whitespace. A string containing an alternate +!! list of delimiter characters may be supplied. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_get_args_fixed_size +!! use M_CLI2, only : set_args, get_args_fixed_size +!! implicit none +!! integer,parameter :: dp=kind(0.0d0) +!! ! DEFINE ARGS +!! real :: x(2) +!! real(kind=dp) :: y(2) +!! integer :: p(3) +!! character(len=80) :: title(1) +!! logical :: l(4), lbig(4) +!! complex :: cmp(2) +!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE +!! ! o only quote strings +!! ! o set all logical values to F or T. +!! call set_args(' & +!! & -x 10.0,20.0 & +!! & -y 11.0,22.0 & +!! & -p -1,-2,-3 & +!! & --title "my title" & +!! & -l F,T,F,T -L T,F,T,F & +!! & --cmp 111,222.0,333.0e0,4444 & +!! & ') +!! ! ASSIGN VALUES TO ELEMENTS +!! call get_args_fixed_size('x',x) +!! call get_args_fixed_size('y',y) +!! call get_args_fixed_size('p',p) +!! call get_args_fixed_size('title',title) +!! call get_args_fixed_size('l',l) +!! call get_args_fixed_size('L',lbig) +!! call get_args_fixed_size('cmp',cmp) +!! ! USE VALUES +!! write(*,*)'x=',x +!! write(*,*)'p=',p +!! write(*,*)'title=',title +!! write(*,*)'l=',l +!! write(*,*)'L=',lbig +!! write(*,*)'cmp=',cmp +!! end program demo_get_args_fixed_size +!! Results: +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +subroutine get_fixedarray_class(keyword,generic,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +class(*) :: generic(:) +character(len=*),intent(in),optional :: delimiters + select type(generic) + type is (character(len=*)); call get_fixedarray_fixed_length_c(keyword,generic,delimiters) + type is (integer); call get_fixedarray_i(keyword,generic,delimiters) + type is (real); call get_fixedarray_r(keyword,generic,delimiters) + type is (complex); call get_fixed_size_complex(keyword,generic,delimiters) + type is (real(kind=dp)); call get_fixedarray_d(keyword,generic,delimiters) + type is (logical); call get_fixedarray_l(keyword,generic,delimiters) + class default + call mystop(-7,'*get_fixedarray_class* crud -- procedure does not know about this type') + end select +end subroutine get_fixedarray_class +!=================================================================================================================================== +! return allocatable arrays +!=================================================================================================================================== +subroutine get_anyarray_l(keyword,larray,delimiters) + +! ident_5="@(#) M_CLI2 get_anyarray_l(3f) given keyword fetch logical array from string in dictionary(F on err)" + +character(len=*),intent(in) :: keyword ! the dictionary keyword (in form VERB_KEYWORD) to retrieve +logical,allocatable :: larray(:) ! convert value to an array +character(len=*),intent(in),optional :: delimiters +character(len=:),allocatable :: carray(:) ! convert value to an array +character(len=:),allocatable :: val +integer :: i +integer :: place +integer :: iichar ! point to first character of word unless first character is "." + call locate_key(keyword,place) ! find where string is or should be + if(place > 0)then ! if string was found + val=values(place)(:counts(place)) + call split(adjustl(upper(val)),carray,delimiters=delimiters) ! convert value to uppercase, trimmed; then parse into array + else + call journal('*get_anyarray_l* unknown keyword',keyword) + call mystop(8 ,'*get_anyarray_l* unknown keyword '//keyword) + if(allocated(larray))deallocate(larray) + allocate(larray(0)) + return + endif + if(size(carray) > 0)then ! if not a null string + if(allocated(larray))deallocate(larray) + allocate(larray(size(carray))) ! allocate output array + do i=1,size(carray) + larray(i)=.false. ! initialize return value to .false. + if(carray(i)(1:1) == '.')then ! looking for fortran logical syntax .STRING. + iichar=2 + else + iichar=1 + endif + select case(carray(i)(iichar:iichar)) ! check word to see if true or false + case('T','Y',' '); larray(i)=.true. ! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...) + case('F','N'); larray(i)=.false. ! assume this is false or no + case default + call journal("*get_anyarray_l* bad logical expression for ",(keyword),'=',carray(i)) + end select + enddo + else ! for a blank string return one T + if(allocated(larray))deallocate(larray) + allocate(larray(1)) ! allocate output array + larray(1)=.true. + endif +end subroutine get_anyarray_l +!=================================================================================================================================== +subroutine get_anyarray_d(keyword,darray,delimiters) + +! ident_6="@(#) M_CLI2 get_anyarray_d(3f) given keyword fetch dble value array from Language Dictionary (0 on err)" + +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +real(kind=dp),allocatable,intent(out) :: darray(:) ! function type +character(len=*),intent(in),optional :: delimiters + +character(len=:),allocatable :: carray(:) ! convert value to an array using split(3f) +integer :: i +integer :: place +integer :: ierr +character(len=:),allocatable :: val +!----------------------------------------------------------------------------------------------------------------------------------- + call locate_key(keyword,place) ! find where string is or should be + if(place > 0)then ! if string was found + val=values(place)(:counts(place)) + val=replace_str(val,'(','') + val=replace_str(val,')','') + call split(val,carray,delimiters=delimiters) ! find value associated with keyword and split it into an array + else + call journal('*get_anyarray_d* unknown keyword '//keyword) + call mystop(9 ,'*get_anyarray_d* unknown keyword '//keyword) + if(allocated(darray))deallocate(darray) + allocate(darray(0)) + return + endif + if(allocated(darray))deallocate(darray) + allocate(darray(size(carray))) ! create the output array + do i=1,size(carray) + call a2d(carray(i), darray(i),ierr) ! convert the string to a numeric value + if(ierr /= 0)then + call mystop(10 ,'*get_anyarray_d* unreadable value '//carray(i)//' for keyword '//keyword) + endif + enddo +end subroutine get_anyarray_d +!=================================================================================================================================== +subroutine get_anyarray_i(keyword,iarray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +integer,allocatable :: iarray(:) +character(len=*),intent(in),optional :: delimiters +real(kind=dp),allocatable :: darray(:) ! function type + call get_anyarray_d(keyword,darray,delimiters) + iarray=nint(darray) +end subroutine get_anyarray_i +!=================================================================================================================================== +subroutine get_anyarray_r(keyword,rarray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +real,allocatable :: rarray(:) +character(len=*),intent(in),optional :: delimiters +real(kind=dp),allocatable :: darray(:) ! function type + call get_anyarray_d(keyword,darray,delimiters) + rarray=real(darray) +end subroutine get_anyarray_r +!=================================================================================================================================== +subroutine get_anyarray_x(keyword,xarray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +complex(kind=sp),allocatable :: xarray(:) +character(len=*),intent(in),optional :: delimiters +real(kind=dp),allocatable :: darray(:) ! function type +integer :: half,sz,i + call get_anyarray_d(keyword,darray,delimiters) + sz=size(darray) + half=sz/2 + if(sz /= half+half)then + call journal('*get_anyarray_x* uneven number of values defining complex value '//keyword) + call mystop(11,'*get_anyarray_x* uneven number of values defining complex value '//keyword) + if(allocated(xarray))deallocate(xarray) + allocate(xarray(0)) + endif + + !x!================================================================================================ + !x!IFORT,GFORTRAN OK, NVIDIA RETURNS NULL ARRAY: xarray=cmplx(real(darray(1::2)),real(darray(2::2))) + if(allocated(xarray))deallocate(xarray) + allocate(xarray(half)) + do i=1,sz,2 + xarray((i+1)/2)=cmplx( darray(i),darray(i+1),kind=sp ) + enddo + !x!================================================================================================ + +end subroutine get_anyarray_x +!=================================================================================================================================== +subroutine get_anyarray_c(keyword,strings,delimiters) + +! ident_7="@(#) M_CLI2 get_anyarray_c(3f) Fetch strings value for specified KEYWORD from the lang. dictionary" + +! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary +character(len=*),intent(in) :: keyword ! name to look up in dictionary +character(len=:),allocatable :: strings(:) +character(len=*),intent(in),optional :: delimiters +integer :: place +character(len=:),allocatable :: val + call locate_key(keyword,place) ! find where string is or should be + if(place > 0)then ! if index is valid return strings + val=unquote(values(place)(:counts(place))) + call split(val,strings,delimiters=delimiters) ! find value associated with keyword and split it into an array + else + call journal('*get_anyarray_c* unknown keyword '//keyword) + call mystop(12,'*get_anyarray_c* unknown keyword '//keyword) + if(allocated(strings))deallocate(strings) + allocate(character(len=0)::strings(0)) + endif +end subroutine get_anyarray_c +!=================================================================================================================================== +subroutine get_args_fixed_length_a_array(keyword,strings,delimiters) + +! ident_8="@(#) M_CLI2 get_args_fixed_length_a_array(3f) Fetch strings value for specified KEYWORD from the lang. dictionary" + +! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary +character(len=*),intent(in) :: keyword ! name to look up in dictionary +character(len=*),allocatable :: strings(:) +character(len=*),intent(in),optional :: delimiters +character(len=:),allocatable :: strings_a(:) +integer :: place +character(len=:),allocatable :: val +integer :: ibug + call locate_key(keyword,place) ! find where string is or should be + if(place > 0)then ! if index is valid return strings + val=unquote(values(place)(:counts(place))) + call split(val,strings_a,delimiters=delimiters) ! find value associated with keyword and split it into an array + if( len(strings_a) <= len(strings) )then + strings=strings_a + else + ibug=len(strings) + call journal('*get_args_fixed_length_a_array* values too long. Longest is',len(strings_a),'allowed is',ibug) + write(*,'("strings=",3x,*(a,1x))')strings + call journal('*get_args_fixed_length_a_array* keyword='//keyword) + call mystop(13,'*get_args_fixed_length_a_array* keyword='//keyword) + strings=[character(len=len(strings)) ::] + endif + else + call journal('*get_args_fixed_length_a_array* unknown keyword '//keyword) + call mystop(14,'*get_args_fixed_length_a_array* unknown keyword '//keyword) + strings=[character(len=len(strings)) ::] + endif +end subroutine get_args_fixed_length_a_array +!=================================================================================================================================== +! return non-allocatable arrays +!=================================================================================================================================== +subroutine get_fixedarray_i(keyword,iarray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +integer :: iarray(:) +character(len=*),intent(in),optional :: delimiters +real(kind=dp),allocatable :: darray(:) ! function type +integer :: dsize +integer :: ibug + call get_anyarray_d(keyword,darray,delimiters) + dsize=size(darray) + if(ubound(iarray,dim=1) == dsize)then + iarray=nint(darray) + else + ibug=size(iarray) + call journal('*get_fixedarray_i* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) + call print_dictionary_usage() + call mystop(33) + iarray=0 + endif +end subroutine get_fixedarray_i +!=================================================================================================================================== +subroutine get_fixedarray_r(keyword,rarray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +real :: rarray(:) +character(len=*),intent(in),optional :: delimiters +real,allocatable :: darray(:) ! function type +integer :: dsize +integer :: ibug + call get_anyarray_r(keyword,darray,delimiters) + dsize=size(darray) + if(ubound(rarray,dim=1) == dsize)then + rarray=darray + else + ibug=size(rarray) + call journal('*get_fixedarray_r* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) + call print_dictionary_usage() + call mystop(33) + rarray=0.0 + endif +end subroutine get_fixedarray_r +!=================================================================================================================================== +subroutine get_fixed_size_complex(keyword,xarray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +complex :: xarray(:) +character(len=*),intent(in),optional :: delimiters +complex,allocatable :: darray(:) ! function type +integer :: half, sz +integer :: dsize +integer :: ibug + call get_anyarray_x(keyword,darray,delimiters) + dsize=size(darray) + sz=dsize*2 + half=sz/2 + if(sz /= half+half)then + call journal('*get_fixed_size_complex* uneven number of values defining complex value '//keyword) + call mystop(15,'*get_fixed_size_complex* uneven number of values defining complex value '//keyword) + xarray=0 + return + endif + if(ubound(xarray,dim=1) == dsize)then + xarray=darray + else + ibug=size(xarray) + call journal('*get_fixed_size_complex* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) + call print_dictionary_usage() + call mystop(34) + xarray=cmplx(0.0,0.0) + endif +end subroutine get_fixed_size_complex +!=================================================================================================================================== +subroutine get_fixedarray_d(keyword,darr,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +real(kind=dp) :: darr(:) +character(len=*),intent(in),optional :: delimiters +real(kind=dp),allocatable :: darray(:) ! function type +integer :: dsize +integer :: ibug + call get_anyarray_d(keyword,darray,delimiters) + dsize=size(darray) + if(ubound(darr,dim=1) == dsize)then + darr=darray + else + ibug=size(darr) + call journal('*get_fixedarray_d* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) + call print_dictionary_usage() + call mystop(35) + darr=0.0d0 + endif +end subroutine get_fixedarray_d +!=================================================================================================================================== +subroutine get_fixedarray_l(keyword,larray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +logical :: larray(:) +character(len=*),intent(in),optional :: delimiters +logical,allocatable :: darray(:) ! function type +integer :: dsize +integer :: ibug + call get_anyarray_l(keyword,darray,delimiters) + dsize=size(darray) + if(ubound(larray,dim=1) == dsize)then + larray=darray + else + ibug=size(larray) + call journal('*get_fixedarray_l* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) + call print_dictionary_usage() + call mystop(36) + larray=.false. + endif +end subroutine get_fixedarray_l +!=================================================================================================================================== +subroutine get_fixedarray_fixed_length_c(keyword,strings,delimiters) + +! ident_9="@(#) M_CLI2 get_fixedarray_fixed_length_c(3f) Fetch strings value for specified KEYWORD from the lang. dictionary" + +! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary +character(len=*) :: strings(:) +character(len=*),intent(in),optional :: delimiters +character(len=:),allocatable :: str(:) +character(len=*),intent(in) :: keyword ! name to look up in dictionary +integer :: place +integer :: ssize +integer :: ibug +character(len=:),allocatable :: val + call locate_key(keyword,place) ! find where string is or should be + if(place > 0)then ! if index is valid return strings + val=unquote(values(place)(:counts(place))) + call split(val,str,delimiters=delimiters) ! find value associated with keyword and split it into an array + ssize=size(str) + if(ssize==size(strings))then + strings(:ssize)=str + else + ibug=size(strings) + call journal('*get_fixedarray_fixed_length_c* wrong number of values for keyword',& + & keyword,'got',ssize,'expected ',ibug) !,ubound(strings,dim=1) + call print_dictionary_usage() + call mystop(30,'*get_fixedarray_fixed_length_c* unknown keyword '//keyword) + strings='' + endif + else + call journal('*get_fixedarray_fixed_length_c* unknown keyword '//keyword) + call mystop(16,'*get_fixedarray_fixed_length_c* unknown keyword '//keyword) + strings='' + endif +end subroutine get_fixedarray_fixed_length_c +!=================================================================================================================================== +! return scalars +!=================================================================================================================================== +subroutine get_scalar_d(keyword,d) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +real(kind=dp) :: d +real(kind=dp),allocatable :: darray(:) ! function type +integer :: ibug + call get_anyarray_d(keyword,darray) + if(size(darray) == 1)then + d=darray(1) + else + ibug=size(darray) + call journal('*get_anyarray_d* incorrect number of values for keyword "',keyword,'" expected one found',ibug) + call print_dictionary_usage() + call mystop(31,'*get_anyarray_d* incorrect number of values for keyword "'//keyword//'" expected one') + endif +end subroutine get_scalar_d +!=================================================================================================================================== +subroutine get_scalar_real(keyword,r) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +real,intent(out) :: r +real(kind=dp) :: d + call get_scalar_d(keyword,d) + r=real(d) +end subroutine get_scalar_real +!=================================================================================================================================== +subroutine get_scalar_i(keyword,i) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +integer,intent(out) :: i +real(kind=dp) :: d + call get_scalar_d(keyword,d) + i=nint(d) +end subroutine get_scalar_i +!=================================================================================================================================== +subroutine get_scalar_anylength_c(keyword,string) + +! ident_10="@(#) M_CLI2 get_scalar_anylength_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary" + +! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary +character(len=*),intent(in) :: keyword ! name to look up in dictionary +character(len=:),allocatable,intent(out) :: string +integer :: place + call locate_key(keyword, place) ! find where string is or should be + if (place > 0) then ! if index is valid return string + string = unquote(values(place) (:counts(place))) + else + call journal('*get_anyarray_c* unknown keyword '//keyword) + call mystop(17, '*get_anyarray_c* unknown keyword '//keyword) + string = '' + endif +end subroutine get_scalar_anylength_c +!=================================================================================================================================== +elemental impure subroutine get_args_fixed_length_scalar_c(keyword,string) + +! ident_11="@(#) M_CLI2 get_args_fixed_length_scalar_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary" + +! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary +character(len=*),intent(in) :: keyword ! name to look up in dictionary +character(len=*),intent(out) :: string +integer :: place +integer :: unlen +integer :: ibug + call locate_key(keyword, place) ! find where string is or should be + + if (place > 0) then ! if index is valid return string + string = unquote(values(place) (:counts(place))) + else + call mystop(18, '*get_args_fixed_length_scalar_c* unknown keyword '//keyword) + string = '' + endif + + unlen = len_trim(unquote(values(place) (:counts(place)))) + if (unlen > len(string)) then + ibug = len(string) + call journal('*get_args_fixed_length_scalar_c* value too long for', keyword, 'allowed is', ibug,& + & 'input string [', values(place), '] is', unlen) + call mystop(19, '*get_args_fixed_length_scalar_c* value too long') + string = '' + endif + +end subroutine get_args_fixed_length_scalar_c +!=================================================================================================================================== +subroutine get_scalar_complex(keyword,x) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +complex,intent(out) :: x +real(kind=dp) :: d(2) + + call get_fixedarray_d(keyword,d) + x=cmplx(d(1),d(2),kind=sp) + +end subroutine get_scalar_complex +!=================================================================================================================================== +subroutine get_scalar_logical(keyword,l) +character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary +logical :: l +logical,allocatable :: larray(:) ! function type +integer :: ibug + + l = .false. + + call get_anyarray_l(keyword, larray) + + if (.not. allocated(larray)) then + call journal('*get_scalar_logical* expected one value found not allocated') + call mystop(37, '*get_scalar_logical* incorrect number of values for keyword "'//keyword//'"') + elseif (size(larray) == 1) then + l = larray(1) + else + ibug = size(larray) + call journal('*get_scalar_logical* expected one value found', ibug) + call mystop(21, '*get_scalar_logical* incorrect number of values for keyword "'//keyword//'"') + endif + +end subroutine get_scalar_logical +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +! THE REMAINDER SHOULD BE ROUTINES EXTRACTED FROM OTHER MODULES TO MAKE THIS MODULE STANDALONE BY POPULAR REQUEST +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!use M_strings, only : UPPER, LOWER, QUOTE, REPLACE_STR=>REPLACE, UNQUOTE, SPLIT, STRING_TO_VALUE +!use M_list, only : insert, locate, remove, replace +!use M_journal, only : JOURNAL + +!use M_args, only : LONGEST_COMMAND_ARGUMENT +! routines extracted from other modules +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! longest_command_argument(3f) - [ARGUMENTS:M_args] length of longest +!! argument on command line +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! function longest_command_argument() result(ilongest) +!! +!! integer :: ilongest +!! +!!##DESCRIPTION +!! length of longest argument on command line. Useful when allocating +!! storage for holding arguments. +!!##RESULT +!! longest_command_argument length of longest command argument +!!##EXAMPLE +!! +!! Sample program +!! +!! program demo_longest_command_argument +!! use M_args, only : longest_command_argument +!! write(*,*)'longest argument is ',longest_command_argument() +!! end program demo_longest_command_argument +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +function longest_command_argument() result(ilongest) +integer :: i +integer :: ilength +integer :: istatus +integer :: ilongest + + ilength = 0 + ilongest = 0 + + GET_LONGEST: do i = 1, command_argument_count() ! loop throughout command line arguments to find longest + + call get_command_argument(number=i, length=ilength, status=istatus) ! get next argument + + if (istatus /= 0) then ! on error + write (warn, *) '*prototype_and_cmd_args_to_nlist* error obtaining length for argument ', i + exit GET_LONGEST + elseif (ilength > 0) then + ilongest = max(ilongest, ilength) + endif + + end do GET_LONGEST + +end function longest_command_argument +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! journal(3f) - [M_CLI2] converts a list of standard scalar types to a string and writes message +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine journal(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep,line) +!! +!! class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9 +!! class(*),intent(in),optional :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj +!! character(len=*),intent(in),optional :: sep +!! character(len=:),intent(out),allocatable,optional :: line +!! +!!##DESCRIPTION +!! journal(3f) builds and prints a space-separated string from up to twenty scalar values. +!! +!!##OPTIONS +!! g[0-9a-j] optional value to print the value of after the message. May +!! be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION, +!! COMPLEX, or CHARACTER. +!! +!! sep separator to place between values. Defaults to a space. +!! line if present, the output is placed in the variable instead of +!! being written +!!##RETURNS +!! journal description to print +!!##EXAMPLES +!! +!! Sample program: +!! +!! program demo_journal +!! use M_CLI2, only : journal +!! implicit none +!! character(len=:),allocatable :: frmt +!! integer :: biggest +!! +!! call journal('HUGE(3f) integers',huge(0),'and real',& +!! & huge(0.0),'and double',huge(0.0d0)) +!! call journal('real :',huge(0.0),0.0,12345.6789,tiny(0.0) ) +!! call journal('doubleprecision :',huge(0.0d0),0.0d0,12345.6789d0,tiny(0.0d0) ) +!! call journal('complex :',cmplx(huge(0.0),tiny(0.0)) ) +!! +!! end program demo_journal +!! +!! Output +!! +!! HUGE(3f) integers 2147483647 and real 3.40282347E+38 and +!! double 1.7976931348623157E+308 +!! real : 3.40282347E+38 0.00000000 12345.6787 1.17549435E-38 +!! doubleprecision : 1.7976931348623157E+308 0.0000000000000000 +!! 12345.678900000001 2.2250738585072014E-308 +!! complex : (3.40282347E+38,1.17549435E-38) +!! format=(*(i9:,1x)) +!! program will now stop +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +subroutine journal(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj, sep,line) + +! ident_12="@(#) M_CLI2 journal(3fp) writes a message to stdout or a string composed of any standard scalar types" + +class(*),intent(in),optional :: g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj +character(len=*),intent(in),optional :: sep +character(len=:),intent(out),allocatable,optional :: line +character(len=:),allocatable :: sep_local +character(len=4096) :: local_line +integer :: istart +integer :: increment + if(present(sep))then + sep_local=sep + increment=len(sep_local)+1 + else + sep_local=' ' + increment=2 + endif + + istart=1 + local_line='' + if(present(g0))call print_generic(g0) + if(present(g1))call print_generic(g1) + if(present(g2))call print_generic(g2) + if(present(g3))call print_generic(g3) + if(present(g4))call print_generic(g4) + if(present(g5))call print_generic(g5) + if(present(g6))call print_generic(g6) + if(present(g7))call print_generic(g7) + if(present(g8))call print_generic(g8) + if(present(g9))call print_generic(g9) + if(present(ga))call print_generic(ga) + if(present(gb))call print_generic(gb) + if(present(gc))call print_generic(gc) + if(present(gd))call print_generic(gd) + if(present(ge))call print_generic(ge) + if(present(gf))call print_generic(gf) + if(present(gg))call print_generic(gg) + if(present(gh))call print_generic(gh) + if(present(gi))call print_generic(gi) + if(present(gj))call print_generic(gj) + if(present(line))then + line=trim(local_line) + else + write(*,'(a)')trim(local_line) + endif +contains +!=================================================================================================================================== +subroutine print_generic(generic) +use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 +class(*),intent(in) :: generic + select type(generic) + type is (integer(kind=int8)); write(local_line(istart:),'(i0)') generic + type is (integer(kind=int16)); write(local_line(istart:),'(i0)') generic + type is (integer(kind=int32)); write(local_line(istart:),'(i0)') generic + type is (integer(kind=int64)); write(local_line(istart:),'(i0)') generic + type is (real(kind=real32)); write(local_line(istart:),'(1pg0)') generic + type is (real(kind=real64)) + write(local_line(istart:),'(1pg0)') generic + !x! DOES NOT WORK WITH NVFORTRAN: type is (real(kind=real128)); write(local_line(istart:),'(1pg0)') generic + type is (logical) + write(local_line(istart:),'(l1)') generic + type is (character(len=*)) + write(local_line(istart:),'(a)') trim(generic) + type is (complex); write(local_line(istart:),'("(",1pg0,",",1pg0,")")') generic + end select + istart=len_trim(local_line)+increment + local_line=trim(local_line)//sep_local +end subroutine print_generic +!=================================================================================================================================== +end subroutine journal +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +function str(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj, sep) result(line) + +! ident_13="@(#) M_CLI2 str(3fp) writes a message to a string composed of any standard scalar types" + +class(*),intent(in),optional :: g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj +character(len=*),intent(in),optional :: sep +character(len=:),allocatable :: line +call journal(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj, sep,line) + +end function str +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +function upper(str) result (string) + +! ident_14="@(#) M_CLI2 upper(3f) Changes a string to uppercase" + +character(*), intent(in) :: str +character(:),allocatable :: string +integer :: i + string = str + do i = 1, len_trim(str) + select case (str(i:i)) + case ('a':'z') + string(i:i) = char(iachar(str(i:i))-32) + end select + end do +end function upper +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +function lower(str) result (string) + +! ident_15="@(#) M_CLI2 lower(3f) Changes a string to lowercase over specified range" + +character(*), intent(In) :: str +character(:),allocatable :: string +integer :: i + string = str + do i = 1, len_trim(str) + select case (str(i:i)) + case ('A':'Z') + string(i:i) = char(iachar(str(i:i))+32) + end select + end do +end function lower +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine a2i(chars,valu,ierr) + +! ident_16="@(#) M_CLI2 a2i(3fp) subroutine returns integer value from string" + +character(len=*),intent(in) :: chars ! input string +integer,intent(out) :: valu ! value read from input string +integer,intent(out) :: ierr ! error flag (0 == no error) +doubleprecision :: valu8 +integer,parameter :: ihuge=huge(0) + + valu8 = 0.0d0 + call a2d(chars, valu8, ierr, onerr=0.0d0) + + if (valu8 <= huge(valu)) then + + if (valu8 <= huge(valu)) then + valu = int(valu8) + else + call journal('*a2i*', '- value too large', valu8, '>', ihuge) + valu = huge(valu) + ierr = -1 + endif + + endif + +end subroutine a2i +!---------------------------------------------------------------------------------------------------------------------------------- +subroutine a2d(chars,valu,ierr,onerr) + +! ident_17="@(#) M_CLI2 a2d(3fp) subroutine returns double value from string" + +! 1989,2016 John S. Urban. +! +! o works with any g-format input, including integer, real, and exponential. +! o if an error occurs in the read, iostat is returned in ierr and value is set to zero. If no error occurs, ierr=0. +! o if the string happens to be 'eod' no error message is produced so this string may be used to act as an end-of-data. +! IERR will still be non-zero in this case. +!---------------------------------------------------------------------------------------------------------------------------------- +character(len=*),intent(in) :: chars ! input string +character(len=:),allocatable :: local_chars +doubleprecision,intent(out) :: valu ! value read from input string +integer,intent(out) :: ierr ! error flag (0 == no error) +class(*),optional,intent(in) :: onerr +!---------------------------------------------------------------------------------------------------------------------------------- +character(len=*),parameter :: fmt="('(bn,g',i5,'.0)')" ! format used to build frmt +character(len=15) :: frmt ! holds format built to read input string +character(len=256) :: msg ! hold message from I/O errors +integer :: intg +integer :: pnd +integer :: basevalue, ivalu +character(len=3),save :: nan_string='NaN' +!---------------------------------------------------------------------------------------------------------------------------------- + ierr=0 ! initialize error flag to zero + local_chars=unquote(chars) + msg='' + if(len(local_chars) == 0)local_chars=' ' + local_chars=replace_str(local_chars,',','') ! remove any comma characters + pnd=scan(local_chars,'#:') + if(pnd /= 0)then + write(frmt,fmt)pnd-1 ! build format of form '(BN,Gn.0)' + read(local_chars(:pnd-1),fmt=frmt,iostat=ierr,iomsg=msg)basevalue ! try to read value from string + if(decodebase(local_chars(pnd+1:),basevalue,ivalu))then + valu=real(ivalu,kind=kind(0.0d0)) + else + valu=0.0d0 + ierr=-1 + endif + else + select case(local_chars(1:1)) + case('z','Z','h','H') ! assume hexadecimal + write(frmt,"('(Z',i0,')')")len(local_chars) + read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg + valu=dble(intg) + case('b','B') ! assume binary (base 2) + write(frmt,"('(B',i0,')')")len(local_chars) + read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg + valu=dble(intg) + case('o','O') ! assume octal + write(frmt,"('(O',i0,')')")len(local_chars) + read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg + valu=dble(intg) + case default + write(frmt,fmt)len(local_chars) ! build format of form '(BN,Gn.0)' + read(local_chars,fmt=frmt,iostat=ierr,iomsg=msg)valu ! try to read value from string + end select + endif + if(ierr /= 0)then ! if an error occurred ierr will be non-zero. + if(present(onerr))then + select type(onerr) + type is (integer) + valu=onerr + type is (real) + valu=onerr + type is (doubleprecision) + valu=onerr + end select + else ! set return value to NaN + read(nan_string,'(f3.3)')valu + endif + if(local_chars /= 'eod')then ! print warning message except for special value "eod" + call journal('*a2d* - cannot produce number from string ['//trim(chars)//']') + if(msg /= '')then + call journal('*a2d* - ['//trim(msg)//']') + endif + endif + endif +end subroutine a2d +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! split(3f) - [M_CLI2:TOKENS] parse string into an array using specified +!! delimiters +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine split(input_line,array,delimiters,order,nulls) +!! +!! character(len=*),intent(in) :: input_line +!! character(len=:),allocatable,intent(out) :: array(:) +!! character(len=*),optional,intent(in) :: delimiters +!! character(len=*),optional,intent(in) :: order +!! character(len=*),optional,intent(in) :: nulls +!!##DESCRIPTION +!! SPLIT(3f) parses a string using specified delimiter characters and +!! store tokens into an allocatable array +!! +!!##OPTIONS +!! +!! INPUT_LINE Input string to tokenize +!! +!! ARRAY Output array of tokens +!! +!! DELIMITERS List of delimiter characters. +!! The default delimiters are the "whitespace" characters +!! (space, tab,new line, vertical tab, formfeed, carriage +!! return, and null). You may specify an alternate set of +!! delimiter characters. +!! +!! Multi-character delimiters are not supported (Each +!! character in the DELIMITERS list is considered to be +!! a delimiter). +!! +!! Quoting of delimiter characters is not supported. +!! +!! ORDER SEQUENTIAL|REVERSE|RIGHT Order of output array. +!! By default ARRAY contains the tokens having parsed +!! the INPUT_LINE from left to right. If ORDER='RIGHT' +!! or ORDER='REVERSE' the parsing goes from right to left. +!! +!! NULLS IGNORE|RETURN|IGNOREEND Treatment of null fields. +!! By default adjacent delimiters in the input string +!! do not create an empty string in the output array. if +!! NULLS='return' adjacent delimiters create an empty element +!! in the output ARRAY. If NULLS='ignoreend' then only +!! trailing delimiters at the right of the string are ignored. +!! +!!##EXAMPLES +!! +!! Sample program: +!! +!! program demo_split +!! use M_CLI2, only: split +!! character(len=*),parameter :: & +!! & line=' aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ' +!! character(len=:),allocatable :: array(:) ! output array of tokens +!! write(*,*)'INPUT LINE:['//LINE//']' +!! write(*,'(80("="))') +!! write(*,*)'typical call:' +!! CALL split(line,array) +!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) +!! write(*,*)'SIZE:',SIZE(array) +!! write(*,'(80("-"))') +!! write(*,*)'custom list of delimiters (colon and vertical line):' +!! CALL split(line,array,delimiters=':|',order='sequential',nulls='ignore') +!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) +!! write(*,*)'SIZE:',SIZE(array) +!! write(*,'(80("-"))') +!! write(*,*)& +!! &'custom list of delimiters, reverse array order and count null fields:' +!! CALL split(line,array,delimiters=':|',order='reverse',nulls='return') +!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) +!! write(*,*)'SIZE:',SIZE(array) +!! write(*,'(80("-"))') +!! write(*,*)'INPUT LINE:['//LINE//']' +!! write(*,*)& +!! &'default delimiters and reverse array order and return null fields:' +!! CALL split(line,array,delimiters='',order='reverse',nulls='return') +!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) +!! write(*,*)'SIZE:',SIZE(array) +!! end program demo_split +!! +!! Output +!! +!! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] +!! > =========================================================================== +!! > typical call: +!! > 1 ==> aBcdef +!! > 2 ==> ghijklmnop +!! > 3 ==> qrstuvwxyz +!! > 4 ==> 1:|:2 +!! > 5 ==> 333|333 +!! > 6 ==> a +!! > 7 ==> B +!! > 8 ==> cc +!! > SIZE: 8 +!! > -------------------------------------------------------------------------- +!! > custom list of delimiters (colon and vertical line): +!! > 1 ==> aBcdef ghijklmnop qrstuvwxyz 1 +!! > 2 ==> 2 333 +!! > 3 ==> 333 a B cc +!! > SIZE: 3 +!! > -------------------------------------------------------------------------- +!! > custom list of delimiters, reverse array order and return null fields: +!! > 1 ==> 333 a B cc +!! > 2 ==> 2 333 +!! > 3 ==> +!! > 4 ==> +!! > 5 ==> aBcdef ghijklmnop qrstuvwxyz 1 +!! > SIZE: 5 +!! > -------------------------------------------------------------------------- +!! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] +!! > default delimiters and reverse array order and count null fields: +!! > 1 ==> +!! > 2 ==> +!! > 3 ==> +!! > 4 ==> cc +!! > 5 ==> B +!! > 6 ==> a +!! > 7 ==> 333|333 +!! > 8 ==> +!! > 9 ==> +!! > 10 ==> +!! > 11 ==> +!! > 12 ==> 1:|:2 +!! > 13 ==> +!! > 14 ==> qrstuvwxyz +!! > 15 ==> ghijklmnop +!! > 16 ==> +!! > 17 ==> +!! > 18 ==> aBcdef +!! > 19 ==> +!! > 20 ==> +!! > SIZE: 20 +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +subroutine split(input_line,array,delimiters,order,nulls) + +! ident_18="@(#) M_CLI2 split(3f) parse string on delimiter characters and store tokens into an allocatable array" + +! John S. Urban +intrinsic index, min, present, len +! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. +! o by default adjacent delimiters in the input string do not create an empty string in the output array +! o no quoting of delimiters is supported +character(len=*),intent(in) :: input_line ! input string to tokenize +character(len=*),optional,intent(in) :: delimiters ! list of delimiter characters +character(len=*),optional,intent(in) :: order ! order of output array sequential|[reverse|right] +character(len=*),optional,intent(in) :: nulls ! return strings composed of delimiters or not ignore|return|ignoreend +character(len=:),allocatable,intent(out) :: array(:) ! output array of tokens +!----------------------------------------------------------------------------------------------------------------------------------- +integer :: n ! max number of strings INPUT_LINE could split into if all delimiter +integer,allocatable :: ibegin(:) ! positions in input string where tokens start +integer,allocatable :: iterm(:) ! positions in input string where tokens end +character(len=:),allocatable :: dlim ! string containing delimiter characters +character(len=:),allocatable :: ordr ! string containing order keyword +character(len=:),allocatable :: nlls ! string containing nulls keyword +integer :: ii,iiii ! loop parameters used to control print order +integer :: icount ! number of tokens found +integer :: iilen ! length of input string with trailing spaces trimmed +integer :: i10,i20,i30 ! loop counters +integer :: icol ! pointer into input string as it is being parsed +integer :: idlim ! number of delimiter characters +integer :: ifound ! where next delimiter character is found in remaining input string data +integer :: inotnull ! count strings not composed of delimiters +integer :: ireturn ! number of tokens returned +integer :: imax ! length of longest token +!----------------------------------------------------------------------------------------------------------------------------------- + ! decide on value for optional DELIMITERS parameter + if (present(delimiters)) then ! optional delimiter list was present + if(delimiters /= '')then ! if DELIMITERS was specified and not null use it + dlim=delimiters + else ! DELIMITERS was specified on call as empty string + dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0)//',:' ! use default delimiter when not specified + endif + else ! no delimiter value was specified + dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0)//',:' ! use default delimiter when not specified + endif + idlim=len(dlim) ! dlim a lot of blanks on some machines if dlim is a big string +!----------------------------------------------------------------------------------------------------------------------------------- + if(present(order))then; ordr=lower(adjustl(order)); else; ordr='sequential'; endif ! decide on value for optional ORDER parameter + if(present(nulls))then; nlls=lower(adjustl(nulls)); else; nlls='ignore' ; endif ! optional parameter +!----------------------------------------------------------------------------------------------------------------------------------- + n=len(input_line)+1 ! max number of strings INPUT_LINE could split into if all delimiter + if(allocated(ibegin))deallocate(ibegin) !x! intel compiler says allocated already ??? + allocate(ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens + if(allocated(iterm))deallocate(iterm) !x! intel compiler says allocated already ??? + allocate(iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens + ibegin(:)=1 + iterm(:)=1 +!----------------------------------------------------------------------------------------------------------------------------------- + iilen=len(input_line) ! IILEN is the column position of the last non-blank character + icount=0 ! how many tokens found + inotnull=0 ! how many tokens found not composed of delimiters + imax=0 ! length of longest token found + if(iilen > 0)then ! there is at least one non-delimiter in INPUT_LINE if get here + icol=1 ! initialize pointer into input line + INFINITE: do i30=1,iilen,1 ! store into each array element + ibegin(i30)=icol ! assume start new token on the character + if(index(dlim(1:idlim),input_line(icol:icol)) == 0)then ! if current character is not a delimiter + iterm(i30)=iilen ! initially assume no more tokens + do i10=1,idlim ! search for next delimiter + ifound=index(input_line(ibegin(i30):iilen),dlim(i10:i10)) + IF(ifound > 0)then + iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2) + endif + enddo + icol=iterm(i30)+2 ! next place to look as found end of this token + inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters + else ! character is a delimiter for a null string + iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning + icol=icol+1 ! advance pointer into input string + endif + imax=max(imax,iterm(i30)-ibegin(i30)+1) + icount=i30 ! increment count of number of tokens found + if(icol > iilen)then ! no text left + exit INFINITE + endif + enddo INFINITE + endif +!----------------------------------------------------------------------------------------------------------------------------------- + select case (clipends(nlls)) + case ('ignore','','ignoreend') + ireturn=inotnull + case default + ireturn=icount + end select + if(allocated(array))deallocate(array) + allocate(character(len=imax) :: array(ireturn)) ! allocate the array to return + !allocate(array(ireturn)) ! allocate the array to turn +!----------------------------------------------------------------------------------------------------------------------------------- + select case (clipends(ordr)) ! decide which order to store tokens + case ('reverse','right') ; ii=ireturn ; iiii=-1 ! last to first + case default ; ii=1 ; iiii=1 ! first to last + end select +!----------------------------------------------------------------------------------------------------------------------------------- + do i20=1,icount ! fill the array with the tokens that were found + if(iterm(i20) < ibegin(i20))then + select case (clipends(nlls)) + case ('ignore','','ignoreend') + case default + array(ii)=' ' + ii=ii+iiii + end select + else + array(ii)=input_line(ibegin(i20):iterm(i20)) + ii=ii+iiii + endif + enddo +!----------------------------------------------------------------------------------------------------------------------------------- +end subroutine split +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! replace_str(3f) - [M_CLI2:EDITING] function globally replaces one +!! substring for another in string +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! function replace_str(targetline,old,new,range,ierr) result (newline) +!! +!! character(len=*) :: targetline +!! character(len=*),intent(in) :: old +!! character(len=*),intent(in) :: new +!! integer,intent(in),optional :: range(2) +!! integer,intent(out),optional :: ierr +!! logical,intent(in),optional :: clip +!! character(len=:),allocatable :: newline +!!##DESCRIPTION +!! Globally replace one substring for another in string. +!! Either CMD or OLD and NEW must be specified. +!! +!!##OPTIONS +!! targetline input line to be changed +!! old old substring to replace +!! new new substring +!! range if present, only change range(1) to range(2) of +!! occurrences of old string +!! ierr error code. If ier = -1 bad directive, >= 0 then +!! count of changes made +!! clip whether to return trailing spaces or not. Defaults to .false. +!!##RETURNS +!! newline allocatable string returned +!! +!!##EXAMPLES +!! +!! Sample Program: +!! +!! program demo_replace_str +!! use M_CLI2, only : replace_str +!! implicit none +!! character(len=:),allocatable :: targetline +!! +!! targetline='this is the input string' +!! +!! call testit('th','TH','THis is THe input string') +!! +!! ! a null old substring means "at beginning of line" +!! call testit('','BEFORE:', 'BEFORE:THis is THe input string') +!! +!! ! a null new string deletes occurrences of the old substring +!! call testit('i','', 'BEFORE:THs s THe nput strng') +!! +!! targetline=replace_str('a b ab baaa aaaa','a','A') +!! write(*,*)'replace a with A ['//targetline//']' +!! +!! write(*,*)'Examples of the use of RANGE=' +!! +!! targetline=replace_str('a b ab baaa aaaa','a','A',range=[3,5]) +!! write(*,*)'replace a with A instances 3 to 5 ['//targetline//']' +!! +!! targetline=replace_str('a b ab baaa aaaa','a','',range=[3,5]) +!! write(*,*)'replace a with null instances 3 to 5 ['//targetline//']' +!! +!! targetline=replace_str('a b ab baaa aaaa aa aa a a a aa aaaaaa',& +!! & 'aa','CCCC',range=[3,5]) +!! write(*,*)'replace aa with CCCC instances 3 to 5 ['//targetline//']' +!! +!! contains +!! subroutine testit(old,new,expected) +!! character(len=*),intent(in) :: old,new,expected +!! write(*,*)repeat('=',79) +!! write(*,*)':STARTED ['//targetline//']' +!! write(*,*)':OLD['//old//']', ' NEW['//new//']' +!! targetline=replace_str(targetline,old,new) +!! write(*,*)':GOT ['//targetline//']' +!! write(*,*)':EXPECTED['//expected//']' +!! write(*,*)':TEST [',targetline == expected,']' +!! end subroutine testit +!! +!! end program demo_replace_str +!! +!! Expected output +!! +!! =============================================================================== +!! STARTED [this is the input string] +!! OLD[th] NEW[TH] +!! GOT [THis is THe input string] +!! EXPECTED[THis is THe input string] +!! TEST [ T ] +!! =============================================================================== +!! STARTED [THis is THe input string] +!! OLD[] NEW[BEFORE:] +!! GOT [BEFORE:THis is THe input string] +!! EXPECTED[BEFORE:THis is THe input string] +!! TEST [ T ] +!! =============================================================================== +!! STARTED [BEFORE:THis is THe input string] +!! OLD[i] NEW[] +!! GOT [BEFORE:THs s THe nput strng] +!! EXPECTED[BEFORE:THs s THe nput strng] +!! TEST [ T ] +!! replace a with A [A b Ab bAAA AAAA] +!! Examples of the use of RANGE= +!! replace a with A instances 3 to 5 [a b ab bAAA aaaa] +!! replace a with null instances 3 to 5 [a b ab b aaaa] +!! replace aa with CCCC instances 3 to 5 [a b ab baaa aaCCCC CCCC CCCC +!! a a a aa aaaaaa] +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +function replace_str(targetline,old,new,ierr,range) result (newline) + +! ident_19="@(#) M_CLI2 replace_str(3f) Globally replace one substring for another in string" + +!----------------------------------------------------------------------------------------------------------------------------------- +! parameters +character(len=*),intent(in) :: targetline ! input line to be changed +character(len=*),intent(in) :: old ! old substring to replace +character(len=*),intent(in) :: new ! new substring +integer,intent(out),optional :: ierr ! error code. If ierr = -1 bad directive, >=0 then ierr changes made +integer,intent(in),optional :: range(2) ! start and end of which changes to make +!----------------------------------------------------------------------------------------------------------------------------------- +! returns +character(len=:),allocatable :: newline ! output string buffer +!----------------------------------------------------------------------------------------------------------------------------------- +! local +integer :: icount,ichange +integer :: original_input_length +integer :: len_old, len_new +integer :: ladd +integer :: left_margin, right_margin +integer :: ind +integer :: ic +integer :: iichar +integer :: range_local(2) +!----------------------------------------------------------------------------------------------------------------------------------- + icount=0 ! initialize error flag/change count + ichange=0 ! initialize error flag/change count + original_input_length=len_trim(targetline) ! get non-blank length of input line + len_old=len(old) ! length of old substring to be replaced + len_new=len(new) ! length of new substring to replace old substring + left_margin=1 ! left_margin is left margin of window to change + right_margin=len(targetline) ! right_margin is right margin of window to change + newline='' ! begin with a blank line as output string +!----------------------------------------------------------------------------------------------------------------------------------- + if(present(range))then + range_local=range + else + range_local=[1,original_input_length] + endif +!----------------------------------------------------------------------------------------------------------------------------------- + if(len_old == 0)then ! c//new/ means insert new at beginning of line (or left margin) + iichar=len_new + original_input_length + if(len_new > 0)then + newline=new(:len_new)//targetline(left_margin:original_input_length) + else + newline=targetline(left_margin:original_input_length) + endif + ichange=1 ! made one change. actually, c/// should maybe return 0 + if(present(ierr))ierr=ichange + return + endif +!----------------------------------------------------------------------------------------------------------------------------------- + iichar=left_margin ! place to put characters into output string + ic=left_margin ! place looking at in input string + loop: do + ind=index(targetline(ic:),old(:len_old))+ic-1 ! try finding start of OLD in remaining part of input in change window + if(ind == ic-1.or.ind > right_margin)then ! did not find old string or found old string past edit window + exit loop ! no more changes left to make + endif + icount=icount+1 ! found an old string to change, so increment count of change candidates + if(ind > ic)then ! if found old string past at current position in input string copy unchanged + ladd=ind-ic ! find length of character range to copy as-is from input to output + newline=newline(:iichar-1)//targetline(ic:ind-1) + iichar=iichar+ladd + endif + if(icount >= range_local(1).and.icount <= range_local(2))then ! check if this is an instance to change or keep + ichange=ichange+1 + if(len_new /= 0)then ! put in new string + newline=newline(:iichar-1)//new(:len_new) + iichar=iichar+len_new + endif + else + if(len_old /= 0)then ! put in copy of old string + newline=newline(:iichar-1)//old(:len_old) + iichar=iichar+len_old + endif + endif + ic=ind+len_old + enddo loop +!----------------------------------------------------------------------------------------------------------------------------------- + select case (ichange) + case (0) ! there were no changes made to the window + newline=targetline ! if no changes made output should be input + case default + if(ic <= len(targetline))then ! if there is more after last change on original line add it + newline=newline(:iichar-1)//targetline(ic:max(ic,original_input_length)) + endif + end select + if(present(ierr))ierr=ichange +!----------------------------------------------------------------------------------------------------------------------------------- +end function replace_str +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! quote(3f) - [M_CLI2:QUOTES] add quotes to string as if written with +!! list-directed input +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! function quote(str,mode,clip) result (quoted_str) +!! +!! character(len=*),intent(in) :: str +!! character(len=*),optional,intent(in) :: mode +!! logical,optional,intent(in) :: clip +!! character(len=:),allocatable :: quoted_str +!!##DESCRIPTION +!! Add quotes to a CHARACTER variable as if it was written using +!! list-directed input. This is particularly useful for processing +!! strings to add to CSV files. +!! +!!##OPTIONS +!! str input string to add quotes to, using the rules of +!! list-directed input (single quotes are replaced by two +!! adjacent quotes) +!! mode alternate quoting methods are supported: +!! +!! DOUBLE default. replace quote with double quotes +!! ESCAPE replace quotes with backslash-quote instead +!! of double quotes +!! +!! clip default is to trim leading and trailing spaces from the +!! string. If CLIP +!! is .FALSE. spaces are not trimmed +!! +!!##RESULT +!! quoted_str The output string, which is based on adding quotes to STR. +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_quote +!! use M_CLI2, only : quote +!! implicit none +!! character(len=:),allocatable :: str +!! character(len=1024) :: msg +!! integer :: ios +!! character(len=80) :: inline +!! do +!! write(*,'(a)',advance='no')'Enter test string:' +!! read(*,'(a)',iostat=ios,iomsg=msg)inline +!! if(ios /= 0)then +!! write(*,*)trim(inline) +!! exit +!! endif +!! +!! ! the original string +!! write(*,'(a)')'ORIGINAL ['//trim(inline)//']' +!! +!! ! the string processed by quote(3f) +!! str=quote(inline) +!! write(*,'(a)')'QUOTED ['//str//']' +!! +!! ! write the string list-directed to compare the results +!! write(*,'(a)',iostat=ios,iomsg=msg) 'LIST DIRECTED:' +!! write(*,*,iostat=ios,iomsg=msg,delim='none') inline +!! write(*,*,iostat=ios,iomsg=msg,delim='quote') inline +!! write(*,*,iostat=ios,iomsg=msg,delim='apostrophe') inline +!! enddo +!! end program demo_quote +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +!----------------------------------------------------------------------------------------------------------------------------------- +function quote(str,mode,clip) result (quoted_str) +character(len=*),intent(in) :: str ! the string to be quoted +character(len=*),optional,intent(in) :: mode +logical,optional,intent(in) :: clip +logical :: clip_local +character(len=:),allocatable :: quoted_str + +character(len=1),parameter :: double_quote = '"' +character(len=20) :: local_mode + + if(present(mode))then + local_mode=mode + else + local_mode='DOUBLE' + endif + + if(present(clip))then + clip_local=clip + else + clip_local=.false. + endif + + if(clip_local)then + quoted_str=adjustl(str) + else + quoted_str=str + endif + + select case(lower(local_mode)) + case('double') + quoted_str=double_quote//trim(replace_str(quoted_str,'"','""'))//double_quote + case('escape') + quoted_str=double_quote//trim(replace_str(quoted_str,'"','\"'))//double_quote + case default + call journal('*quote* ERROR: unknown quote mode ',local_mode) + quoted_str=str + end select + +end function quote +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! unquote(3f) - [M_CLI2:QUOTES] remove quotes from string as if read +!! with list-directed input +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! pure function unquote(quoted_str,esc) result (unquoted_str) +!! +!! character(len=*),intent(in) :: quoted_str +!! character(len=1),optional,intent(in) :: esc +!! character(len=:),allocatable :: unquoted_str +!!##DESCRIPTION +!! Remove quotes from a CHARACTER variable as if it was read using +!! list-directed input. This is particularly useful for processing +!! tokens read from input such as CSV files. +!! +!! Fortran can now read using list-directed input from an internal file, +!! which should handle quoted strings, but list-directed input does not +!! support escape characters, which UNQUOTE(3f) does. +!!##OPTIONS +!! quoted_str input string to remove quotes from, using the rules of +!! list-directed input (two adjacent quotes inside a quoted +!! region are replaced by a single quote, a single quote or +!! double quote is selected as the delimiter based on which +!! is encountered first going from left to right, ...) +!! esc optional character used to protect the next quote +!! character from being processed as a quote, but simply as +!! a plain character. +!!##RESULT +!! unquoted_str The output string, which is based on removing quotes +!! from quoted_str. +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_unquote +!! use M_CLI2, only : unquote +!! implicit none +!! character(len=128) :: quoted_str +!! character(len=:),allocatable :: unquoted_str +!! character(len=1),parameter :: esc='\' +!! character(len=1024) :: msg +!! integer :: ios +!! character(len=1024) :: dummy +!! do +!! write(*,'(a)',advance='no')'Enter test string:' +!! read(*,'(a)',iostat=ios,iomsg=msg)quoted_str +!! if(ios /= 0)then +!! write(*,*)trim(msg) +!! exit +!! endif +!! +!! ! the original string +!! write(*,'(a)')'QUOTED ['//trim(quoted_str)//']' +!! +!! ! the string processed by unquote(3f) +!! unquoted_str=unquote(trim(quoted_str),esc) +!! write(*,'(a)')'UNQUOTED ['//unquoted_str//']' +!! +!! ! read the string list-directed to compare the results +!! read(quoted_str,*,iostat=ios,iomsg=msg)dummy +!! if(ios /= 0)then +!! write(*,*)trim(msg) +!! else +!! write(*,'(a)')'LIST DIRECTED['//trim(dummy)//']' +!! endif +!! enddo +!! end program demo_unquote +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +pure function unquote(quoted_str,esc) result (unquoted_str) +character(len=*),intent(in) :: quoted_str ! the string to be unquoted +character(len=1),optional,intent(in) :: esc ! escape character +character(len=:),allocatable :: unquoted_str +integer :: inlen +character(len=1),parameter :: single_quote = "'" +character(len=1),parameter :: double_quote = '"' +integer :: quote ! whichever quote is to be used +integer :: before +integer :: current +integer :: iesc +integer :: iput +integer :: i +logical :: inside +!----------------------------------------------------------------------------------------------------------------------------------- + if(present(esc))then ! select escape character as specified character or special value meaning not set + iesc=ichar(esc) ! allow for an escape character + else + iesc=-1 ! set to value that matches no character + endif +!----------------------------------------------------------------------------------------------------------------------------------- + inlen=len(quoted_str) ! find length of input string + if(allocated(unquoted_str))deallocate(unquoted_str) + allocate(character(len=inlen) :: unquoted_str) ! initially make output string length of input string +!----------------------------------------------------------------------------------------------------------------------------------- + if(inlen >= 1)then ! double_quote is the default quote unless the first character is single_quote + if(quoted_str(1:1) == single_quote)then + quote=ichar(single_quote) + else + quote=ichar(double_quote) + endif + else + quote=ichar(double_quote) + endif +!----------------------------------------------------------------------------------------------------------------------------------- + before=-2 ! initially set previous character to impossible value + unquoted_str(:)='' ! initialize output string to null string + iput=1 + inside=.false. + STEPTHROUGH: do i=1,inlen + current=ichar(quoted_str(i:i)) + if(before == iesc)then ! if previous character was escape use current character unconditionally + iput=iput-1 ! backup + unquoted_str(iput:iput)=char(current) + iput=iput+1 + before=-2 ! this could be second esc or quote + elseif(current == quote)then ! if current is a quote it depends on whether previous character was a quote + if(before == quote)then + unquoted_str(iput:iput)=char(quote) ! this is second quote so retain it + iput=iput+1 + before=-2 + elseif(.not.inside.and.before /= iesc)then + inside=.true. + else ! this is first quote so ignore it except remember it in case next is a quote + before=current + endif + else + unquoted_str(iput:iput)=char(current) + iput=iput+1 + before=current + endif + enddo STEPTHROUGH +!----------------------------------------------------------------------------------------------------------------------------------- + unquoted_str=unquoted_str(:iput-1) +!----------------------------------------------------------------------------------------------------------------------------------- +end function unquote +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! +!! decodebase(3f) - [M_CLI2:BASE] convert whole number string in base +!! [2-36] to base 10 number +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! logical function decodebase(string,basein,out10) +!! +!! character(len=*),intent(in) :: string +!! integer,intent(in) :: basein +!! integer,intent(out) :: out10 +!!##DESCRIPTION +!! +!! Convert a numeric string representing a whole number in base BASEIN +!! to base 10. The function returns FALSE if BASEIN is not in the range +!! [2..36] or if string STRING contains invalid characters in base BASEIN +!! or if result OUT10 is too big +!! +!! The letters A,B,...,Z represent 10,11,...,36 in the base > 10. +!! +!!##OPTIONS +!! string input string. It represents a whole number in +!! the base specified by BASEIN unless BASEIN is set +!! to zero. When BASEIN is zero STRING is assumed to +!! be of the form BASE#VALUE where BASE represents +!! the function normally provided by BASEIN. +!! basein base of input string; either 0 or from 2 to 36. +!! out10 output value in base 10 +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_decodebase +!! use M_CLI2, only : codebase, decodebase +!! implicit none +!! integer :: ba,bd +!! character(len=40) :: x,y +!! integer :: r +!! +!! print *,' BASE CONVERSION' +!! write(*,'("Start Base (2 to 36): ")',advance='no'); read *, bd +!! write(*,'("Arrival Base (2 to 36): ")',advance='no'); read *, ba +!! INFINITE: do +!! print *,'' +!! write(*,'("Enter number in start base: ")',advance='no'); read *, x +!! if(x == '0') exit INFINITE +!! if(decodebase(x,bd,r)) then +!! if(codebase(r,ba,y)) then +!! write(*,'("In base ",I2,": ",A20)') ba, y +!! else +!! print *,'Error in coding number.' +!! endif +!! else +!! print *,'Error in decoding number.' +!! endif +!! enddo INFINITE +!! +!! end program demo_decodebase +!! +!!##AUTHOR +!! John S. Urban +!! +!! Ref.: "Math matiques en Turbo-Pascal by +!! M. Ducamp and A. Reverchon (2), +!! Eyrolles, Paris, 1988". +!! +!! based on a F90 Version By J-P Moreau (www.jpmoreau.fr) +!! +!!##LICENSE +!! Public Domain +logical function decodebase(string,basein,out_baseten) + +! ident_20="@(#) M_CLI2 decodebase(3f) convert whole number string in base [2-36] to base 10 number" + +character(len=*),intent(in) :: string +integer,intent(in) :: basein +integer,intent(out) :: out_baseten + +character(len=len(string)) :: string_local +integer :: long, i, j, k +real :: y +real :: mult +character(len=1) :: ch +real,parameter :: XMAXREAL=real(huge(1)) +integer :: out_sign +integer :: basein_local +integer :: ipound +integer :: ierr + + string_local=upper(clipends(string)) + decodebase=.false. + + ipound=index(string_local,'#') ! determine if in form [-]base#whole + if(basein == 0.and.ipound > 1)then ! split string into two values + call a2i(string_local(:ipound-1),basein_local,ierr) ! get the decimal value of the base + string_local=string_local(ipound+1:) ! now that base is known make string just the value + if(basein_local >= 0)then ! allow for a negative sign prefix + out_sign=1 + else + out_sign=-1 + endif + basein_local=abs(basein_local) + else ! assume string is a simple positive value + basein_local=abs(basein) + out_sign=1 + endif + + out_baseten=0 + y=0.0 + ALL: if(basein_local<2.or.basein_local>36) then + print *,'(*decodebase* ERROR: Base must be between 2 and 36. base=',basein_local + else ALL + out_baseten=0;y=0.0; mult=1.0 + long=LEN_TRIM(string_local) + do i=1, long + k=long+1-i + ch=string_local(k:k) + IF(CH == '-'.AND.K == 1)THEN + out_sign=-1 + cycle + endif + if(ch<'0'.or.ch>'Z'.or.(ch>'9'.and.ch<'A'))then + write(*,*)'*decodebase* ERROR: invalid character ',ch + exit ALL + endif + if(ch<='9') then + j=IACHAR(ch)-IACHAR('0') + else + j=IACHAR(ch)-IACHAR('A')+10 + endif + if(j>=basein_local)then + exit ALL + endif + y=y+mult*j + if(mult>XMAXREAL/basein_local)then + exit ALL + endif + mult=mult*basein_local + enddo + decodebase=.true. + out_baseten=nint(out_sign*y)*sign(1,basein) + endif ALL +end function decodebase +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! locate_(3f) - [M_CLI2] finds the index where a string is found or +!! should be in a sorted array +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine locate_(list,value,place,ier,errmsg) +!! +!! character(len=:)|doubleprecision|real|integer,allocatable :: list(:) +!! character(len=*)|doubleprecision|real|integer,intent(in) :: value +!! integer, intent(out) :: PLACE +!! +!! integer, intent(out),optional :: IER +!! character(len=*),intent(out),optional :: ERRMSG +!! +!!##DESCRIPTION +!! +!! LOCATE_(3f) finds the index where the VALUE is found or should +!! be found in an array. The array must be sorted in descending +!! order (highest at top). If VALUE is not found it returns the index +!! where the name should be placed at with a negative sign. +!! +!! The array and list must be of the same type (CHARACTER, DOUBLEPRECISION, +!! REAL,INTEGER) +!! +!!##OPTIONS +!! +!! VALUE the value to locate in the list. +!! LIST is the list array. +!! +!!##RETURNS +!! PLACE is the subscript that the entry was found at if it is +!! greater than zero(0). +!! +!! If PLACE is negative, the absolute value of +!! PLACE indicates the subscript value where the +!! new entry should be placed in order to keep the +!! list alphabetized. +!! +!! IER is zero(0) if no error occurs. +!! If an error occurs and IER is not +!! present, the program is stopped. +!! +!! ERRMSG description of any error +!! +!!##EXAMPLES +!! +!! +!! Find if a string is in a sorted array, and insert the string into +!! the list if it is not present ... +!! +!! program demo_locate +!! use M_sort, only : sort_shell +!! use M_CLI2, only : locate_ +!! implicit none +!! character(len=:),allocatable :: arr(:) +!! integer :: i +!! +!! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] +!! ! make sure sorted in descending order +!! call sort_shell(arr,order='d') +!! +!! call update_dic(arr,'b') +!! call update_dic(arr,'[') +!! call update_dic(arr,'c') +!! call update_dic(arr,'ZZ') +!! call update_dic(arr,'ZZZZ') +!! call update_dic(arr,'z') +!! +!! contains +!! subroutine update_dic(arr,string) +!! character(len=:),intent(in),allocatable :: arr(:) +!! character(len=*),intent(in) :: string +!! integer :: place, plus, ii, end +!! ! find where string is or should be +!! call locate_(arr,string,place) +!! write(*,*)'for "'//string//'" index is ',place, size(arr) +!! ! if string was not found insert it +!! if(place < 1)then +!! plus=abs(place) +!! ii=len(arr) +!! end=size(arr) +!! ! empty array +!! if(end == 0)then +!! arr=[character(len=ii) :: string ] +!! ! put in front of array +!! elseif(plus == 1)then +!! arr=[character(len=ii) :: string, arr] +!! ! put at end of array +!! elseif(plus == end)then +!! arr=[character(len=ii) :: arr, string ] +!! ! put in middle of array +!! else +!! arr=[character(len=ii) :: arr(:plus-1), string,arr(plus:) ] +!! endif +!! ! show array +!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) +!! endif +!! end subroutine update_dic +!! end program demo_locate +!! +!! Results: +!! +!! for "b" index is 2 5 +!! for "[" index is -4 5 +!! SIZE=5 xxx,b,aaa,[,ZZZ, +!! for "c" index is -2 6 +!! SIZE=6 xxx,c,b,aaa,[,ZZZ, +!! for "ZZ" index is -7 7 +!! SIZE=7 xxx,c,b,aaa,[,ZZZ,, +!! for "ZZZZ" index is -6 8 +!! SIZE=8 xxx,c,b,aaa,[,ZZZZ,ZZZ,, +!! for "z" index is -1 9 +!! SIZE=9 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,, +!! +!!##AUTHOR +!! 1989,2017 John S. Urban +!!##LICENSE +!! Public Domain +subroutine locate_c(list,value,place,ier,errmsg) + +! ident_21="@(#) M_CLI2 locate_c(3f) find PLACE in sorted character array LIST where VALUE can be found or should be placed" + +character(len=*),intent(in) :: value +integer,intent(out) :: place +character(len=:),allocatable :: list(:) +integer,intent(out),optional :: ier +character(len=*),intent(out),optional :: errmsg +integer :: i +character(len=:),allocatable :: message +integer :: arraysize +integer :: maxtry +integer :: imin, imax +integer :: error + if(.not.allocated(list))then + list=[character(len=max(len_trim(value),2)) :: ] + endif + arraysize=size(list) + + error=0 + if(arraysize == 0)then + maxtry=0 + place=-1 + else + maxtry=nint(log(float(arraysize))/log(2.0)+1.0) + place=(arraysize+1)/2 + endif + imin=1 + imax=arraysize + message='' + + LOOP: block + do i=1,maxtry + + if(value == list(PLACE))then + exit LOOP + elseif(value > list(place))then + imax=place-1 + else + imin=place+1 + endif + + if(imin > imax)then + place=-imin + if(iabs(place) > arraysize)then ! ran off end of list. Where new value should go or an unsorted input array' + exit LOOP + endif + exit LOOP + endif + + place=(imax+imin)/2 + + if(place > arraysize.or.place <= 0)then + message='*locate_* error: search is out of bounds of list. Probably an unsorted input array' + error=-1 + exit LOOP + endif + + enddo + message='*locate_* exceeded allowed tries. Probably an unsorted input array' + endblock LOOP + if(present(ier))then + ier=error + elseif(error /= 0)then + write(warn,*)message//' VALUE=',trim(value)//' PLACE=',place + call mystop(-24,'(*locate_c* '//message) + endif + if(present(errmsg))then + errmsg=message + endif +end subroutine locate_c +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! remove_(3f) - [M_CLI2] remove entry from an allocatable array at specified position +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine remove_(list,place) +!! +!! character(len=:)|doubleprecision|real|integer,intent(inout) :: list(:) +!! integer, intent(out) :: PLACE +!! +!!##DESCRIPTION +!! +!! Remove a value from an allocatable array at the specified index. +!! The array is assumed to be sorted in descending order. It may be of +!! type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER. +!! +!!##OPTIONS +!! +!! list is the list array. +!! PLACE is the subscript for the entry that should be removed +!! +!!##EXAMPLES +!! +!! +!! Sample program +!! +!! program demo_remove +!! use M_sort, only : sort_shell +!! use M_CLI2, only : locate_, remove_ +!! implicit none +!! character(len=:),allocatable :: arr(:) +!! integer :: i +!! integer :: end +!! +!! arr=[character(len=20) :: '', 'ZZZ', 'Z', 'aaa', 'b', 'b', 'ab', 'bb', 'xxx' ] +!! ! make sure sorted in descending order +!! call sort_shell(arr,order='d') +!! +!! end=size(arr) +!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) +!! call remove_(arr,1) +!! end=size(arr) +!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) +!! call remove_(arr,4) +!! end=size(arr) +!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) +!! +!! end program demo_remove +!! +!! Results: +!! +!! Expected output +!! +!! SIZE=9 xxx,bb,b,b,ab,aaa,ZZZ,Z,, +!! SIZE=8 bb,b,b,ab,aaa,ZZZ,Z,, +!! SIZE=7 bb,b,b,aaa,ZZZ,Z,, +!! +!!##AUTHOR +!! 1989,2017 John S. Urban +!!##LICENSE +!! Public Domain +subroutine remove_c(list,place) + +! ident_22="@(#) M_CLI2 remove_c(3fp) remove string from allocatable string array at specified position" + +character(len=:),allocatable :: list(:) +integer,intent(in) :: place +integer :: ii, end + if(.not.allocated(list))then + list=[character(len=2) :: ] + endif + ii=len(list) + end=size(list) + if(place <= 0.or.place > end)then ! index out of bounds of array + elseif(place == end)then ! remove from array + list=[character(len=ii) :: list(:place-1) ] + else + list=[character(len=ii) :: list(:place-1), list(place+1:) ] + endif +end subroutine remove_c +subroutine remove_l(list,place) + +! ident_23="@(#) M_CLI2 remove_l(3fp) remove value from allocatable array at specified position" + +logical,allocatable :: list(:) +integer,intent(in) :: place +integer :: end + + if(.not.allocated(list))then + list=[logical :: ] + endif + end=size(list) + if(place <= 0.or.place > end)then ! index out of bounds of array + elseif(place == end)then ! remove from array + list=[ list(:place-1)] + else + list=[ list(:place-1), list(place+1:) ] + endif + +end subroutine remove_l +subroutine remove_i(list,place) + +! ident_24="@(#) M_CLI2 remove_i(3fp) remove value from allocatable array at specified position" +integer,allocatable :: list(:) +integer,intent(in) :: place +integer :: end + + if(.not.allocated(list))then + list=[integer :: ] + endif + end=size(list) + if(place <= 0.or.place > end)then ! index out of bounds of array + elseif(place == end)then ! remove from array + list=[ list(:place-1)] + else + list=[ list(:place-1), list(place+1:) ] + endif + +end subroutine remove_i +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! replace_(3f) - [M_CLI2] replace entry in a string array at specified position +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine replace_(list,value,place) +!! +!! character(len=*)|doubleprecision|real|integer,intent(in) :: value +!! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) +!! integer, intent(out) :: place +!! +!!##DESCRIPTION +!! +!! replace a value in an allocatable array at the specified index. Unless the +!! array needs the string length to increase this is merely an assign of a value +!! to an array element. +!! +!! The array may be of type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER> +!! It is assumed to be sorted in descending order without duplicate values. +!! +!! The value and list must be of the same type. +!! +!!##OPTIONS +!! +!! VALUE the value to place in the array +!! LIST is the array. +!! PLACE is the subscript that the entry should be placed at +!! +!!##EXAMPLES +!! +!! +!! Replace key-value pairs in a dictionary +!! +!! program demo_replace +!! use M_CLI2, only : insert_, locate_, replace_ +!! ! Find if a key is in a list and insert it +!! ! into the key list and value list if it is not present +!! ! or replace the associated value if the key existed +!! implicit none +!! character(len=20) :: key +!! character(len=100) :: val +!! character(len=:),allocatable :: keywords(:) +!! character(len=:),allocatable :: values(:) +!! integer :: i +!! integer :: place +!! call update_dic('b','value of b') +!! call update_dic('a','value of a') +!! call update_dic('c','value of c') +!! call update_dic('c','value of c again') +!! call update_dic('d','value of d') +!! call update_dic('a','value of a again') +!! ! show array +!! write(*,'(*(a,"==>",a,/))')(trim(keywords(i)),trim(values(i)),i=1,size(keywords)) +!! +!! call locate_key('a',place) +!! if(place > 0)then +!! write(*,*)'The value of "a" is',trim(values(place)) +!! else +!! write(*,*)'"a" not found' +!! endif +!! +!! contains +!! subroutine update_dic(key,val) +!! character(len=*),intent(in) :: key +!! character(len=*),intent(in) :: val +!! integer :: place +!! +!! ! find where string is or should be +!! call locate_key(key,place) +!! ! if string was not found insert it +!! if(place < 1)then +!! call insert_(keywords,key,abs(place)) +!! call insert_(values,val,abs(place)) +!! else ! replace +!! call replace_(values,val,place) +!! endif +!! +!! end subroutine update_dic +!! end program demo_replace +!! +!! Expected output +!! +!! d==>value of d +!! c==>value of c again +!! b==>value of b +!! a==>value of a again +!! +!!##AUTHOR +!! 1989,2017 John S. Urban +!!##LICENSE +!! Public Domain +subroutine replace_c(list,value,place) + +! ident_25="@(#) M_CLI2 replace_c(3fp) replace string in allocatable string array at specified position" + +character(len=*),intent(in) :: value +character(len=:),allocatable :: list(:) +character(len=:),allocatable :: kludge(:) +integer,intent(in) :: place +integer :: ii +integer :: tlen +integer :: end + if(.not.allocated(list))then + list=[character(len=max(len_trim(value),2)) :: ] + endif + tlen=len_trim(value) + end=size(list) + if(place < 0.or.place > end)then + write(warn,*)'*replace_c* error: index out of range. end=',end,' index=',place + elseif(len_trim(value) <= len(list))then + list(place)=value + else ! increase length of variable + ii=max(tlen,len(list)) + kludge=[character(len=ii) :: list ] + list=kludge + list(place)=value + endif +end subroutine replace_c +subroutine replace_l(list,value,place) + +! ident_26="@(#) M_CLI2 replace_l(3fp) place value into allocatable array at specified position" + +logical,allocatable :: list(:) +logical,intent(in) :: value +integer,intent(in) :: place +integer :: end + if(.not.allocated(list))then + list=[logical :: ] + endif + end=size(list) + if(end == 0)then ! empty array + list=[value] + elseif(place > 0.and.place <= end)then + list(place)=value + else ! put in middle of array + write(warn,*)'*replace_l* error: index out of range. end=',end,' index=',place + endif +end subroutine replace_l +subroutine replace_i(list,value,place) + +! ident_27="@(#) M_CLI2 replace_i(3fp) place value into allocatable array at specified position" + +integer,intent(in) :: value +integer,allocatable :: list(:) +integer,intent(in) :: place +integer :: end + if(.not.allocated(list))then + list=[integer :: ] + endif + end=size(list) + if(end == 0)then ! empty array + list=[value] + elseif(place > 0.and.place <= end)then + list(place)=value + else ! put in middle of array + write(warn,*)'*replace_i* error: index out of range. end=',end,' index=',place + endif +end subroutine replace_i +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! insert_(3f) - [M_CLI2] insert entry into a string array at specified position +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine insert_(list,value,place) +!! +!! character(len=*)|doubleprecision|real|integer,intent(in) :: value +!! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) +!! integer,intent(in) :: place +!! +!!##DESCRIPTION +!! +!! Insert a value into an allocatable array at the specified index. +!! The list and value must be of the same type (CHARACTER, DOUBLEPRECISION, +!! REAL, or INTEGER) +!! +!!##OPTIONS +!! +!! list is the list array. Must be sorted in descending order. +!! value the value to place in the array +!! PLACE is the subscript that the entry should be placed at +!! +!!##EXAMPLES +!! +!! +!! Find if a string is in a sorted array, and insert the string into +!! the list if it is not present ... +!! +!! program demo_insert +!! use M_sort, only : sort_shell +!! use M_CLI2, only : locate_, insert_ +!! implicit none +!! character(len=:),allocatable :: arr(:) +!! integer :: i +!! +!! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] +!! ! make sure sorted in descending order +!! call sort_shell(arr,order='d') +!! ! add or replace values +!! call update_dic(arr,'b') +!! call update_dic(arr,'[') +!! call update_dic(arr,'c') +!! call update_dic(arr,'ZZ') +!! call update_dic(arr,'ZZZ') +!! call update_dic(arr,'ZZZZ') +!! call update_dic(arr,'') +!! call update_dic(arr,'z') +!! +!! contains +!! subroutine update_dic(arr,string) +!! character(len=:),allocatable :: arr(:) +!! character(len=*) :: string +!! integer :: place, end +!! +!! end=size(arr) +!! ! find where string is or should be +!! call locate_(arr,string,place) +!! ! if string was not found insert it +!! if(place < 1)then +!! call insert_(arr,string,abs(place)) +!! endif +!! ! show array +!! end=size(arr) +!! write(*,'("array is now SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) +!! +!! end subroutine update_dic +!! end program demo_insert +!! +!! Results: +!! +!! array is now SIZE=5 xxx,b,aaa,ZZZ,, +!! array is now SIZE=6 xxx,b,aaa,[,ZZZ,, +!! array is now SIZE=7 xxx,c,b,aaa,[,ZZZ,, +!! array is now SIZE=8 xxx,c,b,aaa,[,ZZZ,ZZ,, +!! array is now SIZE=9 xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,, +!! array is now SIZE=10 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,, +!! +!!##AUTHOR +!! 1989,2017 John S. Urban +!!##LICENSE +!! Public Domain +subroutine insert_c(list,value,place) + +! ident_28="@(#) M_CLI2 insert_c(3fp) place string into allocatable string array at specified position" + +character(len=*),intent(in) :: value +character(len=:),allocatable :: list(:) +character(len=:),allocatable :: kludge(:) +integer,intent(in) :: place +integer :: ii +integer :: end + + if(.not.allocated(list))then + list=[character(len=max(len_trim(value),2)) :: ] + endif + + ii=max(len_trim(value),len(list),2) + end=size(list) + + if(end == 0)then ! empty array + list=[character(len=ii) :: value ] + elseif(place == 1)then ! put in front of array + kludge=[character(len=ii) :: value, list] + list=kludge + elseif(place > end)then ! put at end of array + kludge=[character(len=ii) :: list, value ] + list=kludge + elseif(place >= 2.and.place <= end)then ! put in middle of array + kludge=[character(len=ii) :: list(:place-1), value,list(place:) ] + list=kludge + else ! index out of range + write(warn,*)'*insert_c* error: index out of range. end=',end,' index=',place,' value=',value + endif + +end subroutine insert_c +subroutine insert_l(list,value,place) + +! ident_29="@(#) M_CLI2 insert_l(3fp) place value into allocatable array at specified position" + +logical,allocatable :: list(:) +logical,intent(in) :: value +integer,intent(in) :: place +integer :: end + if(.not.allocated(list))then + list=[logical :: ] + endif + end=size(list) + if(end == 0)then ! empty array + list=[value] + elseif(place == 1)then ! put in front of array + list=[value, list] + elseif(place > end)then ! put at end of array + list=[list, value ] + elseif(place >= 2.and.place <= end)then ! put in middle of array + list=[list(:place-1), value,list(place:) ] + else ! index out of range + write(warn,*)'*insert_l* error: index out of range. end=',end,' index=',place,' value=',value + endif + +end subroutine insert_l +subroutine insert_i(list,value,place) + +! ident_30="@(#) M_CLI2 insert_i(3fp) place value into allocatable array at specified position" + +integer,allocatable :: list(:) +integer,intent(in) :: value +integer,intent(in) :: place +integer :: end + if(.not.allocated(list))then + list=[integer :: ] + endif + end=size(list) + if(end == 0)then ! empty array + list=[value] + elseif(place == 1)then ! put in front of array + list=[value, list] + elseif(place > end)then ! put at end of array + list=[list, value ] + elseif(place >= 2.and.place <= end)then ! put in middle of array + list=[list(:place-1), value,list(place:) ] + else ! index out of range + write(warn,*)'*insert_i* error: index out of range. end=',end,' index=',place,' value=',value + endif + +end subroutine insert_i +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +subroutine many_args(n0,g0, n1,g1, n2,g2, n3,g3, n4,g4, n5,g5, n6,g6, n7,g7, n8,g8, n9,g9, & + & na,ga, nb,gb, nc,gc, nd,gd, ne,ge, nf,gf, ng,gg, nh,gh, ni,gi, nj,gj ) + +! ident_31="@(#) M_CLI2 many_args(3fp) allow for multiple calls to get_args(3f)" + +character(len=*),intent(in) :: n0, n1 +character(len=*),intent(in),optional :: n2, n3, n4, n5, n6, n7, n8, n9, na, nb, nc, nd, ne, nf, ng, nh, ni, nj +class(*),intent(out) :: g0, g1 +class(*),intent(out),optional :: g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj + call get_generic(n0,g0) + call get_generic(n1,g1) + if( present(n2) .and. present(g2) )call get_generic(n2,g2) + if( present(n3) .and. present(g3) )call get_generic(n3,g3) + if( present(n4) .and. present(g4) )call get_generic(n4,g4) + if( present(n5) .and. present(g5) )call get_generic(n5,g5) + if( present(n6) .and. present(g6) )call get_generic(n6,g6) + if( present(n7) .and. present(g7) )call get_generic(n7,g7) + if( present(n8) .and. present(g8) )call get_generic(n8,g8) + if( present(n9) .and. present(g9) )call get_generic(n9,g9) + if( present(na) .and. present(ga) )call get_generic(na,ga) + if( present(nb) .and. present(gb) )call get_generic(nb,gb) + if( present(nc) .and. present(gc) )call get_generic(nc,gc) + if( present(nd) .and. present(gd) )call get_generic(nd,gd) + if( present(ne) .and. present(ge) )call get_generic(ne,ge) + if( present(nf) .and. present(gf) )call get_generic(nf,gf) + if( present(ng) .and. present(gg) )call get_generic(ng,gg) + if( present(nh) .and. present(gh) )call get_generic(nh,gh) + if( present(ni) .and. present(gi) )call get_generic(ni,gi) + if( present(nj) .and. present(gj) )call get_generic(nj,gj) +contains +!=================================================================================================================================== +function c(generic) +class(*),intent(in) :: generic +character(len=:),allocatable :: c + select type(generic) + type is (character(len=*)); c=trim(generic) + class default + c='unknown' + stop 'get_many:: parameter name is not character' + end select +end function c +!=================================================================================================================================== +subroutine get_generic(name,generic) +use,intrinsic :: iso_fortran_env, only : real64 +character(len=*),intent(in) :: name +class(*),intent(out) :: generic + select type(generic) + type is (integer); call get_args(name,generic) + type is (real); call get_args(name,generic) + type is (real(kind=real64)); call get_args(name,generic) + type is (logical); call get_args(name,generic) + !x!type is (character(len=:),allocatable ::); call get_args(name,generic) + type is (character(len=*)); + call get_args_fixed_length(name,generic) + type is (complex); call get_args(name,generic) + class default + stop 'unknown type in *get_generic*' + end select +end subroutine get_generic +!=================================================================================================================================== +end subroutine many_args +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +function iget(n); integer :: iget; character(len=*),intent(in) :: n; call get_args(n,iget); end function iget +function rget(n); real :: rget; character(len=*),intent(in) :: n; call get_args(n,rget); end function rget +function dget(n); real(kind=dp) :: dget; character(len=*),intent(in) :: n; call get_args(n,dget); end function dget +function sget(n); character(len=:),allocatable :: sget; character(len=*),intent(in) :: n; call get_args(n,sget); end function sget +function cget(n); complex :: cget; character(len=*),intent(in) :: n; call get_args(n,cget); end function cget +function lget(n); logical :: lget; character(len=*),intent(in) :: n; call get_args(n,lget); end function lget + +function igs(n); integer,allocatable :: igs(:); character(len=*),intent(in) :: n; call get_args(n,igs); end function igs +function rgs(n); real,allocatable :: rgs(:); character(len=*),intent(in) :: n; call get_args(n,rgs); end function rgs +function dgs(n); real(kind=dp),allocatable :: dgs(:); character(len=*),intent(in) :: n; call get_args(n,dgs); end function dgs +function sgs(n,delims) +character(len=:),allocatable :: sgs(:) +character(len=*),optional,intent(in) :: delims +character(len=*),intent(in) :: n + call get_args(n,sgs,delims) +end function sgs +function cgs(n); complex,allocatable :: cgs(:); character(len=*),intent(in) :: n; call get_args(n,cgs); end function cgs +function lgs(n); logical,allocatable :: lgs(:); character(len=*),intent(in) :: n; call get_args(n,lgs); end function lgs +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +function ig() +integer,allocatable :: ig(:) +integer :: i, ierr + if(allocated(ig))deallocate(ig) + allocate(ig(size(unnamed))) + do i=1,size(ig) + call a2i(unnamed(i),ig(i),ierr) + enddo +end function ig +!=================================================================================================================================== +function rg() +real,allocatable :: rg(:) + rg=real(dg()) +end function rg +!=================================================================================================================================== +function dg() +real(kind=dp),allocatable :: dg(:) +integer :: i +integer :: ierr + if(allocated(dg))deallocate(dg) + allocate(dg(size(unnamed))) + do i=1,size(dg) + call a2d(unnamed(i),dg(i),ierr) + enddo +end function dg +!=================================================================================================================================== +function lg() +logical,allocatable :: lg(:) +integer :: i +integer :: iichar +character,allocatable :: hold + if(allocated(lg))deallocate(lg) + allocate(lg(size(unnamed))) + do i=1,size(lg) + hold=upper(clipends(unnamed(i))) + if(hold(1:1) == '.')then ! looking for fortran logical syntax .STRING. + iichar=2 + else + iichar=1 + endif + select case(hold(iichar:iichar)) ! check word to see if true or false + case('T','Y',' '); lg(i)=.true. ! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...) + case('F','N'); lg(i)=.false. ! assume this is false or no + case default + call journal("*lg* bad logical expression for element",i,'=',hold) + end select + enddo +end function lg +!=================================================================================================================================== +function cg() +complex,allocatable :: cg(:) +integer :: i, ierr +real(kind=dp) :: rc, ic + if(allocated(cg))deallocate(cg) + allocate(cg(size(unnamed))) + do i=1,size(cg),2 + call a2d(unnamed(i),rc,ierr) + call a2d(unnamed(i+1),ic,ierr) + cg(i)=cmplx(rc,ic,kind=sp) + enddo +end function cg +!=================================================================================================================================== +! Does not work with gcc 5.3 +!function sg() +!character(len=:),allocatable :: sg(:) +! sg=unnamed +!end function sg + +!=================================================================================================================================== +function sg() +character(len=:),allocatable :: sg(:) + if(allocated(sg))deallocate(sg) + allocate(sg,source=unnamed) +end function sg +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +subroutine mystop(sig,msg) +! negative signal means always stop program +! else do not stop and set G_STOP_MESSAGE if G_QUIET is true +! or +! print message and stop if G_QUIET is false +! the MSG is NOT for displaying except for internal errors when the program will be stopped. +! It is for returning a value when the stop is being ignored +! +integer,intent(in) :: sig +character(len=*),intent(in),optional :: msg + if(sig < 0)then + if(present(msg))call journal(msg) + stop 1 + elseif(.not.G_QUIET)then + stop + else + if(present(msg)) then + G_STOP_MESSAGE=msg + else + G_STOP_MESSAGE='' + endif + G_STOP=sig + endif +end subroutine mystop +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +function atleast(line,length,pattern) result(strout) + +! ident_32="@(#) M_strings atleast(3f) return string padded to at least specified length" + +character(len=*),intent(in) :: line +integer,intent(in) :: length +character(len=*),intent(in),optional :: pattern +character(len=max(length,len(trim(line)))) :: strout +if(present(pattern))then + strout=line//repeat(pattern,len(strout)/len(pattern)+1) +else + strout=line +endif +end function atleast +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +function clipends(string) result(lopped) +! trim leading and trailings spaces from resulting string +character(len=*),intent(in) :: string +character(len=:),allocatable :: lopped +integer :: ends(2) + ends=verify( string, " ", [.false.,.true.] ) + if(ends(1) == 0)then + lopped="" + else + lopped=string(ends(1):ends(2)) + endif +end function clipends +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +subroutine locate_key(keyname,place) + +! ident_33="@(#) M_CLI2 locate_key(3f) find PLACE in sorted character array where KEYNAME can be found or should be placed" + +character(len=*),intent(in) :: keyname +integer,intent(out) :: place +integer :: ii +character(len=:),allocatable :: keyword_local + + if(G_UNDERDASH)then + keyword_local=trim(replace_str(keyname,'-','_')) + else + keyword_local=trim(keyname) + endif + + if(G_NODASHUNDER)then + keyword_local=replace_str(keyword_local,'-','') + keyword_local=replace_str(keyword_local,'_','') + endif + + if(G_IGNORELONGCASE.and.len_trim(keyword_local) > 1)keyword_local=lower(keyword_local) + if(G_IGNOREALLCASE)keyword_local=lower(keyword_local) + + if(len(keyword_local) == 1)then + !x!ii=findloc(shorts,keyword_local,dim=1) + ii=maxloc([0,merge(1, 0, shorts == keyword_local)],dim=1) + if(ii > 1)then + place=ii-1 + else + call locate_(keywords,keyword_local,place) + endif + else + call locate_(keywords,keyword_local,place) + endif + + if(G_DEBUG) write(*,gen)'LOCATE_KEY:KEYNAME:',trim(keyname),':KEYWORD:',keyword_local + +end subroutine locate_key +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! set_mode(3f) - [ARGUMENTS:M_CLI2] turn on optional modes +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine set_mode(key,mode) +!! +!! character(len=*),intent(in) :: key +!! logical,intent(in),optional :: mode +!! +!!##DESCRIPTION +!! Allow optional behaviors. +!! +!!##OPTIONS +!! KEY name of option +!! +!! The following values are allowed: +!! +!! o response_file - enable use of response file +!! +!! o ignorelongcase - ignore case in long key names. So the user +!! does not have to remember if the option is --CurtMode or --curtmode +!! or --curtMode . +!! +!! o ignoreallcase - ignore case in long and short key names. +!! This is similar to Powershell, which is case-insensitive. +!! +!! o dashunder - treat dash in keyword as an underscore. +!! So the user should not have to remember if the option is +!! --ignore_case or --ignore-case. +!! +!! o nodashunder - ignore dash and underscore in keywords. +!! +!! o strict - allow Boolean keys to be bundled, but requires +!! a single dash prefix be used for short key names and long names +!! must be prefixed with two dashes. +!! +!! o lastonly - when multiple keywords occur keep the rightmost +!! value specified instead of appending the values together. +!! +!! MODE set to .true. to activate the optional mode. +!! Set to .false. to deactivate the mode. +!! It is .true. by default. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_set_mode +!! use M_CLI2, only : set_args, lget, set_mode +!! implicit none +!! character(len=*),parameter :: all='(*(g0))' +!! ! +!! ! enable use of response files +!! call set_mode('response_file') +!! ! +!! ! Any dash in a keyword is treated as an underscore +!! call set_mode('underdash') +!! ! +!! ! The case of long keywords are ignored. +!! ! Values and short names remain case-sensitive +!! call set_mode('ignorelongcase') +!! ! The case of short and long keywords are ignored +!! call set_mode('ignoreallcase') +!! ! +!! ! short single-character boolean keys may be bundled +!! ! but it is required that a single dash is used for +!! ! short keys and a double dash for long keywords. +!! call set_mode('strict') +!! ! +!! call set_args(' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F') +!! ! +!! ! show the results +!! print all,'--switch_X or -X ... ',lget('switch_X') +!! print all,'--switch_Y or -Y ... ',lget('switch_Y') +!! print all,'--ox or -O ... ',lget('ox') +!! print all,'-o ... ',lget('o') +!! print all,'-x ... ',lget('x') +!! print all,'-t ... ',lget('t') +!! end program demo_set_mode +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +elemental impure subroutine set_mode(key,mode) +character(len=*),intent(in) :: key +logical,intent(in),optional :: mode +logical :: local_mode +character(len=:),allocatable :: debug_mode + + debug_mode= upper(get_env('CLI_DEBUG_MODE','FALSE'))//' ' + select case(debug_mode(1:1)) + case('Y','T') + G_DEBUG=.true. + end select + + if(present(mode))then + local_mode=mode + else + local_mode=.true. + endif + + select case(lower(key)) + case('response_file','response file'); CLI_RESPONSE_FILE=local_mode + case('debug'); G_DEBUG=local_mode + case('ignorecase','ignorelongcase'); G_IGNORELONGCASE=local_mode + case('ignoreallcase'); G_IGNOREALLCASE=local_mode + case('underdash','dashunder'); G_UNDERDASH=local_mode + case('nodashunder','nounderdash'); G_NODASHUNDER=local_mode + case('strict'); G_STRICT=local_mode + case('lastonly'); G_APPEND=.not.local_mode + case default + call journal('*set_mode* unknown key name ',key) + end select + + if(G_DEBUG)write(*,gen)'SET_MODE:END' + +end subroutine set_mode +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine print_dictionary_usage() + if(G_DEBUG)then + call print_dictionary( str('response_file=', CLI_RESPONSE_FILE, & + &'ignorelongcase=', G_IGNORELONGCASE,& + &'ignoreallcase=', G_IGNOREALLCASE,& + &'underdash=', G_UNDERDASH,& + &'strict=', G_STRICT,& + &'lastonly=', G_APPEND,& + &'NODASHUNDER=', G_NODASHUNDER,& + &'debug=', G_DEBUG) ) + else + call print_dictionary('USAGE:') + endif +end subroutine print_dictionary_usage +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +end module M_CLI2 +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!=================================================================================================================================== + +!>>>>> build/dependencies/fortran-regex/src/regex.f90 + +! ************************************************************************************************* +! ____ ___________________ __ +! / __ \/ ____/ ____/ ____/ |/ / +! / /_/ / __/ / / __/ __/ | / +! / _, _/ /___/ /_/ / /___ / | +! /_/ |_/_____/\____/_____//_/|_| +! +! MIT License +! +! (C) Federico Perini, 2022 +! A Fortran port of the tiny-regex library. +! +! https://github.com/kokke/tiny-regex-c +! Code inspired by Rob Pike's regex code described in: +! http://www.cs.princeton.edu/courses/archive/spr09/cos333/beautiful.html +! +! ************************************************************************************************* +module regex_module + use iso_fortran_env, only: output_unit + implicit none + private + + public :: parse_pattern + public :: check_pattern + public :: regex + + ! Character kind + integer, parameter, public :: RCK = selected_char_kind("ascii") + + logical, parameter, public :: RE_DOT_MATCHES_NEWLINE = .true. ! Define .false. if you DON'T want '.' to match '\r' + '\n' + integer, parameter, public :: MAX_REGEXP_OBJECTS = 512 ! Max number of regex symbols in expression. + integer, parameter, public :: MAX_CHAR_CLASS_LEN = 1024 ! Max length of character-class buffer in. + + ! Turn on verbosity for debugging + logical, parameter :: DEBUG = .false. + + ! Supported patterns + integer, parameter :: UNUSED = 0 + integer, parameter :: DOT = 1 ! '.' Dot, matches any character + integer, parameter :: BEGIN_WITH = 2 ! '^' Start anchor, matches beginning of string + integer, parameter :: END_WITH = 3 ! '$' End anchor, matches end of string + integer, parameter :: QUESTIONMARK = 4 ! '?' Question, match zero or one (non-greedy) + integer, parameter :: STAR = 5 ! '*' Asterisk, match zero or more (greedy) + integer, parameter :: PLUS = 6 ! '+' Plus, match one or more (greedy) + integer, parameter :: ATCHAR = 7 ! '[a-zA-Z]' Character ranges, the character set of the ranges { a-z | A-Z } + integer, parameter :: AT_CHAR_CLASS = 8 ! '[abc]' Character class, match if one of {'a', 'b', 'c'} + integer, parameter :: INV_CHAR_CLASS = 9 ! '[^abc]' Inverted class, match if NOT one of {'a', 'b', 'c'} -- NOTE: feature is currently broken! + integer, parameter :: DIGIT = 10 ! '\d' Digits, [0-9] + integer, parameter :: NOT_DIGIT = 11 ! '\D' Non-digits + integer, parameter :: ALPHA = 12 ! '\w' Alphanumeric, [a-zA-Z0-9_] + integer, parameter :: NOT_ALPHA = 13 ! '\W' Non-alphanumeric + integer, parameter :: WHITESPACE = 14 ! '\s' Whitespace, \t \f \r \n \v and spaces + integer, parameter :: NOT_WHITESPACE = 15 ! '\S' Non-whitespace + + character(kind=RCK,len=*), parameter :: types(*) = [ character(len=14) :: "UNUSED", "DOT", "BEGIN", "END", "QUESTIONMARK", & + "STAR", "PLUS", "CHAR", "CHAR_CLASS", "INV_CHAR_CLASS", "DIGIT", "NOT_DIGIT", "ALPHA", "NOT_ALPHA", & + "WHITESPACE", "NOT_WHITESPACE", "BRANCH" ] + + ! Characters + character(kind=RCK,len=*), parameter :: lowercase="abcdefghijklmnopqrstuvwxyz" + character(kind=RCK,len=*), parameter :: uppercase="ABCDEFGHIJKLMNOPQRSTUVWXYZ" + + character(kind=RCK), parameter, public :: UNDERSCORE = "_" + character(kind=RCK), parameter, public :: SPACE = " " + character(kind=RCK), parameter, public :: DASH = "-" + character(kind=RCK), parameter, public :: CNULL = achar( 0,kind=RCK) ! \0 or null character + character(kind=RCK), parameter, public :: NEWLINE = achar(10,kind=RCK) ! \n or line feed + character(kind=RCK), parameter, public :: BACKSPCE = achar( 8,kind=RCK) ! \b or backspace character + character(kind=RCK), parameter, public :: TAB = achar( 9,kind=RCK) ! \t or tabulation character + + ! Regex pattern element + type, public :: regex_token + + integer :: type = UNUSED + + ! Single or multi-character pattern + character(kind=RCK,len=:), allocatable :: ccl + contains + + procedure :: print => print_pattern + procedure :: destroy => pat_destroy + procedure :: match => pat_match + + end type regex_token + + type, public :: regex_pattern + + integer :: n = 0 + + type(regex_token), dimension(MAX_REGEXP_OBJECTS) :: pattern + + contains + + procedure :: new => new_from_pattern + procedure :: write => write_pattern + procedure :: nrules + procedure :: destroy + final :: finalize + + end type regex_pattern + + ! Public interface + interface regex + module procedure re_match + module procedure re_match_noback + module procedure re_match_nolength + module procedure re_match_nolength_noback + module procedure re_matchp + module procedure re_matchp_noback + module procedure re_matchp_nolength + module procedure re_matchp_nolength_noback + end interface regex + + ! Override default constructor for ifort bug + interface regex_token + module procedure pat_from_char + end interface regex_token + + contains + + ! Construct a regex pattern from a single character + elemental type(regex_token) function pat_from_char(type,ccl) result(this) + integer, intent(in) :: type + character(kind=RCK), intent(in) :: ccl + call pat_destroy(this) + this%type = type + allocate(character(len=1,kind=RCK) :: this%ccl) + this%ccl(1:1) = ccl + end function pat_from_char + + ! Check that a pattern matches the expected result + logical function check_pattern(string,pattern,expected) result(success) + character(len=*,kind=RCK), intent(in) :: string + character(len=*,kind=RCK), intent(in) :: pattern + character(len=*,kind=RCK), intent(in) :: expected + + integer :: idx,length + + idx = regex(string,pattern,length) + + if (idx>0) then + success = length==len(expected) + if (success) success = string(idx:idx+length-1)==expected + else + success = len(expected)<=0 + end if + + if (DEBUG .and. .not.success) then + print "('[regex] test FAILED: text=',a,' pattern=',a,' index=',i0,' len=',i0)", & + string,pattern,idx,length + stop 1 + endif + + end function check_pattern + + ! Clean up a pattern + elemental subroutine pat_destroy(this) + class(regex_token), intent(inout) :: this + integer :: ierr + this%type = UNUSED + deallocate(this%ccl,stat=ierr) + end subroutine pat_destroy + + ! Number of rules in the current pattern + elemental integer function nrules(this) + class(regex_pattern), intent(in) :: this + integer :: i + nrules = 0 + do i=1,MAX_REGEXP_OBJECTS + if (this%pattern(i)%type==UNUSED) return + nrules = nrules + 1 + end do + end function nrules + + subroutine write_pattern(this,iunit) + class(regex_pattern), intent(in) :: this + integer, optional, intent(in) :: iunit + + integer :: i,u + + if (present(iunit)) then + u = iunit + else + u = output_unit + end if + + do i=1,this%nrules() + write(u,'(a)') this%pattern(i)%print() + end do + + end subroutine write_pattern + + elemental subroutine destroy(this) + class(regex_pattern), intent(inout) :: this + integer :: i + do i=1,MAX_REGEXP_OBJECTS + call this%pattern(i)%destroy() + end do + end subroutine destroy + + subroutine finalize(this) + type(regex_pattern), intent(inout) :: this + integer :: i + do i=1,MAX_REGEXP_OBJECTS + call this%pattern(i)%destroy() + end do + end subroutine finalize + + ! Check that a character matches a dot ("any character") pattern + elemental logical function matchdot(c) + character(kind=RCK), intent(in) :: c + if (RE_DOT_MATCHES_NEWLINE) then + matchdot = .true. + else + matchdot = c/=NEWLINE .and. c/=BACKSPCE + end if + end function matchdot + + elemental logical function ismetachar(c) + character(kind=RCK), intent(in) :: c + ismetachar = index("sSwWdD",c)>0 + end function ismetachar + + pure logical function matchmetachar(c, str) + character(kind=RCK), intent(in) :: c + character(kind=RCK,len=*), intent(in) :: str + + select case (str(1:1)) + case ('d'); matchmetachar = isdigit(c) + case ('D'); matchmetachar = .not.isdigit(c) + case ('w'); matchmetachar = isalphanum(c) + case ('W'); matchmetachar = .not.isalphanum(c) + case ('s'); matchmetachar = isspace(c) + case ('S'); matchmetachar = .not.isspace(c) + case default; matchmetachar = c==str(1:1) + end select + end function matchmetachar + + elemental logical function isdigit(c) + character(kind=RCK), intent(in) :: c + isdigit = index("1234567890",c)>0 + end function isdigit + + elemental logical function isalpha(c) + character(kind=RCK), intent(in) :: c + isalpha = index(lowercase,c)>0 .or. index(uppercase,c)>0 + end function isalpha + + elemental logical function isalphanum(c) + character(kind=RCK), intent(in) :: c + isalphanum = isalpha(c) .or. isdigit(c) .or. c==UNDERSCORE + end function isalphanum + + elemental logical function isspace(c) + character(kind=RCK), intent(in) :: c + isspace = c==SPACE + end function isspace + + ! Match range of the tye 0-9 or 5-7 etc. + elemental logical function matchrange(c,str) + character(kind=RCK), intent(in) :: c + character(kind=RCK,len=*), intent(in) :: str ! the range pattern + + matchrange = len(str)>=3; if (.not.matchrange) return + matchrange = c /= DASH & + .and. str(1:1) /= DASH & + .and. str(2:2) == DASH & + .and. iachar(c)>=iachar(str(1:1)) & + .and. iachar(c)<=iachar(str(3:3)) ! Range (number/letters) is in increasing order + + end function matchrange + + logical function matchcharclass(c,str) result(match) + character(kind=RCK), intent(in) :: c ! The current character + character(kind=RCK,len=*), intent(in) :: str ! The charclass contents + + integer :: i + + match = .false. + i = 0 + + ! All characters in the charclass contents + loop: do while (ilen(str) + + else + match = .true. + end if + return + end if + + end do loop + + if (DEBUG) print *, 'charclass: no match on i=',i,' str=',trim(str),' c=',c + + end function matchcharclass + + recursive logical function matchquestion(p, pattern, text, matchlength) + type(regex_token), intent(in) :: p, pattern(:) + character(len=*,kind=RCK), intent(in) :: text + integer, intent(inout) :: matchlength + + matchquestion = .false. + + if (p%type == UNUSED) then + matchquestion = .true. + return + elseif (matchpattern(pattern, text, matchlength)) then + matchquestion = .true. + return + elseif (len(text)>0) then + if (pat_match(p,text) .and. len(text)>1) then + if (matchpattern(pattern,text(2:),matchlength)) then + matchlength = matchlength+1 + matchquestion = .true. + return + endif + end if + end if + + end function matchquestion + + recursive logical function matchstar(p, pattern, text, it0, matchlength) + type(regex_token), intent(in) :: p, pattern(:) + character(len=*,kind=RCK), intent(in) :: text + integer, intent(in) :: it0 ! starting point + integer, intent(inout) :: matchlength + + integer :: prelen,it + + if (DEBUG) print *, 'match star, length=',matchlength,' it0=',it0,' lenm=',len(text) + + if (len(text)<=0) then + matchstar = .false. + return + end if + + ! Save input variables + prelen = matchlength + it = it0 + + do while (it>0 .and. it<=len(text)) + if (.not.pat_match(p, text(it:))) exit + it = it+1 + matchlength = matchlength+1 + end do + + do while (it>=it0) + matchstar = matchpattern(pattern, text(it:), matchlength) + it = it-1 + if (matchstar) return + matchlength = matchlength-1 + end do + + matchlength = prelen + matchstar = .false. + + end function matchstar + + recursive logical function matchplus(p, pattern, text, it0, matchlength) + type(regex_token), intent(in) :: p, pattern(:) + character(len=*,kind=RCK), intent(in) :: text + integer, intent(in) :: it0 + integer, intent(inout) :: matchlength + + integer :: it + + if (DEBUG) print *, 'matching PLUS pattern' + + it = it0 + do while (it>0 .and. it<=len(text)) + if (.not. pat_match(p, text(it:))) exit + it = it+1 + matchlength = matchlength+1 + end do + + do while (it>it0) + matchplus = matchpattern(pattern, text(it:), matchlength) + it = it-1 + if (matchplus) return + matchlength = matchlength-1 + end do + + matchplus = .false. + + end function matchplus + + ! Find matches of the given pattern in the string + integer function re_match(string, pattern, length, back) result(index) + character(*,kind=RCK), intent(in) :: pattern + character(*,kind=RCK), intent(in) :: string + integer, intent(out) :: length + logical, intent(in) :: back + type (regex_pattern) :: command + + command = parse_pattern(pattern) + index = re_matchp(string,command,length,back) + + end function re_match + + ! Find matches of the given pattern in the string + integer function re_match_noback(string, pattern, length) result(index) + character(*,kind=RCK), intent(in) :: pattern + character(*,kind=RCK), intent(in) :: string + integer, intent(out) :: length + type (regex_pattern) :: command + + command = parse_pattern(pattern) + index = re_matchp(string,command,length,.false.) + + end function re_match_noback + + ! Find matches of the given pattern in the string + integer function re_match_nolength(string, pattern, back) result(index) + character(*,kind=RCK), intent(in) :: pattern + character(*,kind=RCK), intent(in) :: string + logical , intent(in) :: back + + type (regex_pattern) :: command + integer :: length + + command = parse_pattern(pattern) + index = re_matchp(string,command,length,back) + + end function re_match_nolength + + ! Find matches of the given pattern in the string + integer function re_match_nolength_noback(string, pattern) result(index) + character(*,kind=RCK), intent(in) :: pattern + character(*,kind=RCK), intent(in) :: string + + type (regex_pattern) :: command + integer :: length + + command = parse_pattern(pattern) + index = re_matchp(string,command,length,.false.) + + end function re_match_nolength_noback + + type(regex_pattern) function parse_pattern(pattern) result(this) + character(*,kind=RCK), intent(in) :: pattern + + call new_from_pattern(this,pattern) + + end function parse_pattern + + subroutine new_from_pattern(this,pattern) + class(regex_pattern), intent(inout) :: this + character(*,kind=RCK), intent(in) :: pattern + + ! Local variables + character(len=MAX_CHAR_CLASS_LEN,kind=RCK) :: ccl_buf ! size of buffer for chars in all char-classes in the expression. */ + integer :: loc,i,j,lenp,lenc + character(kind=RCK) :: c + + ! Initialize class + call this%destroy() + ccl_buf = repeat(SPACE,MAX_CHAR_CLASS_LEN) + + if (DEBUG) print "('[regex] parsing pattern: <',a,'>')", trim(pattern) + + i = 1 ! index in pattern + j = 1 ! index in re-compiled + lenp = len_trim(pattern) + + ! Move along the pattern string + to_the_moon: do while (i<=lenp) + + c = pattern(i:i) + if (DEBUG) print "('[regex] at location ',i0,': <',a,'>')", i, c + + select case (c) + + ! Meta-characters are single-character patterns + case ('^'); this%pattern(j) = regex_token(BEGIN_WITH,c) + case ('$'); this%pattern(j) = regex_token(END_WITH,c) + case ('.'); this%pattern(j) = regex_token(DOT,c) + case ('*'); this%pattern(j) = regex_token(STAR,c) + case ('+'); this%pattern(j) = regex_token(PLUS,c) + case ('?'); this%pattern(j) = regex_token(QUESTIONMARK,c) + + ! Escaped character-classes (\s, \w, ...) + case ('\'); + + ! Parse an escaped character class + if (i=lenp) then + call this%destroy() + return + end if + + else + this%pattern(j)%type = AT_CHAR_CLASS + end if + + ! Remove any escape characters + loc = index(pattern(i+1:),']') + lenc = loc-1 + if (loc>0) then + ccl_buf = pattern(i+1:i+loc-1) + i = i+loc + if (DEBUG) print "('[regex] at end of multi-character pattern: ',a)", trim(ccl_buf) + else + ! Incomplete [] pattern + call this%destroy() + return + end if + + ! If there is any escape character(s), just check that the next is nonempty + loc = index(ccl_buf,'\') + if (loc>0) then + if (loc>=len(ccl_buf)) then + ! stop 'incomplete escaped character inside [] pattern' + call this%destroy() + return + end if + if (ccl_buf(loc+1:loc+1)==SPACE) then + ! stop 'empty escaped character inside [] pattern' + call this%destroy() + return + end if + end if + + ! Ensure there are no spaces + + allocate(character(len=lenc,kind=RCK) :: this%pattern(j)%ccl) + this%pattern(j)%ccl = ccl_buf(:lenc) + + case default + + ! Single character + this%pattern(j) = regex_token(ATCHAR,c) + + end select + + if (DEBUG) print "('[regex] added pattern ',i0,': ',a)",j,this%pattern(j)%print() + + ! A pattern was added: move to next + i = i+1 + j = j+1 + if (j>MAX_REGEXP_OBJECTS) stop 'max regexp reached!' + + end do to_the_moon + + ! Save number of patterns + this%n = j-1 + return + + end subroutine new_from_pattern + + function print_pattern(pattern) result(msg) + class(regex_token), intent(in) :: pattern + character(:,kind=RCK), allocatable :: msg + + character(len=MAX_CHAR_CLASS_LEN,kind=RCK) :: buffer + integer :: lt + + write(buffer,1) trim(types(pattern%type+1)),trim(pattern%ccl) + + lt = len_trim(buffer) + allocate(character(len=lt,kind=RCK) :: msg) + if (lt>0) msg(1:lt) = buffer(1:lt) + + 1 format('type=',a,:,1x,'char=',a) + + end function print_pattern + + ! Match a single pattern at the g + recursive logical function pat_match(p, c) result(match) + class(regex_token), intent(in) :: p + character(kind=RCK), intent(in) :: c + + select case (p%type) + case (DOT); match = matchdot(c) + case (AT_CHAR_CLASS); match = matchcharclass(c,p%ccl) + case (INV_CHAR_CLASS); match = .not.matchcharclass(c,p%ccl) + case (DIGIT); match = isdigit(c) + case (NOT_DIGIT); match = .not.isdigit(c) + case (ALPHA); match = isalphanum(c) + case (NOT_ALPHA); match = .not.isalphanum(c) + case (WHITESPACE); match = isspace(c) + case (NOT_WHITESPACE); match = .not.isspace(c) + case default; match = c==p%ccl(1:1) + end select + + if (DEBUG) print "('[regex] current pattern=',a,' at char=',a,' match? ',l1)", p%print(),c,match + + end function pat_match + + integer function re_matchp_nolength(string, pattern, back) result(index) + type(regex_pattern), intent(in) :: pattern + character(len=*,kind=RCK), intent(in) :: string + logical, intent(in) :: back + integer :: matchlength + index = re_matchp(string, pattern, matchlength, back) + end function re_matchp_nolength + + integer function re_matchp_nolength_noback(string, pattern) result(index) + type(regex_pattern), intent(in) :: pattern + character(len=*,kind=RCK), intent(in) :: string + integer :: matchlength + index = re_matchp(string, pattern, matchlength, .false.) + end function re_matchp_nolength_noback + + integer function re_matchp_noback(string, pattern, length) result(index) + type(regex_pattern), intent(in) :: pattern + character(len=*,kind=RCK), intent(in) :: string + integer, intent(out) :: length + index = re_matchp(string, pattern, length, .false.) + end function re_matchp_noback + + integer function re_matchp(string, pattern, length, back) result(index) + type(regex_pattern), intent(in) :: pattern + character(len=*,kind=RCK), intent(in) :: string + integer, intent(out) :: length + logical, intent(in) :: back + + integer :: first,last,step + + if (pattern%n>0) then + + if (pattern%pattern(1)%type == BEGIN_WITH) then + + ! String must begin with this pattern + length = 0 + index = merge(1,0,matchpattern(pattern%pattern(2:), string, length) .and. len(string)>0) + + else + + first = merge(1,len(string),.not.back) + last = merge(1,len(string),back) + step = sign(1,last-first) + + do index=first,last,step + length = 0 + if (matchpattern(pattern%pattern,string(index:),length)) goto 1 + end do + + index = 0 + + end if + + else + + ! On an empty/invalid pattern, return -1 + index = -1 + + end if + + 1 if (DEBUG) then + if (index==-1) then + print "('[regex] end: empty/invalid regex pattern. ')" + elseif (index==0) then + print "('[regex] end: pattern not found. ')" + else + print "('[regex] end: pattern found at ',i0,': ',a)", index,string(index:) + end if + end if + + end function re_matchp + + ! Iterative matching + recursive logical function matchpattern(pattern, text, matchlength) result(match) + type(regex_token), intent(in) :: pattern(:) + character(kind=RCK,len=*), intent(in) :: text + integer, intent(inout) :: matchlength + + integer :: pre,ip,it + + pre = matchlength + ip = 1 + it = 1 + + iterate: do while (ip<=size(pattern)) + + if (pattern(ip)%type == UNUSED .or. pattern(ip+1)%type == QUESTIONMARK) then + + match = matchquestion(pattern(ip),pattern(ip+2:),text(it:),matchlength) + return + + elseif (pattern(ip+1)%type == STAR) then + + match = matchstar(pattern(ip),pattern(ip+2:), text, it, matchlength) + return + + elseif (pattern(ip+1)%type == PLUS) then + + match = matchplus(pattern(ip),pattern(ip+2:), text, it, matchlength) + return + + elseif (pattern(ip)%type == END_WITH .and. pattern(ip+1)%type == UNUSED) then + + if (DEBUG .and. len(text(it:))>0) print *, '[regex] at end: remaining = ',text(it:),' len=',matchlength + + match = it>len(text) + return + + end if + + if (it>len(text)) exit iterate + + matchlength = matchlength+1 + + if (DEBUG) print "('[regex] matching ',i0,'-th pattern on chunk <',i0,':',i0,'>')", ip,it,len(text) + if (.not. pat_match(pattern(ip), text(it:it))) exit iterate + ip = ip+1 + it = it+1 + + end do iterate + + matchlength = pre + match = .false. + return + + end function matchpattern + +end module regex_module + +!>>>>> build/dependencies/jonquil/src/jonquil/version.f90 + +! This file is part of jonquil. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Version information on jonquil +module jonquil_version + implicit none + private + + public :: get_jonquil_version + public :: jonquil_version_string, jonquil_version_compact + + !> String representation of the jonquil version + character(len=*), parameter :: jonquil_version_string = "0.4.0" + + !> Major version number of the above jonquil version + integer, parameter :: jonquil_major = 0 + + !> Minor version number of the above jonquil version + integer, parameter :: jonquil_minor = 4 + + !> Patch version number of the above jonquil version + integer, parameter :: jonquil_patch = 0 + + !> Compact numeric representation of the jonquil version + integer, parameter :: jonquil_version_compact = & + & jonquil_major*10000 + jonquil_minor*100 + jonquil_patch + +contains + +!> Getter function to retrieve jonquil version +subroutine get_jonquil_version(major, minor, patch, string) + + !> Major version number of the jonquil version + integer, intent(out), optional :: major + + !> Minor version number of the jonquil version + integer, intent(out), optional :: minor + + !> Patch version number of the jonquil version + integer, intent(out), optional :: patch + + !> String representation of the jonquil version + character(len=:), allocatable, intent(out), optional :: string + + if (present(major)) then + major = jonquil_major + end if + if (present(minor)) then + minor = jonquil_minor + end if + if (present(patch)) then + patch = jonquil_patch + end if + if (present(string)) then + string = jonquil_version_string + end if + +end subroutine get_jonquil_version + +end module jonquil_version + +!>>>>> build/dependencies/fortran-shlex/src/shlex_module.f90 + +! ************************************************************************************************* +! _____ __ ____ _______ __ +! / ___// / / / / / ____/ |/ / +! \__ \/ /_/ / / / __/ | / +! ___/ / __ / /___/ /___ / | +! /____/_/ /_/_____/_____//_/|_| +! +! MIT License +! +! (C) Federico Perini, 2023 +! A Fortran port of the Python standard library shlex module. +! +! https://github.com/perazz/fortran-shlex +! +! ************************************************************************************************* +module shlex_module + use iso_fortran_env, only: output_unit + implicit none + private + + integer, parameter, public :: SCK = selected_char_kind("ascii") + + ! Shlex: return tokens + public :: shlex + interface shlex + module procedure shlex_bool + module procedure shlex_error + end interface + + ! Split: return split strings + public :: split + interface split + module procedure split_bool + module procedure split_error + end interface + + ! Turn on verbosity for debugging + logical, parameter :: DEBUG = .false. + + ! Character types + integer, parameter :: CHAR_UNKNOWN = 0 + integer, parameter :: CHAR_SPACE = 1 + integer, parameter :: CHAR_ESCAPING_QUOTE = 2 + integer, parameter :: CHAR_NONESCAPING_QUOTE = 3 + integer, parameter :: CHAR_ESCAPE = 4 + integer, parameter :: CHAR_COMMENT = 5 + integer, parameter :: CHAR_EOF = 6 + + ! Error types + integer, parameter :: NO_ERROR = 0 + integer, parameter :: SYNTAX_ERROR = 1 + integer, parameter :: EOF_ERROR = 2 + + character(kind=SCK), parameter, public :: NEWLINE = achar(10,kind=SCK) ! \n or line feed + character(kind=SCK), parameter, public :: TAB = achar( 9,kind=SCK) ! \t or tabulation character + character(kind=SCK), parameter, public :: CARRIAGE = achar(13,kind=SCK) ! \t or tabulation character + + integer, parameter :: MAX_CHAR_CLASS_LEN = 1024 + + ! Character type sets + character(kind=SCK,len=*), parameter :: SPACE_CHARS = " "//NEWLINE//TAB//CARRIAGE + character(kind=SCK,len=*), parameter :: ESCAPING_QUOTE_CHARS = '"' + character(kind=SCK,len=*), parameter :: NONESCAPING_QUOTE_CHARS = "'" + character(kind=SCK,len=*), parameter :: ESCAPE_CHARS = "\" + character(kind=SCK,len=*), parameter :: COMMENT_CHARS = "#" + + ! Token types + integer, parameter :: TOKEN_UNKNOWN = 0 + integer, parameter :: TOKEN_WORD = 1 + integer, parameter :: TOKEN_SPACE = 2 + integer, parameter :: TOKEN_COMMENT = 3 + + ! Lexer state + integer, parameter :: STATE_START = 0 ! No characters read yet + integer, parameter :: STATE_INWORD = 1 ! Processing characters in a word + integer, parameter :: STATE_ESCAPING = 2 ! Just found an escape character: next has to be literal + integer, parameter :: STATE_ESCAPING_QUOTED = 3 ! Just found an e2cape character within a quoted string + integer, parameter :: STATE_QUOTING_ESCAPING = 4 ! Within a quoted string that supports escaping ("...") + integer, parameter :: STATE_QUOTING = 5 ! Within a quoted string that does not support escaping ('...') + integer, parameter :: STATE_COMMENT = 6 ! Within a comment + + type, public :: shlex_token + + integer :: type = TOKEN_UNKNOWN + character(kind=SCK,len=:), allocatable :: string + + end type shlex_token + + type, public :: shlex_lexer + + ! The input string + integer :: input_position = 0 + integer :: input_length = -1 + + contains + + procedure :: destroy + procedure :: new + + end type shlex_lexer + + contains + + elemental subroutine destroy_token(this) + class(shlex_token), intent(inout) :: this + this%type = TOKEN_UNKNOWN + if (allocated(this%string)) deallocate(this%string) + end subroutine destroy_token + + elemental type(shlex_token) function new_token(type,string) result(token) + integer, intent(in) :: type + character(kind=SCK,len=*), intent(in) :: string + call destroy_token(token) + token%type = type + token%string = string + end function new_token + + ! Return + elemental integer function CHAR_TYPE(c) + character(kind=SCK), intent(in) :: c + + if (scan(c,SPACE_CHARS)>0) then + CHAR_TYPE = CHAR_SPACE + elseif (scan(c,ESCAPING_QUOTE_CHARS)>0) then + CHAR_TYPE = CHAR_ESCAPING_QUOTE + elseif (scan(c,NONESCAPING_QUOTE_CHARS)>0) then + CHAR_TYPE = CHAR_NONESCAPING_QUOTE + elseif (scan(c,ESCAPE_CHARS)>0) then + CHAR_TYPE = CHAR_ESCAPE + elseif (scan(c,COMMENT_CHARS)>0) then + CHAR_TYPE = CHAR_COMMENT + else + CHAR_TYPE = CHAR_UNKNOWN + end if + + end function CHAR_TYPE + + ! High level interface: return a list of strings, with error type + function split_bool(pattern,success) result(list) + character(*), intent(in) :: pattern + logical, optional, intent(out) :: success + character(kind=SCK,len=:), allocatable :: list(:) + type(shlex_token) :: error + + list = split_error(pattern,error) + if (present(success)) success = error%type==NO_ERROR + + end function split_bool + + ! High level interface: return a list of strings + function split_error(pattern,error) result(list) + character(*), intent(in) :: pattern + type(shlex_token), intent(out) :: error + character(kind=SCK,len=:), allocatable :: list(:) + + type(shlex_token), allocatable :: tokens(:) + + integer :: n,maxlen,i,l + + tokens = shlex(pattern,error) + + n = size(tokens) + maxlen = 0 + do i=1,n + maxlen = max(maxlen,len(tokens(i)%string)) + end do + + allocate(character(kind=SCK,len=maxlen) :: list(n)) + do i=1,n + list(i) = tokens(i)%string + end do + + end function split_error + + ! High level interface: return a list of tokens + function shlex_bool(pattern,success) result(list) + character(*), intent(in) :: pattern + logical, optional, intent(out) :: success + type(shlex_token), allocatable :: list(:) + type(shlex_token) :: error + + list = shlex_error(pattern,error) + if (present(success)) success = error%type==NO_ERROR + end function shlex_bool + + ! High level interface: return a list of tokens + function shlex_error(pattern,error) result(list) + character(*), intent(in) :: pattern + type(shlex_token), intent(out) :: error + type(shlex_token), allocatable :: list(:) + + type(shlex_lexer) :: s + type(shlex_token) :: next + + ! Initialize lexer + call s%new(pattern) + + allocate(list(0)) + error = new_token(NO_ERROR,"SUCCESS") + do while (error%type==NO_ERROR) + + next = scan_stream(s,pattern,error) + select case (error%type) + case (EOF_ERROR) + ! Finished reading + error = new_token(NO_ERROR,"SUCCESS") + exit + case (SYNTAX_ERROR) + ! Something happened + exit + case default + ! Keep reading + list = [list,next] + end select + + end do + + return + + end function shlex_error + + type(shlex_token) function scan_stream(this,pattern,error) result(token) + class(shlex_lexer), intent(inout) :: this + character(kind=SCK,len=*), intent(in) :: pattern + type(shlex_token), intent(out) :: error + + integer :: state,next_type,token_type + character(kind=SCK) :: next_char + character(kind=SCK,len=:), allocatable :: value + + state = STATE_START + token_type = TOKEN_UNKNOWN + allocate(character(kind=SCK,len=0) :: value) + + read_chars: do + + ! Get next character + this%input_position = this%input_position + 1 + if (this%input_position<=this%input_length) then + if (len(pattern)>=this%input_position) then + next_char = pattern(this%input_position:this%input_position) + next_type = CHAR_TYPE(next_char) + error = new_token(NO_ERROR,"SUCCESS") + else + ! Should never happen + call destroy_token(token) + error = new_token(SYNTAX_ERROR,"END-OF-RECORD reading pattern") + return + endif + else + next_char = "" + next_type = CHAR_EOF + error = new_token(NO_ERROR,"SUCCESS") + end if + + select case (state) + + ! No characters read yet + case (STATE_START) + + select case (next_type) + case (CHAR_EOF) + call destroy_token(token) + error = new_token(EOF_ERROR,"END-OF-FILE encountered") + return + case (CHAR_SPACE) + ! do nothing + case (CHAR_ESCAPING_QUOTE) + token_type = TOKEN_WORD + state = STATE_QUOTING_ESCAPING + case (CHAR_NONESCAPING_QUOTE) + token_type = TOKEN_WORD + state = STATE_QUOTING + case (CHAR_ESCAPE) + token_type = TOKEN_WORD + state = STATE_ESCAPING + case (CHAR_COMMENT) + token_type = TOKEN_COMMENT + state = STATE_COMMENT + case default + token_type = TOKEN_WORD + state = STATE_INWORD + value = value//next_char + end select + + ! Into a regular word + case (STATE_INWORD) + + select case (next_type) + case (CHAR_EOF, CHAR_SPACE) + token = new_token(token_type,value) + return + case (CHAR_ESCAPING_QUOTE) + state = STATE_QUOTING_ESCAPING + case (CHAR_NONESCAPING_QUOTE) + state = STATE_QUOTING + case (CHAR_ESCAPE) + state = STATE_ESCAPING + case default + value = value//next_char + end select + + ! After an escape character + case (STATE_ESCAPING) + + select case (next_type) + case (CHAR_EOF) + ! Error: EOF after an escape character + error = new_token(SYNTAX_ERROR,"END-OF-FILE after an escape character") + token = new_token(token_type,value) + return + case default + state = STATE_INWORD + value = value//next_char + end select + + ! Inside escaping double quotes + case (STATE_ESCAPING_QUOTED) + + select case (next_type) + case (CHAR_EOF) + ! Error: EOF when expecting closing quote + error = new_token(SYNTAX_ERROR,"END-OF-FILE when expecting escaped closing quote") + token = new_token(token_type,value) + return + case default + ! go back to quoting excping + state = STATE_QUOTING_ESCAPING + value = value//next_char + end select + + ! Inside escaping double quotes + case (STATE_QUOTING_ESCAPING) + + select case (next_type) + case (CHAR_EOF) + ! Error: EOF when expecting closing quote + error = new_token(SYNTAX_ERROR,"END-OF-FILE when expecting closing quote") + token = new_token(token_type,value) + return + case (CHAR_ESCAPING_QUOTE) + state = STATE_INWORD + case (CHAR_ESCAPE) + state = STATE_ESCAPING_QUOTED + case default + value = value//next_char + end select + + ! Inside non-escaping single quotes + case (STATE_QUOTING) + + select case (next_type) + case (CHAR_EOF) + ! Error: EOF when expecting closing quote + error = new_token(SYNTAX_ERROR,"END-OF-FILE when expecting closing quote") + token = new_token(token_type,value) + return + case (CHAR_NONESCAPING_QUOTE) + state = STATE_INWORD + case default + value = value//next_char + end select + + ! Inside a comment string + case (STATE_COMMENT) + + select case (next_type) + case (CHAR_EOF) + token = new_token(token_type,value) + return + case (CHAR_SPACE) + + if (next_char==NEWLINE) then + state = STATE_START + token = new_token(token_type,value) + return + else + value = value//next_char + end if + case default + value = value//next_char + end select + + ! Invalid state + case default + error = new_token(SYNTAX_ERROR,"Internal error: invalid state at [["//pattern(1:this%input_position)//']]') + call destroy_token(token) + return + end select + + end do read_chars + + end function scan_stream + + ! Cleanup + elemental subroutine destroy(this) + class(shlex_lexer), intent(inout) :: this + + this%input_length = -1 + this%input_position = 0 + + end subroutine destroy + + ! Initialize lexer + pure subroutine new(this,pattern) + class(shlex_lexer), intent(inout) :: this + character(kind=SCK, len=*), intent(in) :: pattern + + call this%destroy() + + this%input_position = 0 + this%input_length = len(pattern) + + end subroutine new + + function print_token(token) result(msg) + class(shlex_token), intent(in) :: token + character(:,kind=SCK), allocatable :: msg + + character(len=MAX_CHAR_CLASS_LEN,kind=SCK) :: buffer + integer :: lt + + write(buffer,1) token%type,trim(token%string) + + lt = len_trim(buffer) + allocate(character(len=lt,kind=SCK) :: msg) + if (lt>0) msg(1:lt) = buffer(1:lt) + + 1 format('type=',i0,:,1x,'char=',a) + + end function print_token + +end module shlex_module + +!>>>>> ././src/fpm/error.f90 + +!> Implementation of basic error handling. +module fpm_error + use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit + use fpm_strings, only : is_fortran_name, to_fortran_name + implicit none + private + + public :: error_t + public :: fatal_error, syntax_error, file_not_found_error + public :: file_parse_error + public :: bad_name_error + public :: fpm_stop + + !> Data type defining an error + type :: error_t + + !> Error message + character(len=:), allocatable :: message + + end type error_t + +contains + + !> Generic fatal runtime error + subroutine fatal_error(error, message) + + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error + + !> Error message + character(len=*), intent(in) :: message + + allocate(error) + error%message = message + + end subroutine fatal_error + + subroutine syntax_error(error, message) + + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error + + !> Error message + character(len=*), intent(in) :: message + + allocate(error) + error%message = message + + end subroutine syntax_error + + function bad_name_error(error, label,name) + + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error + + !> Error message label to add to message + character(len=*), intent(in) :: label + + !> name value to check + character(len=*), intent(in) :: name + + logical :: bad_name_error + + if(.not.is_fortran_name(to_fortran_name(name)))then + bad_name_error=.true. + allocate(error) + error%message = 'manifest file syntax error: '//label//' name must be composed only of & + &alphanumerics, "-" and "_" and start with a letter ::'//name + else + bad_name_error=.false. + endif + + end function bad_name_error + + !> Error created when a file is missing or not found + subroutine file_not_found_error(error, file_name) + + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error + + !> Name of the missing file + character(len=*), intent(in) :: file_name + + allocate(error) + error%message = "'"//file_name//"' could not be found, check if the file exists" + + end subroutine file_not_found_error + + !> Error created when file parsing fails + subroutine file_parse_error(error, file_name, message, line_num, & + line_string, line_col) + + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error + + !> Name of file + character(len=*), intent(in) :: file_name + + !> Parse error message + character(len=*), intent(in) :: message + + !> Line number of parse error + integer, intent(in), optional :: line_num + + !> Line context string + character(len=*), intent(in), optional :: line_string + + !> Line context column + integer, intent(in), optional :: line_col + + character(50) :: temp_string + + allocate(error) + error%message = 'Parse error: '//message//new_line('a') + + error%message = error%message//file_name + + if (present(line_num)) then + + write(temp_string,'(I0)') line_num + + error%message = error%message//':'//trim(temp_string) + + end if + + if (present(line_col)) then + + if (line_col > 0) then + + write(temp_string,'(I0)') line_col + error%message = error%message//':'//trim(temp_string) + + end if + + end if + + if (present(line_string)) then + + error%message = error%message//new_line('a') + error%message = error%message//' | '//line_string + + if (present(line_col)) then + + if (line_col > 0) then + + error%message = error%message//new_line('a') + error%message = error%message//' | '//repeat(' ',line_col-1)//'^' + + end if + + end if + + end if + + end subroutine file_parse_error + + subroutine fpm_stop(value,message) + ! TODO: if verbose mode, call ERROR STOP instead of STOP + ! TODO: if M_escape is used, add color + ! to work with older compilers might need a case statement for values + + !> value to use on STOP + integer, intent(in) :: value + !> Error message + character(len=*), intent(in) :: message + integer :: iostat + if(message/='')then + flush(unit=stderr,iostat=iostat) + flush(unit=stdout,iostat=iostat) + if(value>0)then + write(stderr,'(" ",a)')trim(message) + else + write(stderr,'(" ",a)')trim(message) + endif + flush(unit=stderr,iostat=iostat) + endif + stop value + end subroutine fpm_stop + +end module fpm_error + +!>>>>> build/dependencies/toml-f/src/tomlf/datetime.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a TOML datetime value +module tomlf_datetime + use tomlf_constants, only : tfc + implicit none + private + + public :: toml_datetime, toml_time, toml_date, to_string, has_date, has_time + public :: operator(==) + + !> TOML time value (HH:MM:SS.sssssZ...) + type :: toml_time + integer :: hour = -1 + integer :: minute = -1 + integer :: second = -1 + integer :: msec = -1 + character(len=:), allocatable :: zone + end type + + interface toml_time + module procedure :: new_toml_time + end interface toml_time + + !> TOML date value (YYYY-MM-DD) + type :: toml_date + integer :: year = -1 + integer :: month = -1 + integer :: day = -1 + end type + + !> TOML datatime value type + type :: toml_datetime + type(toml_date) :: date + type(toml_time) :: time + end type + + !> Create a new TOML datetime value + interface toml_datetime + module procedure :: new_datetime + module procedure :: new_datetime_from_string + end interface toml_datetime + + interface operator(==) + module procedure :: compare_datetime + end interface operator(==) + + interface to_string + module procedure :: to_string_datetime + end interface to_string + +contains + +pure function new_datetime(year, month, day, hour, minute, second, msecond, zone) & + & result(datetime) + integer, intent(in), optional :: year + integer, intent(in), optional :: month + integer, intent(in), optional :: day + integer, intent(in), optional :: hour + integer, intent(in), optional :: minute + integer, intent(in), optional :: second + integer, intent(in), optional :: msecond + character(len=*), intent(in), optional :: zone + type(toml_datetime) :: datetime + + if (present(year) .and. present(month) .and. present(day)) then + datetime%date%year = year + datetime%date%month = month + datetime%date%day = day + end if + + if (present(hour) .and. present(minute) .and. present(second)) then + datetime%time%hour = hour + datetime%time%minute = minute + datetime%time%second = second + if (present(msecond)) then + datetime%time%msec = msecond + end if + if (present(zone)) then + datetime%time%zone = zone + end if + end if +end function new_datetime + +pure function new_datetime_from_string(string) result(datetime) + character(len=*), intent(in) :: string + type(toml_datetime) :: datetime + + type(toml_date) :: date + type(toml_time) :: time + + integer :: it, tmp, first + character(*, tfc), parameter :: num = "0123456789" + integer, allocatable :: msec(:) + + first = 0 + + if (all([string(first+5:first+5), string(first+8:first+8)] == "-")) then + date%year = 0 + do it = first + 1, first + 4 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + date%year = date%year * 10 + tmp + end do + + date%month = 0 + do it = first + 6, first + 7 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + date%month = date%month * 10 + tmp + end do + + date%day = 0 + do it = first + 9, first + 10 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + date%day = date%day * 10 + tmp + end do + + first = first + 11 + datetime%date = date + end if + + if (first >= len(string)) return + if (all([string(first+3:first+3), string(first+6:first+6)] == ":")) then + time%hour = 0 + do it = first + 1, first + 2 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + time%hour = time%hour * 10 + tmp + end do + + time%minute = 0 + do it = first + 4, first + 5 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + time%minute = time%minute * 10 + tmp + end do + + time%second = 0 + do it = first + 7, first + 8 + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + time%second = time%second * 10 + tmp + end do + + first = first + 8 + if (string(first+1:first+1) == ".") then + msec = [integer::] + do it = first + 2, len(string) + tmp = scan(num, string(it:it)) - 1 + if (tmp < 0) exit + msec = [msec, tmp] + end do + first = it - 1 + + msec = [msec, 0, 0, 0, 0, 0, 0] + time%msec = sum(msec(1:6) * [100000, 10000, 1000, 100, 10, 1]) + end if + + if (first < len(string)) then + time%zone = "" + do it = first + 1, len(string) + time%zone = time%zone // string(it:it) + end do + if (time%zone == "z") time%zone = "Z" + end if + datetime%time = time + end if + +end function new_datetime_from_string + +pure function to_string_datetime(datetime) result(str) + type(toml_datetime), intent(in) :: datetime + character(kind=tfc, len=:), allocatable :: str + + str = "" + if (has_date(datetime)) then + str = str // to_string_date(datetime%date) + end if + + if (has_time(datetime)) then + if (has_date(datetime)) then + str = str // ' ' + end if + str = str // to_string_time(datetime%time) + end if +end function to_string_datetime + +pure function to_string_date(date) result(str) + type(toml_date), intent(in) :: date + character(:, tfc), allocatable :: str + + allocate(character(10, tfc) :: str) + write(str, '(i4.4,"-",i2.2,"-",i2.2)') & + & date%year, date%month, date%day +end function to_string_date + +pure function to_string_time(time) result(str) + type(toml_time), intent(in) :: time + character(:, tfc), allocatable :: str + + integer :: msec, width + character(1), parameter :: places(6) = ["1", "2", "3", "4", "5", "6"] + + if (time%msec < 0) then + allocate(character(8, tfc) :: str) + write(str, '(i2.2,":",i2.2,":",i2.2)') & + & time%hour, time%minute, time%second + else + width = 6 + msec = time%msec + do while(mod(msec, 10) == 0 .and. width > 3) + width = width - 1 + msec = msec / 10 + end do + allocate(character(9 + width, tfc) :: str) + write(str, '(i2.2,":",i2.2,":",i2.2,".",i'//places(width)//'.'//places(width)//')') & + & time%hour, time%minute, time%second, msec + end if + if (allocated(time%zone)) str = str // trim(time%zone) +end function to_string_time + +pure function has_date(datetime) + class(toml_datetime), intent(in) :: datetime + logical :: has_date + has_date = (datetime%date%year >= 0) .and. & + & (datetime%date%month >= 0) .and. & + & (datetime%date%day >= 0) +end function has_date + +pure function has_time(datetime) + class(toml_datetime), intent(in) :: datetime + logical :: has_time + has_time = (datetime%time%hour >= 0) .and. & + & (datetime%time%minute >= 0) .and. & + & (datetime%time%second >= 0) +end function has_time + +!> Constructor for toml_time type, necessary due to PGI bug in NVHPC 20.7 and 20.9 +elemental function new_toml_time(hour, minute, second, msec, zone) & + & result(self) + integer, intent(in), optional :: hour + integer, intent(in), optional :: minute + integer, intent(in), optional :: second + integer, intent(in), optional :: msec + character(len=*), intent(in), optional :: zone + type(toml_time) :: self + if (present(hour)) self%hour = hour + if (present(minute)) self%minute = minute + if (present(second)) self%second = second + if (present(msec)) self%msec = msec + if (present(zone)) self%zone = zone +end function new_toml_time + +pure function compare_datetime(lhs, rhs) result(match) + type(toml_datetime), intent(in) :: lhs + type(toml_datetime), intent(in) :: rhs + logical :: match + + match = (has_date(lhs) .eqv. has_date(rhs)) & + & .and. (has_time(lhs) .eqv. has_time(rhs)) + if (has_date(lhs) .and. has_date(rhs)) then + match = match .and. compare_date(lhs%date, rhs%date) + end if + + if (has_time(lhs) .and. has_time(rhs)) then + match = match .and. compare_time(lhs%time, rhs%time) + end if +end function compare_datetime + +pure function compare_date(lhs, rhs) result(match) + type(toml_date), intent(in) :: lhs + type(toml_date), intent(in) :: rhs + logical :: match + + match = lhs%year == rhs%year .and. lhs%month == rhs%month .and. lhs%day == rhs%day +end function compare_date + +pure function compare_time(lhs, rhs) result(match) + type(toml_time), intent(in) :: lhs + type(toml_time), intent(in) :: rhs + logical :: match + + integer :: lms, rms + + lms = max(lhs%msec, 0) + rms = max(rhs%msec, 0) + + match = lhs%hour == rhs%hour .and. lhs%minute == rhs%minute .and. lhs%second == rhs%second & + & .and. lms == rms .and. allocated(lhs%zone) .eqv. allocated(rhs%zone) + + if (allocated(lhs%zone) .and. allocated(rhs%zone)) then + match = match .and. lhs%zone == rhs%zone + end if +end function compare_time + +end module tomlf_datetime + +!>>>>> build/dependencies/toml-f/src/tomlf/error.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Central registry for error codes +module tomlf_error + use tomlf_constants, only : tfc, TOML_NEWLINE + implicit none + private + + public :: toml_stat, toml_error, make_error + + !> Possible TOML-Fortran error codes + type :: enum_stat + + !> Successful run + integer :: success = 0 + + !> Internal error: + !> + !> General undefined error state, usually caused by algorithmic errors. + integer :: fatal = -1 + + !> Duplicate key encountered + integer :: duplicate_key = -2 + + !> Incorrect type when reading a value + integer :: type_mismatch = -3 + + !> Conversion error when downcasting a value + integer :: conversion_error = -4 + + !> Key not present in table + integer :: missing_key = -5 + + end type enum_stat + + !> Actual enumerator for return states + type(enum_stat), parameter :: toml_stat = enum_stat() + + !> Error message produced by TOML-Fortran + type :: toml_error + + !> Error code + integer :: stat = toml_stat%fatal + + !> Payload of the error + character(kind=tfc, len=:), allocatable :: message + + end type toml_error + +contains + +!> Create new error message +subroutine make_error(error, message, stat) + !> Error report + type(toml_error), allocatable, intent(out) :: error + !> Message for the error + character(*, tfc), intent(in) :: message + !> Status code + integer, intent(in), optional :: stat + + allocate(error) + error%message = message + if (present(stat)) then + error%stat = stat + else + error%stat = toml_stat%fatal + end if +end subroutine make_error + +end module tomlf_error + +!>>>>> build/dependencies/toml-f/src/tomlf/utils/io.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Utilities for handling input and output operations +module tomlf_utils_io + use tomlf_constants, only : tfc + implicit none + private + + public :: read_whole_file, read_whole_line + +contains + +!> Read a whole file into an array of characters +subroutine read_whole_file(filename, string, stat) + !> File to read + character(*, tfc), intent(in) :: filename + !> Array of characters representing the file + character(:, tfc), allocatable, intent(out) :: string + !> Error status + integer, intent(out) :: stat + + integer :: io, length + + open(file=filename, & + & status="old", & + & access="stream", & + & position="append", & + & newunit=io, & + & iostat=stat) + if (stat == 0) then + inquire(unit=io, pos=length) + allocate(character(length-1, tfc) :: string, stat=stat) + end if + if (stat == 0) then + read(io, pos=1, iostat=stat) string(:length-1) + end if + if (stat == 0) then + close(io) + end if +end subroutine read_whole_file + +!> Read a whole line from a formatted unit into a deferred length character variable +subroutine read_whole_line(io, string, stat) + !> Formatted IO unit + integer, intent(in) :: io + !> Line to read + character(:, tfc), allocatable, intent(out) :: string + !> Status of operation + integer, intent(out) :: stat + + integer, parameter :: bufsize = 4096 + character(bufsize, tfc) :: buffer, msg + integer :: chunk + logical :: opened + + if (io /= -1) then + inquire(unit=io, opened=opened) + else + opened = .false. + end if + + if (opened) then + open(unit=io, pad="yes", iostat=stat) + else + stat = 1 + msg = "Unit is not connected" + end if + + string = "" + do while (stat == 0) + read(io, '(a)', advance='no', iostat=stat, size=chunk) buffer + if (stat > 0) exit + string = string // buffer(:chunk) + end do + if (is_iostat_eor(stat)) stat = 0 +end subroutine read_whole_line + +end module tomlf_utils_io + +!>>>>> ././src/fpm_environment.f90 + +!> This module contains procedures that interact with the programming environment. +!! +!! * [get_os_type] -- Determine the OS type +!! * [get_env] -- return the value of an environment variable +module fpm_environment + use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & + & stdout=>output_unit, & + & stderr=>error_unit + use,intrinsic :: iso_c_binding, only: c_char,c_int,c_null_char + use fpm_error, only : fpm_stop + 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 + integer, parameter, public :: OS_LINUX = 1 + integer, parameter, public :: OS_MACOS = 2 + integer, parameter, public :: OS_WINDOWS = 3 + integer, parameter, public :: OS_CYGWIN = 4 + integer, parameter, public :: OS_SOLARIS = 5 + integer, parameter, public :: OS_FREEBSD = 6 + integer, parameter, public :: OS_OPENBSD = 7 +contains + + !> Return string describing the OS type flag + pure function OS_NAME(os) + integer, intent(in) :: os + character(len=:), allocatable :: OS_NAME + + select case (os) + case (OS_LINUX); OS_NAME = "Linux" + case (OS_MACOS); OS_NAME = "macOS" + case (OS_WINDOWS); OS_NAME = "Windows" + case (OS_CYGWIN); OS_NAME = "Cygwin" + case (OS_SOLARIS); OS_NAME = "Solaris" + case (OS_FREEBSD); OS_NAME = "FreeBSD" + case (OS_OPENBSD); OS_NAME = "OpenBSD" + case (OS_UNKNOWN); OS_NAME = "Unknown" + case default ; OS_NAME = "UNKNOWN" + end select + end function OS_NAME + + !> Determine the OS type + integer function get_os_type() result(r) + !! + !! Returns one of OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, OS_CYGWIN, + !! OS_SOLARIS, OS_FREEBSD, OS_OPENBSD. + !! + !! At first, the environment variable `OS` is checked, which is usually + !! found on Windows. Then, `OSTYPE` is read in and compared with common + !! names. If this fails too, check the existence of files that can be + !! found on specific system types only. + !! + !! Returns OS_UNKNOWN if the operating system cannot be determined. + character(len=255) :: val + integer :: length, rc + logical :: file_exists + logical, save :: first_run = .true. + integer, save :: ret = OS_UNKNOWN + !$omp threadprivate(ret, first_run) + + if (.not. first_run) then + r = ret + return + end if + + first_run = .false. + r = OS_UNKNOWN + + ! Check environment variable `OSTYPE`. + call get_environment_variable('OSTYPE', val, length, rc) + + if (rc == 0 .and. length > 0) then + ! Linux + if (index(val, 'linux') > 0) then + r = OS_LINUX + ret = r + return + end if + + ! macOS + if (index(val, 'darwin') > 0) then + r = OS_MACOS + ret = r + return + end if + + ! Windows, MSYS, MinGW, Git Bash + if (index(val, 'win') > 0 .or. index(val, 'msys') > 0) then + r = OS_WINDOWS + ret = r + return + end if + + ! Cygwin + if (index(val, 'cygwin') > 0) then + r = OS_CYGWIN + ret = r + return + end if + + ! Solaris, OpenIndiana, ... + if (index(val, 'SunOS') > 0 .or. index(val, 'solaris') > 0) then + r = OS_SOLARIS + ret = r + return + end if + + ! FreeBSD + if (index(val, 'FreeBSD') > 0 .or. index(val, 'freebsd') > 0) then + r = OS_FREEBSD + ret = r + return + end if + + ! OpenBSD + if (index(val, 'OpenBSD') > 0 .or. index(val, 'openbsd') > 0) then + r = OS_OPENBSD + ret = r + return + end if + end if + + ! Check environment variable `OS`. + call get_environment_variable('OS', val, length, rc) + + if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then + r = OS_WINDOWS + ret = r + return + end if + + ! Linux + inquire (file='/etc/os-release', exist=file_exists) + + if (file_exists) then + r = OS_LINUX + ret = r + return + end if + + ! macOS + inquire (file='/usr/bin/sw_vers', exist=file_exists) + + if (file_exists) then + r = OS_MACOS + ret = r + return + end if + + ! FreeBSD + inquire (file='/bin/freebsd-version', exist=file_exists) + + if (file_exists) then + r = OS_FREEBSD + ret = r + return + end if + end function get_os_type + + !> Compare the output of [[get_os_type]] or the optional + !! passed INTEGER value to the value for OS_WINDOWS + !! and return .TRUE. if they match and .FALSE. otherwise + logical function os_is_unix(os) + integer, intent(in), optional :: os + integer :: build_os + if (present(os)) then + build_os = os + else + build_os = get_os_type() + end if + os_is_unix = build_os /= OS_WINDOWS + end function os_is_unix + + !> get named environment variable value. It it is blank or + !! not set return the optional default value + function get_env(NAME,DEFAULT) result(VALUE) + implicit none + !> name of environment variable to get the value of + character(len=*),intent(in) :: NAME + !> default value to return if the requested value is undefined or blank + character(len=*),intent(in),optional :: DEFAULT + !> the returned value + character(len=:),allocatable :: VALUE + integer :: howbig + integer :: stat + integer :: length + ! get length required to hold value + length=0 + if(NAME/='')then + call get_environment_variable(NAME, length=howbig,status=stat,trim_name=.true.) + select case (stat) + case (1) + !*!print *, NAME, " is not defined in the environment. Strange..." + VALUE='' + case (2) + !*!print *, "This processor doesn't support environment variables. Boooh!" + VALUE='' + case default + ! make string to hold value of sufficient size + allocate(character(len=max(howbig,1)) :: VALUE) + ! get value + call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.) + if(stat/=0)VALUE='' + end select + else + VALUE='' + endif + if(VALUE==''.and.present(DEFAULT))VALUE=DEFAULT + end function get_env + + function get_command_arguments_quoted() result(args) + character(len=:),allocatable :: args + character(len=:),allocatable :: arg + character(len=1) :: quote + integer :: ilength, istatus, i + ilength=0 + args='' + quote=merge('"',"'",separator()=='\') + do i=2,command_argument_count() ! look at all arguments after subcommand + call get_command_argument(number=i,length=ilength,status=istatus) + if(istatus /= 0) then + write(stderr,'(*(g0,1x))')'*get_command_arguments_stack* error obtaining argument ',i + exit + else + if(allocated(arg))deallocate(arg) + allocate(character(len=ilength) :: arg) + call get_command_argument(number=i,value=arg,length=ilength,status=istatus) + if(istatus /= 0) then + write(stderr,'(*(g0,1x))')'*get_command_arguments_stack* error obtaining argument ',i + exit + elseif(ilength>0)then + if(index(arg//' ','-')/=1)then + args=args//quote//arg//quote//' ' + elseif(index(arg,' ')/=0)then + args=args//quote//arg//quote//' ' + else + args=args//arg//' ' + endif + else + args=args//repeat(quote,2)//' ' + endif + endif + enddo + end function get_command_arguments_quoted + +function separator() result(sep) +!> +!!##NAME +!! separator(3f) - [M_io:ENVIRONMENT] try to determine pathname directory separator character +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! function separator() result(sep) +!! +!! character(len=1) :: sep +!! +!!##DESCRIPTION +!! First using the name the program was invoked with, then the name +!! returned by an INQUIRE(3f) of that name, then ".\NAME" and "./NAME" +!! try to determine the separator character used to separate directory +!! names from file basenames. +!! +!! If a slash or backslash is not found in the name, the environment +!! variable PATH is examined first for a backslash, then a slash. +!! +!! Can be very system dependent. If the queries fail the default returned +!! is "/". +!! +!!##EXAMPLE +!! +!! sample usage +!! +!! program demo_separator +!! use M_io, only : separator +!! implicit none +!! write(*,*)'separator=',separator() +!! end program demo_separator + +! use the pathname returned as arg0 to determine pathname separator +implicit none +character(len=:),allocatable :: arg0 +integer :: arg0_length +integer :: istat +logical :: existing +character(len=1) :: sep +!*ifort_bug*!character(len=1),save :: sep_cache=' ' +character(len=4096) :: name +character(len=:),allocatable :: fname + + !*ifort_bug*! if(sep_cache/=' ')then ! use cached value. NOTE: A parallel code might theoretically use multiple OS + !*ifort_bug*! sep=sep_cache + !*ifort_bug*! return + !*ifort_bug*! endif + + arg0_length=0 + name=' ' + call get_command_argument(0,length=arg0_length,status=istat) + if(allocated(arg0))deallocate(arg0) + allocate(character(len=arg0_length) :: arg0) + call get_command_argument(0,arg0,status=istat) + ! check argument name + if(index(arg0,'\')/=0)then + sep='\' + elseif(index(arg0,'/')/=0)then + sep='/' + else + ! try name returned by INQUIRE(3f) + existing=.false. + name=' ' + inquire(file=arg0,iostat=istat,exist=existing,name=name) + if(index(name,'\')/=0)then + sep='\' + elseif(index(name,'/')/=0)then + sep='/' + else + ! well, try some common syntax and assume in current directory + fname='.\'//arg0 + inquire(file=fname,iostat=istat,exist=existing) + if(existing)then + sep='\' + else + fname='./'//arg0 + inquire(file=fname,iostat=istat,exist=existing) + if(existing)then + sep='/' + else ! check environment variable PATH + sep=merge('\','/',index(get_env('PATH'),'\')/=0) + !*!write(*,*)'unknown system directory path separator' + endif + endif + endif + endif + !*ifort_bug*!sep_cache=sep +end function separator + +!> Set an environment variable for the current environment using the C standard library +logical function set_env(name,value,overwrite) + + !> Variable name + character(*), intent(in) :: name + + !> Variable value + character(*), intent(in) :: value + + !> Should a former value be overwritten? default = .true. + logical, optional, intent(in) :: overwrite + + ! Local variables + logical :: can_overwrite + integer(c_int) :: cover,cerr + character(kind=c_char,len=1), allocatable :: c_value(:),c_name(:) + + interface + integer(c_int) function c_setenv(envname, envval, overwrite) & + bind(C,name="c_setenv") + import c_int, c_char + implicit none + !> Pointer to the name string + character(kind=c_char,len=1), intent(in) :: envname(*) + !> Pointer to the value string + character(kind=c_char,len=1), intent(in) :: envval(*) + !> Overwrite option + integer(c_int), intent(in), value :: overwrite + end function c_setenv + end interface + + !> Overwrite setting + 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 + + cerr = c_setenv(c_name,c_value,cover) + + 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 + + cerr = c_unsetenv(c_name) + + 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 + +!>>>>> ././src/fpm/versioning.f90 + +!> Implementation of versioning data for comparing packages +module fpm_versioning + use fpm_error, only : error_t, syntax_error + use fpm_strings, only: string_t + use regex_module, only: regex + implicit none + private + + public :: version_t, new_version + public :: regex_version_from_text + + type :: version_t + private + + !> Version numbers found + integer, allocatable :: num(:) + + contains + + generic :: operator(==) => equals + procedure, private :: equals + + generic :: operator(/=) => not_equals + procedure, private :: not_equals + + generic :: operator(>) => greater + procedure, private :: greater + + generic :: operator(<) => less + procedure, private :: less + + generic :: operator(>=) => greater_equals + procedure, private :: greater_equals + + generic :: operator(<=) => less_equals + procedure, private :: less_equals + + !> Compare a version against a version constraint (x.x.0 <= v < x.x.HUGE) + generic :: operator(.match.) => match + procedure, private :: match + + !> Create a printable string from a version data type + procedure :: s + + end type version_t + + !> Arbitrary internal limit of the version parser + integer, parameter :: max_limit = 3 + + interface new_version + module procedure :: new_version_from_string + module procedure :: new_version_from_int + end interface new_version + +contains + + !> Create a new version from a string + subroutine new_version_from_int(self, num) + + !> Instance of the versioning data + type(version_t), intent(out) :: self + + !> Subversion numbers to define version data + integer, intent(in) :: num(:) + + self%num = num + + end subroutine new_version_from_int + + !> Create a new version from a string + subroutine new_version_from_string(self, string, error) + + !> Instance of the versioning data + type(version_t), intent(out) :: self + + !> String describing the version information + character(len=*), intent(in) :: string + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: istart, iend, stat, nn + integer :: num(max_limit) + logical :: is_number + + nn = 0 + iend = 0 + istart = 0 + is_number = .false. + + do while(iend < len(string)) + call next(string, istart, iend, is_number, error) + if (allocated(error)) exit + if (is_number) then + if (nn >= max_limit) then + call token_error(error, string, istart, iend, & + & "Too many subversions found") + exit + end if + nn = nn + 1 + read(string(istart:iend), *, iostat=stat) num(nn) + if (stat /= 0) then + call token_error(error, string, istart, iend, & + & "Failed to parse version number") + exit + end if + end if + end do + if (allocated(error)) return + if (.not.is_number) then + call token_error(error, string, istart, iend, & + & "Expected version number, but no characters are left") + return + end if + + call new_version(self, num(:nn)) + + end subroutine new_version_from_string + + !> Tokenize a version string + subroutine next(string, istart, iend, is_number, error) + + !> String describing the version information + character(len=*), intent(in) :: string + + !> Start of last token, start of next token on exit + integer, intent(inout) :: istart + + !> End of last token on entry, end of next token on exit + integer, intent(inout) :: iend + + !> Token produced is a number + logical, intent(inout) :: is_number + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ii, nn + logical :: was_number + character :: tok + + was_number = is_number + nn = len(string) + + if (iend >= nn) then + istart = nn + iend = nn + return + end if + + ii = min(iend + 1, nn) + tok = string(ii:ii) + + is_number = tok /= '.' + if (is_number .eqv. was_number) then + call token_error(error, string, istart, ii, & + & "Unexpected token found") + return + end if + + if (.not.is_number) then + is_number = .false. + istart = ii + iend = ii + return + end if + + istart = ii + do ii = min(iend + 1, nn), nn + tok = string(ii:ii) + select case(tok) + case default + call token_error(error, string, istart, ii, & + & "Invalid character in version number") + exit + case('.') + exit + case('0', '1', '2', '3', '4', '5', '6', '7', '8', '9') + iend = ii + cycle + end select + end do + + end subroutine next + + !> Create an error on an invalid token, provide some visual context as well + subroutine token_error(error, string, istart, iend, message) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> String describing the version information + character(len=*), intent(in) :: string + + !> Start of last token, start of next token on exit + integer, intent(in) :: istart + + !> End of last token on entry, end of next token on exit + integer, intent(in) :: iend + + !> Error message + character(len=*), intent(in) :: message + + character(len=*), parameter :: nl = new_line('a') + + allocate(error) + error%message = message // nl // " | " // string // nl // & + & " |" // repeat('-', istart) // repeat('^', iend - istart + 1) + + end subroutine token_error + + pure function s(self) result(string) + + !> Version number + class(version_t), intent(in) :: self + + !> Character representation of the version + character(len=:), allocatable :: string + + integer, parameter :: buffersize = 64 + character(len=buffersize) :: buffer + integer :: ii + + do ii = 1, ndigits(self) + if (allocated(string)) then + write(buffer, '(".", i0)') self%num(ii) + string = string // trim(buffer) + else + write(buffer, '(i0)') self%num(ii) + string = trim(buffer) + end if + end do + + if (.not.allocated(string)) then + string = '0' + end if + + end function s + + !> Check to version numbers for equality + elemental function equals(lhs, rhs) result(is_equal) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> Version match + logical :: is_equal + + is_equal = .not.(lhs > rhs) + if (is_equal) then + is_equal = .not.(rhs > lhs) + end if + + end function equals + + !> Check two versions for inequality + elemental function not_equals(lhs, rhs) result(not_equal) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> Version mismatch + logical :: not_equal + + not_equal = lhs > rhs + if (.not.not_equal) then + not_equal = rhs > lhs + end if + + end function not_equals + + !> Relative comparison of two versions + elemental function greater(lhs, rhs) result(is_greater) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> First version is greater + logical :: is_greater + + integer :: ii, lhs_size, rhs_size + + do ii = 1, min(ndigits(lhs),ndigits(rhs)) + if (lhs%num(ii) /= rhs%num(ii)) then + is_greater = lhs%num(ii) > rhs%num(ii) + return + end if + end do + + is_greater = ndigits(lhs) > ndigits(rhs) + if (is_greater) then + do ii = ndigits(rhs) + 1, ndigits(lhs) + is_greater = lhs%num(ii) > 0 + if (is_greater) return + end do + end if + + end function greater + + !> Relative comparison of two versions + elemental function less(lhs, rhs) result(is_less) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> First version is less + logical :: is_less + + is_less = rhs > lhs + + end function less + + !> Relative comparison of two versions + elemental function greater_equals(lhs, rhs) result(is_greater_equal) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> First version is greater or equal + logical :: is_greater_equal + + is_greater_equal = .not. (rhs > lhs) + + end function greater_equals + + !> Relative comparison of two versions + elemental function less_equals(lhs, rhs) result(is_less_equal) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> First version is less or equal + logical :: is_less_equal + + is_less_equal = .not. (lhs > rhs) + + end function less_equals + + !> Try to match first version against second version + elemental function match(lhs, rhs) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> Version match following semantic versioning rules + logical :: match + + type(version_t) :: tmp + + match = .not.(rhs > lhs) + if (match) then + tmp%num = rhs%num + tmp%num(size(tmp%num)) = tmp%num(size(tmp%num)) + 1 + match = tmp > lhs + end if + + end function match + + !> Number of digits + elemental integer function ndigits(self) + class(version_t), intent(in) :: self + + if (allocated(self%num)) then + ndigits = size(self%num) + else + ndigits = 0 + end if + + end function ndigits + + ! Extract canonical version flags "1.0.0" or "1.0" as the first instance inside a text + ! (whatever long) using regex + type(string_t) function regex_version_from_text(text,what,error) result(ver) + character(*), intent(in) :: text + character(*), intent(in) :: what + type(error_t), allocatable, intent(out) :: error + + integer :: ire, length + + if (len_trim(text)<=0) then + call syntax_error(error,'cannot retrieve '//what//' version: empty input string') + return + end if + + ! Extract 3-sized version "1.0.4" + ire = regex(text,'\d+\.\d+\.\d+',length=length) + if (ire>0 .and. length>0) then + ! Parse version into the object (this should always work) + ver = string_t(text(ire:ire+length-1)) + else + + ! Try 2-sized version "1.0" + ire = regex(text,'\d+\.\d+',length=length) + + if (ire>0 .and. length>0) then + ver = string_t(text(ire:ire+length-1)) + else + call syntax_error(error,'cannot retrieve '//what//' version.') + end if + + end if + + end function regex_version_from_text + +end module fpm_versioning + +!>>>>> build/dependencies/toml-f/src/tomlf/utils.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +module tomlf_utils + use tomlf_constants + use tomlf_datetime, only : toml_datetime, toml_date, toml_time, to_string + use tomlf_utils_io, only : read_whole_file, read_whole_line + implicit none + private + + public :: toml_escape_string + public :: to_string + public :: read_whole_file, read_whole_line + + interface to_string + module procedure :: to_string_i1 + module procedure :: to_string_i2 + module procedure :: to_string_i4 + module procedure :: to_string_i8 + module procedure :: to_string_r8 + end interface to_string + +contains + +!> Escape all special characters in a TOML string +subroutine toml_escape_string(raw, escaped, multiline) + + !> Raw representation of TOML string + character(kind=tfc, len=*), intent(in) :: raw + + !> Escaped view of the TOML string + character(kind=tfc, len=:), allocatable, intent(out) :: escaped + + !> Preserve newline characters + logical, intent(in), optional :: multiline + + integer :: i + logical :: preserve_newline + + preserve_newline = .false. + if (present(multiline)) preserve_newline = multiline + + escaped = '"' + do i = 1, len(raw) + select case(raw(i:i)) + case default; escaped = escaped // raw(i:i) + case('\'); escaped = escaped // '\\' + case('"'); escaped = escaped // '\"' + case(TOML_NEWLINE) + if (preserve_newline) then + escaped = escaped // raw(i:i) + else + escaped = escaped // '\n' + end if + case(TOML_FORMFEED); escaped = escaped // '\f' + case(TOML_CARRIAGE_RETURN); escaped = escaped // '\r' + case(TOML_TABULATOR); escaped = escaped // '\t' + case(TOML_BACKSPACE); escaped = escaped // '\b' + end select + end do + escaped = escaped // '"' + +end subroutine toml_escape_string + +!> Represent an integer as character sequence. +pure function to_string_i1(val) result(string) + integer, parameter :: ik = tf_i1 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) +end function to_string_i1 + +!> Represent an integer as character sequence. +pure function to_string_i2(val) result(string) + integer, parameter :: ik = tf_i2 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) +end function to_string_i2 + +!> Represent an integer as character sequence. +pure function to_string_i4(val) result(string) + integer, parameter :: ik = tf_i4 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) +end function to_string_i4 + +!> Represent an integer as character sequence. +pure function to_string_i8(val) result(string) + integer, parameter :: ik = tf_i8 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) +end function to_string_i8 + +!> Represent an real as character sequence. +pure function to_string_r8(val) result(string) + integer, parameter :: rk = tfr + !> Real value to create string from + real(rk), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + character(128, tfc) :: buffer + + if (val > huge(val)) then + string = "+inf" + else if (val < -huge(val)) then + string = "-inf" + else if (val /= val) then + string = "nan" + else + if (abs(val) >= 1.0e+100_rk) then + write(buffer, '(es24.16e3)') val + else if (abs(val) >= 1.0e+10_rk) then + write(buffer, '(es24.16e2)') val + else if (abs(val) >= 1.0e+3_rk) then + write(buffer, '(es24.16e1)') val + else + write(buffer, '(f24.16)') val + end if + string = trim(adjustl(buffer)) + end if +end function to_string_r8 + +end module tomlf_utils + +!>>>>> build/dependencies/toml-f/src/tomlf/de/abc.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Defines the abstract base class which is implemented by the TOML lexer. +module tomlf_de_abc + use tomlf_constants, only : tfc, tfi, tfr + use tomlf_datetime, only : toml_datetime + use tomlf_de_token, only : toml_token + implicit none + private + + public :: abstract_lexer + + !> Abstract base class for TOML lexers. + type, abstract :: abstract_lexer + contains + !> Obtain the next token + procedure(next), deferred :: next + !> Extract a token + generic :: extract => & + & extract_string, extract_integer, extract_float, extract_bool, extract_datetime + !> Extract a string from a token + procedure(extract_string), deferred :: extract_string + !> Extract an integer from a token + procedure(extract_integer), deferred :: extract_integer + !> Extract a float from a token + procedure(extract_float), deferred :: extract_float + !> Extract a boolean from a token + procedure(extract_bool), deferred :: extract_bool + !> Extract a timestamp from a token + procedure(extract_datetime), deferred :: extract_datetime + !> Get information about the source + procedure(get_info), deferred :: get_info + end type abstract_lexer + + abstract interface + !> Advance the lexer to the next token. + subroutine next(lexer, token) + import :: abstract_lexer, toml_token + !> Instance of the lexer + class(abstract_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + end subroutine next + + !> Extract string value of token, works for keypath, string, multiline string, literal, + !> and mulitline literal tokens. + subroutine extract_string(lexer, token, string) + import :: abstract_lexer, toml_token, tfc + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract string value from + type(toml_token), intent(in) :: token + !> String value of token + character(:, tfc), allocatable, intent(out) :: string + end subroutine extract_string + + !> Extract integer value of token + subroutine extract_integer(lexer, token, val) + import :: abstract_lexer, toml_token, tfi + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract integer value from + type(toml_token), intent(in) :: token + !> Integer value of token + integer(tfi), intent(out) :: val + end subroutine extract_integer + + !> Extract floating point value of token + subroutine extract_float(lexer, token, val) + import :: abstract_lexer, toml_token, tfr + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract floating point value from + type(toml_token), intent(in) :: token + !> Floating point value of token + real(tfr), intent(out) :: val + end subroutine extract_float + + !> Extract boolean value of token + subroutine extract_bool(lexer, token, val) + import :: abstract_lexer, toml_token + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract boolean value from + type(toml_token), intent(in) :: token + !> Boolean value of token + logical, intent(out) :: val + end subroutine extract_bool + + !> Extract datetime value of token + subroutine extract_datetime(lexer, token, val) + import :: abstract_lexer, toml_token, toml_datetime + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Token to extract datetime value from + type(toml_token), intent(in) :: token + !> Datetime value of token + type(toml_datetime), intent(out) :: val + end subroutine extract_datetime + + !> Extract information about the source + subroutine get_info(lexer, meta, output) + import :: abstract_lexer, tfc + !> Instance of the lexer + class(abstract_lexer), intent(in) :: lexer + !> Query about the source + character(*, tfc), intent(in) :: meta + !> Metadata about the source + character(:, tfc), allocatable, intent(out) :: output + end subroutine get_info + end interface + +end module tomlf_de_abc + +!>>>>> ././src/fpm_filesystem.F90 + +!> This module contains general routines for interacting with the file system +!! +module fpm_filesystem + use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit + use,intrinsic :: iso_c_binding, only: c_new_line + use fpm_environment, only: get_os_type, & + OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & + OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD + use fpm_environment, only: separator, get_env, os_is_unix + use fpm_strings, only: f_string, replace, string_t, split, split_first_last, dilate, str_begins_with_str + use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer + use fpm_error, only : fpm_stop, error_t, fatal_error + implicit none + private + public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, list_files, get_local_prefix, & + mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, fileopen, fileclose, & + filewrite, warnwrite, parent_dir, is_hidden_file, read_lines, read_lines_expanded, which, run, & + os_delete_dir, is_absolute_path, get_home, execute_and_read_output, get_dos_path + + interface + function c_opendir(dir) result(r) bind(c, name="c_opendir") + import c_char, c_ptr + character(kind=c_char), intent(in) :: dir(*) + type(c_ptr) :: r + end function c_opendir + + function c_readdir(dir) result(r) bind(c, name="c_readdir") + import c_ptr + type(c_ptr), intent(in), value :: dir + type(c_ptr) :: r + end function c_readdir + + function c_closedir(dir) result(r) bind(c, name="closedir") + import c_ptr, c_int + type(c_ptr), intent(in), value :: dir + integer(kind=c_int) :: r + end function c_closedir + + function c_get_d_name(dir) result(r) bind(c, name="get_d_name") + import c_ptr + type(c_ptr), intent(in), value :: dir + type(c_ptr) :: r + end function c_get_d_name + + function c_is_dir(path) result(r) bind(c, name="c_is_dir") + import c_char, c_int + character(kind=c_char), intent(in) :: path(*) + integer(kind=c_int) :: r + end function c_is_dir + end interface + + character(*), parameter :: eol = new_line('a') !! End of line + +contains + +!> Extract filename from path with/without suffix +function basename(path,suffix) result (base) + + character(*), intent(In) :: path + logical, intent(in), optional :: suffix + character(:), allocatable :: base + + character(:), allocatable :: file_parts(:) + logical :: with_suffix + + if (.not.present(suffix)) then + with_suffix = .true. + else + with_suffix = suffix + end if + + call split(path,file_parts,delimiters='\/') + if(size(file_parts)>0)then + base = trim(file_parts(size(file_parts))) + else + base = '' + endif + if(.not.with_suffix)then + call split(base,file_parts,delimiters='.') + if(size(file_parts)>=2)then + base = trim(file_parts(size(file_parts)-1)) + endif + endif + +end function basename + +!> Canonicalize path for comparison +!! * Handles path string redundancies +!! * Does not test existence of path +!! +!! To be replaced by realpath/_fullname in stdlib_os +!! +!! FIXME: Lot's of ugly hacks following here +function canon_path(path) + character(len=*), intent(in) :: path + character(len=:), allocatable :: canon_path + character(len=:), allocatable :: nixpath + + integer :: istart, iend, nn, last + logical :: is_path, absolute + + nixpath = unix_path(path) + + istart = 0 + nn = 0 + iend = 0 + absolute = nixpath(1:1) == "/" + if (absolute) then + canon_path = "/" + else + canon_path = "" + end if + + do while(iend < len(nixpath)) + call next(nixpath, istart, iend, is_path) + if (is_path) then + select case(nixpath(istart:iend)) + case(".", "") ! always drop empty paths + case("..") + if (nn > 0) then + last = scan(canon_path(:len(canon_path)-1), "/", back=.true.) + canon_path = canon_path(:last) + nn = nn - 1 + else + if (.not. absolute) then + canon_path = canon_path // nixpath(istart:iend) // "/" + end if + end if + case default + nn = nn + 1 + canon_path = canon_path // nixpath(istart:iend) // "/" + end select + end if + end do + + if (len(canon_path) == 0) canon_path = "." + if (len(canon_path) > 1 .and. canon_path(len(canon_path):) == "/") then + canon_path = canon_path(:len(canon_path)-1) + end if + +contains + + subroutine next(string, istart, iend, is_path) + character(len=*), intent(in) :: string + integer, intent(inout) :: istart + integer, intent(inout) :: iend + logical, intent(inout) :: is_path + + integer :: ii, nn + character :: tok + + nn = len(string) + + if (iend >= nn) then + istart = nn + iend = nn + return + end if + + ii = min(iend + 1, nn) + tok = string(ii:ii) + + is_path = tok /= '/' + + if (.not.is_path) then + is_path = .false. + istart = ii + iend = ii + return + end if + + istart = ii + do ii = min(iend + 1, nn), nn + tok = string(ii:ii) + select case(tok) + case('/') + exit + case default + iend = ii + cycle + end select + end do + + end subroutine next +end function canon_path + +!> Extract dirname from path +function dirname(path) result (dir) + character(*), intent(in) :: path + character(:), allocatable :: dir + + dir = path(1:scan(path,'/\',back=.true.)) + +end function dirname + +!> Extract dirname from path +function parent_dir(path) result (dir) + character(*), intent(in) :: path + character(:), allocatable :: dir + + dir = path(1:scan(path,'/\',back=.true.)-1) + +end function parent_dir + +!> test if a name matches an existing directory path +logical function is_dir(dir) + character(*), intent(in) :: dir + integer :: stat + + select case (get_os_type()) + + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) + call run( "test -d " // dir , & + & exitstat=stat,echo=.false.,verbose=.false.) + + case (OS_WINDOWS) + call run('cmd /c "if not exist ' // windows_path(dir) // '\ exit /B 1"', & + & exitstat=stat,echo=.false.,verbose=.false.) + + end select + + is_dir = (stat == 0) + +end function is_dir + +!> test if a file is hidden +logical function is_hidden_file(file_basename) result(r) + character(*), intent(in) :: file_basename + if (len(file_basename) <= 2) then + r = .false. + else + r = str_begins_with_str(file_basename, '.') + end if +end function is_hidden_file + +!> Construct path by joining strings with os file separator +function join_path(a1,a2,a3,a4,a5) result(path) + + character(len=*), intent(in) :: a1, a2 + character(len=*), intent(in), optional :: a3, a4, a5 + character(len=:), allocatable :: path + character(len=1) :: filesep + logical, save :: has_cache = .false. + character(len=1), save :: cache = '/' + !$omp threadprivate(has_cache, cache) + + if (has_cache) then + filesep = cache + else + select case (get_os_type()) + case default + filesep = '/' + case (OS_WINDOWS) + filesep = '\' + end select + + cache = filesep + has_cache = .true. + end if + + if (a1 == "") then + path = a2 + else + path = a1 // filesep // a2 + end if + + if (present(a3)) then + path = path // filesep // a3 + else + return + end if + + if (present(a4)) then + path = path // filesep // a4 + else + return + end if + + if (present(a5)) then + path = path // filesep // a5 + else + return + end if + +end function join_path + +!> Determine number or rows in a file given a LUN +integer function number_of_rows(s) result(nrows) + integer,intent(in)::s + integer :: ios + rewind(s) + nrows = 0 + do + read(s, *, iostat=ios) + if (ios /= 0) exit + nrows = nrows + 1 + end do + rewind(s) +end function number_of_rows + +!> read lines into an array of TYPE(STRING_T) variables expanding tabs +function read_lines_expanded(filename) result(lines) + character(len=*), intent(in) :: filename + type(string_t), allocatable :: lines(:) + + integer :: i + character(len=:), allocatable :: content + integer, allocatable :: first(:), last(:) + + content = read_text_file(filename) + if (len(content) == 0) then + allocate (lines(0)) + return + end if + + call split_first_last(content, eol, first, last) ! TODO: \r (< macOS X), \n (>=macOS X/Linux/Unix), \r\n (Windows) + + ! allocate lines from file content string + allocate (lines(size(first))) + do i = 1, size(first) + allocate(lines(i)%s, source=dilate(content(first(i):last(i)))) + end do + +end function read_lines_expanded + +!> read lines into an array of TYPE(STRING_T) variables +function read_lines(filename) result(lines) + character(len=*), intent(in) :: filename + type(string_t), allocatable :: lines(:) + + integer :: i + character(len=:), allocatable :: content + integer, allocatable :: first(:), last(:) + + content = read_text_file(filename) + if (len(content) == 0) then + allocate (lines(0)) + return + end if + + call split_first_last(content, eol, first, last) ! TODO: \r (< macOS X), \n (>=macOS X/Linux/Unix), \r\n (Windows) + + ! allocate lines from file content string + allocate (lines(size(first))) + do i = 1, size(first) + allocate(lines(i)%s, source=content(first(i):last(i))) + end do + +end function read_lines + +!> read text file into a string +function read_text_file(filename) result(string) + character(len=*), intent(in) :: filename + character(len=:), allocatable :: string + integer :: fh, length + + open (newunit=fh, file=filename, status='old', action='read', & + access='stream', form='unformatted') + inquire (fh, size=length) + allocate (character(len=length) :: string) + if (length == 0) return + read (fh) string + close (fh) + +end function read_text_file + +!> Create a directory. Create subdirectories as needed +subroutine mkdir(dir, echo) + character(len=*), intent(in) :: dir + logical, intent(in), optional :: echo + + integer :: stat + + if (is_dir(dir)) return + + select case (get_os_type()) + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) + call run('mkdir -p ' // dir, exitstat=stat,echo=echo,verbose=.false.) + + case (OS_WINDOWS) + call run("mkdir " // windows_path(dir), & + & echo=echo, exitstat=stat,verbose=.false.) + + end select + + if (stat /= 0) then + call fpm_stop(1, '*mkdir*:directory creation failed') + end if +end subroutine mkdir + +!> Get file & directory names in directory `dir` using iso_c_binding. +!! +!! - File/directory names return are relative to cwd, ie. preprended with `dir` +!! - Includes files starting with `.` except current directory and parent directory +!! +recursive subroutine list_files(dir, files, recurse) + character(len=*), intent(in) :: dir + type(string_t), allocatable, intent(out) :: files(:) + logical, intent(in), optional :: recurse + + integer :: i + type(string_t), allocatable :: dir_files(:) + type(string_t), allocatable :: sub_dir_files(:) + + type(c_ptr) :: dir_handle + type(c_ptr) :: dir_entry_c + character(len=:,kind=c_char), allocatable :: fortran_name + character(len=:), allocatable :: string_fortran + integer, parameter :: N_MAX = 256 + type(string_t) :: files_tmp(N_MAX) + integer(kind=c_int) :: r + + if (c_is_dir(dir(1:len_trim(dir))//c_null_char) == 0) then + allocate (files(0)) + return + end if + + dir_handle = c_opendir(dir(1:len_trim(dir))//c_null_char) + if (.not. c_associated(dir_handle)) then + print *, 'c_opendir() failed' + error stop + end if + + i = 0 + allocate(files(0)) + + do + dir_entry_c = c_readdir(dir_handle) + if (.not. c_associated(dir_entry_c)) then + exit + else + string_fortran = f_string(c_get_d_name(dir_entry_c)) + + if ((string_fortran == '.' .or. string_fortran == '..')) then + cycle + end if + + i = i + 1 + + if (i > N_MAX) then + files = [files, files_tmp] + i = 1 + end if + + files_tmp(i)%s = join_path(dir, string_fortran) + end if + end do + + r = c_closedir(dir_handle) + + if (r /= 0) then + print *, 'c_closedir() failed' + error stop + end if + + if (i > 0) then + files = [files, files_tmp(1:i)] + end if + + if (present(recurse)) then + if (recurse) then + + allocate(sub_dir_files(0)) + + do i=1,size(files) + if (c_is_dir(files(i)%s//c_null_char) /= 0) then + call list_files(files(i)%s, dir_files, recurse=.true.) + sub_dir_files = [sub_dir_files, dir_files] + end if + end do + + files = [files, sub_dir_files] + end if + end if +end subroutine list_files + +!> test if pathname already exists +logical function exists(filename) result(r) + character(len=*), intent(in) :: filename + inquire(file=filename, exist=r) + + !> Directories are not files for the Intel compilers. If so, also use this compiler-dependent extension + +end function + +!> Get a unused temporary filename +!! Calls posix 'tempnam' - not recommended, but +!! we have no security concerns for this application +!! and use here is temporary. +!! Works with MinGW +function get_temp_filename() result(tempfile) + ! + use iso_c_binding, only: c_ptr, C_NULL_PTR, c_f_pointer + integer, parameter :: MAX_FILENAME_LENGTH = 32768 + character(:), allocatable :: tempfile + + type(c_ptr) :: c_tempfile_ptr + character(len=1), pointer :: c_tempfile(:) + + interface + + function c_tempnam(dir,pfx) result(tmp) bind(c,name="tempnam") + import + type(c_ptr), intent(in), value :: dir + type(c_ptr), intent(in), value :: pfx + type(c_ptr) :: tmp + end function c_tempnam + + subroutine c_free(ptr) BIND(C,name="free") + import + type(c_ptr), value :: ptr + end subroutine c_free + + end interface + + c_tempfile_ptr = c_tempnam(C_NULL_PTR, C_NULL_PTR) + call c_f_pointer(c_tempfile_ptr,c_tempfile,[MAX_FILENAME_LENGTH]) + + tempfile = f_string(c_tempfile) + + call c_free(c_tempfile_ptr) + +end function get_temp_filename + +!> Replace file system separators for windows +function windows_path(path) result(winpath) + + character(*), intent(in) :: path + character(:), allocatable :: winpath + + integer :: idx + + winpath = path + + idx = index(winpath,'/') + do while(idx > 0) + winpath(idx:idx) = '\' + idx = index(winpath,'/') + end do + +end function windows_path + +!> Replace file system separators for unix +function unix_path(path) result(nixpath) + + character(*), intent(in) :: path + character(:), allocatable :: nixpath + + integer :: idx + + nixpath = path + + idx = index(nixpath,'\') + do while(idx > 0) + nixpath(idx:idx) = '/' + idx = index(nixpath,'\') + end do + +end function unix_path + +!>AUTHOR: fpm(1) contributors +!!LICENSE: MIT +!> +!!##NAME +!! getline(3f) - [M_io:READ] read a line of arbintrary length from specified +!! LUN into allocatable string (up to system line length limit) +!! (LICENSE:PD) +!! +!!##SYNTAX +!! subroutine getline(unit,line,iostat,iomsg) +!! +!! integer,intent(in) :: unit +!! character(len=:),allocatable,intent(out) :: line +!! integer,intent(out) :: iostat +!! character(len=:), allocatable, optional :: iomsg +!! +!!##DESCRIPTION +!! Read a line of any length up to programming environment maximum +!! line length. Requires Fortran 2003+. +!! +!! It is primarily expected to be used when reading input which will +!! then be parsed or echoed. +!! +!! The input file must have a PAD attribute of YES for the function +!! to work properly, which is typically true. +!! +!! The simple use of a loop that repeatedly re-allocates a character +!! variable in addition to reading the input file one buffer at a +!! time could (depending on the programming environment used) be +!! inefficient, as it could reallocate and allocate memory used for +!! the output string with each buffer read. +!! +!!##OPTIONS +!! LINE The line read when IOSTAT returns as zero. +!! LUN LUN (Fortran logical I/O unit) number of file open and ready +!! to read. +!! IOSTAT status returned by READ(IOSTAT=IOS). If not zero, an error +!! occurred or an end-of-file or end-of-record was encountered. +!! IOMSG error message returned by system when IOSTAT is not zero. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_getline +!! use,intrinsic :: iso_fortran_env, only : stdin=>input_unit +!! use,intrinsic :: iso_fortran_env, only : iostat_end +!! use FPM_filesystem, only : getline +!! implicit none +!! integer :: iostat +!! character(len=:),allocatable :: line, iomsg +!! open(unit=stdin,pad='yes') +!! INFINITE: do +!! call getline(stdin,line,iostat,iomsg) +!! if(iostat /= 0) exit INFINITE +!! write(*,'(a)')'['//line//']' +!! enddo INFINITE +!! if(iostat /= iostat_end)then +!! write(*,*)'error reading input:',iomsg +!! endif +!! end program demo_getline +!! +subroutine getline(unit, line, iostat, iomsg) + + !> Formatted IO unit + integer, intent(in) :: unit + + !> Line to read + character(len=:), allocatable, intent(out) :: line + + !> Status of operation + integer, intent(out) :: iostat + + !> Error message + character(len=:), allocatable, optional :: iomsg + + integer, parameter :: BUFFER_SIZE = 1024 + character(len=BUFFER_SIZE) :: buffer + character(len=256) :: msg + integer :: size + integer :: stat + + allocate(character(len=0) :: line) + do + read(unit, '(a)', advance='no', iostat=stat, iomsg=msg, size=size) & + & buffer + if (stat > 0) exit + line = line // buffer(:size) + if (stat < 0) then + if (is_iostat_eor(stat)) then + stat = 0 + end if + exit + end if + end do + + if (stat /= 0) then + if (present(iomsg)) iomsg = trim(msg) + end if + iostat = stat + +end subroutine getline + +!> delete a file by filename +subroutine delete_file(file) + character(len=*), intent(in) :: file + logical :: exist + integer :: unit + inquire(file=file, exist=exist) + if (exist) then + open(file=file, newunit=unit) + close(unit, status="delete") + end if +end subroutine delete_file + +!> write trimmed character data to a file if it does not exist +subroutine warnwrite(fname,data) +character(len=*),intent(in) :: fname +character(len=*),intent(in) :: data(:) + + if(.not.exists(fname))then + call filewrite(fname,data) + else + write(stderr,'(*(g0,1x))')' ',fname,& + & 'already exists. Not overwriting' + endif + +end subroutine warnwrite + +!> procedure to open filename as a sequential "text" file +subroutine fileopen(filename,lun,ier) + +character(len=*),intent(in) :: filename +integer,intent(out) :: lun +integer,intent(out),optional :: ier +integer :: ios +character(len=256) :: message + + message=' ' + ios=0 + if(filename/=' ')then + open(file=filename, & + & newunit=lun, & + & form='formatted', & ! FORM = FORMATTED | UNFORMATTED + & access='sequential', & ! ACCESS = SEQUENTIAL| DIRECT | STREAM + & action='write', & ! ACTION = READ|WRITE| READWRITE + & position='rewind', & ! POSITION= ASIS | REWIND | APPEND + & status='new', & ! STATUS = NEW| REPLACE| OLD| SCRATCH| UNKNOWN + & iostat=ios, & + & iomsg=message) + else + lun=stdout + ios=0 + endif + if(ios/=0)then + lun=-1 + if(present(ier))then + ier=ios + else + call fpm_stop(3,'*fileopen*:'//filename//':'//trim(message)) + endif + endif + +end subroutine fileopen + +!> simple close of a LUN. On error show message and stop (by default) +subroutine fileclose(lun,ier) +integer,intent(in) :: lun +integer,intent(out),optional :: ier +character(len=256) :: message +integer :: ios + if(lun/=-1)then + close(unit=lun,iostat=ios,iomsg=message) + if(ios/=0)then + if(present(ier))then + ier=ios + else + call fpm_stop(4,'*fileclose*:'//trim(message)) + endif + endif + endif +end subroutine fileclose + +!> procedure to write filedata to file filename +subroutine filewrite(filename,filedata) + +character(len=*),intent(in) :: filename +character(len=*),intent(in) :: filedata(:) +integer :: lun, i, ios +character(len=256) :: message + call fileopen(filename,lun) + if(lun/=-1)then ! program currently stops on error on open, but might + ! want it to continue so -1 (unallowed LUN) indicates error + ! write file + do i=1,size(filedata) + write(lun,'(a)',iostat=ios,iomsg=message)trim(filedata(i)) + if(ios/=0)then + call fpm_stop(5,'*filewrite*:'//filename//':'//trim(message)) + endif + enddo + endif + ! close file + call fileclose(lun) + +end subroutine filewrite + +!>AUTHOR: John S. Urban +!!LICENSE: Public Domain +!> +!!##Name +!! which(3f) - [M_io:ENVIRONMENT] given a command name find the pathname by searching +!! the directories in the environment variable $PATH +!! (LICENSE:PD) +!! +!!##Syntax +!! function which(command) result(pathname) +!! +!! character(len=*),intent(in) :: command +!! character(len=:),allocatable :: pathname +!! +!!##Description +!! Given a command name find the first file with that name in the directories +!! specified by the environment variable $PATH. +!! +!!##options +!! COMMAND the command to search for +!! +!!##Returns +!! PATHNAME the first pathname found in the current user path. Returns blank +!! if the command is not found. +!! +!!##Example +!! +!! Sample program: +!! +!! Checking the error message and counting lines: +!! +!! program demo_which +!! use M_io, only : which +!! implicit none +!! write(*,*)'ls is ',which('ls') +!! write(*,*)'dir is ',which('dir') +!! write(*,*)'install is ',which('install') +!! end program demo_which +!! +function which(command) result(pathname) +character(len=*),intent(in) :: command +character(len=:),allocatable :: pathname, checkon, paths(:), exts(:) +integer :: i, j + pathname='' + call split(get_env('PATH'),paths,delimiters=merge(';',':',separator()=='\')) + SEARCH: do i=1,size(paths) + checkon=trim(join_path(trim(paths(i)),command)) + select case(separator()) + case('/') + if(exists(checkon))then + pathname=checkon + exit SEARCH + endif + case('\') + if(exists(checkon))then + pathname=checkon + exit SEARCH + endif + if(exists(checkon//'.bat'))then + pathname=checkon//'.bat' + exit SEARCH + endif + if(exists(checkon//'.exe'))then + pathname=checkon//'.exe' + exit SEARCH + endif + call split(get_env('PATHEXT'),exts,delimiters=';') + do j=1,size(exts) + if(exists(checkon//'.'//trim(exts(j))))then + pathname=checkon//'.'//trim(exts(j)) + exit SEARCH + endif + enddo + end select + enddo SEARCH +end function which + +!>AUTHOR: fpm(1) contributors +!!LICENSE: MIT +!> +!!##Name +!! run(3f) - execute specified system command and selectively echo +!! command and output to a file and/or stdout. +!! (LICENSE:MIT) +!! +!!##Syntax +!! subroutine run(cmd,echo,exitstat,verbose,redirect) +!! +!! character(len=*), intent(in) :: cmd +!! logical,intent(in),optional :: echo +!! integer, intent(out),optional :: exitstat +!! logical, intent(in), optional :: verbose +!! character(*), intent(in), optional :: redirect +!! +!!##Description +!! Execute the specified system command. Optionally +!! +!! + echo the command before execution +!! + return the system exit status of the command. +!! + redirect the output of the command to a file. +!! + echo command output to stdout +!! +!! Calling run(3f) is preferred to direct calls to +!! execute_command_line(3f) in the fpm(1) source to provide a standard +!! interface where output modes can be specified. +!! +!!##Options +!! CMD System command to execute +!! ECHO Whether to echo the command being executed or not +!! Defaults to .TRUE. . +!! VERBOSE Whether to redirect the command output to a null device or not +!! Defaults to .TRUE. . +!! REDIRECT Filename to redirect stdout and stderr of the command into. +!! If generated it is closed before run(3f) returns. +!! EXITSTAT The system exit status of the command when supported by +!! the system. If not present and a non-zero status is +!! generated program termination occurs. +!! +!!##Example +!! +!! Sample program: +!! +!! Checking the error message and counting lines: +!! +!! program demo_run +!! use fpm_filesystem, only : run +!! implicit none +!! logical,parameter :: T=.true., F=.false. +!! integer :: exitstat +!! character(len=:),allocatable :: cmd +!! cmd='ls -ltrasd *.md' +!! call run(cmd) +!! call run(cmd,exitstat=exitstat) +!! call run(cmd,echo=F) +!! call run(cmd,verbose=F) +!! end program demo_run +!! +subroutine run(cmd,echo,exitstat,verbose,redirect) + character(len=*), intent(in) :: cmd + logical,intent(in),optional :: echo + integer, intent(out),optional :: exitstat + logical, intent(in), optional :: verbose + character(*), intent(in), optional :: redirect + + integer :: cmdstat + character(len=256) :: cmdmsg, iomsg + logical :: echo_local, verbose_local + character(:), allocatable :: redirect_str + character(:), allocatable :: line + integer :: stat, fh, iostat + + if(present(echo))then + echo_local=echo + else + echo_local=.true. + end if + + if(present(verbose))then + verbose_local=verbose + else + verbose_local=.true. + end if + + if (present(redirect)) then + if(redirect /= '')then + redirect_str = ">"//redirect//" 2>&1" + else + redirect_str = "" + endif + else + if(verbose_local)then + ! No redirection but verbose output + redirect_str = "" + else + ! No redirection and non-verbose output + if (os_is_unix()) then + redirect_str = " >/dev/null 2>&1" + else + redirect_str = " >NUL 2>&1" + end if + end if + end if + + if(echo_local) print *, '+ ', cmd !//redirect_str + + call execute_command_line(cmd//redirect_str, exitstat=stat,cmdstat=cmdstat,cmdmsg=cmdmsg) + if(cmdstat /= 0)then + write(*,'(a)')':failed command '//cmd//redirect_str + call fpm_stop(1,'*run*:'//trim(cmdmsg)) + endif + + if (verbose_local.and.present(redirect)) then + + open(newunit=fh,file=redirect,status='old',iostat=iostat,iomsg=iomsg) + if(iostat == 0)then + do + call getline(fh, line, iostat) + if (iostat /= 0) exit + write(*,'(A)') trim(line) + end do + else + write(*,'(A)') trim(iomsg) + endif + + close(fh) + + end if + + if (present(exitstat)) then + exitstat = stat + elseif (stat /= 0) then + call fpm_stop(stat,'*run*: Command '//cmd//redirect_str//' returned a non-zero status code') + end if + +end subroutine run + +!> Delete directory using system OS remove directory commands +subroutine os_delete_dir(is_unix, dir, echo) + logical, intent(in) :: is_unix + character(len=*), intent(in) :: dir + logical, intent(in), optional :: echo + + if (is_unix) then + call run('rm -rf ' // dir, echo=echo,verbose=.false.) + else + call run('rmdir /s/q ' // dir, echo=echo,verbose=.false.) + end if + +end subroutine os_delete_dir + + !> Determine the path prefix to the local folder. Used for installation, registry etc. + function get_local_prefix(os) result(prefix) + !> Installation prefix + character(len=:), allocatable :: prefix + !> Platform identifier + integer, intent(in), optional :: os + + !> Default installation prefix on Unix platforms + character(len=*), parameter :: default_prefix_unix = "/usr/local" + !> Default installation prefix on Windows platforms + character(len=*), parameter :: default_prefix_win = "C:\" + + character(len=:), allocatable :: home + + if (os_is_unix(os)) then + home=get_env('HOME','') + if (home /= '' ) then + prefix = join_path(home, ".local") + else + prefix = default_prefix_unix + end if + else + home=get_env('APPDATA','') + if (home /= '' ) then + prefix = join_path(home, "local") + else + prefix = default_prefix_win + end if + end if + + end function get_local_prefix + + !> Returns .true. if provided path is absolute. + !> + !> `~` not treated as absolute. + logical function is_absolute_path(path, is_unix) + character(len=*), intent(in) :: path + logical, optional, intent(in):: is_unix + character(len=*), parameter :: letters = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + logical :: is_unix_os + + if (present(is_unix)) then + is_unix_os = is_unix + else + is_unix_os = os_is_unix() + end if + + if (is_unix_os) then + is_absolute_path = path(1:1) == '/' + else + if (len(path) < 2) then + is_absolute_path = .false. + return + end if + + is_absolute_path = index(letters, path(1:1)) /= 0 .and. path(2:2) == ':' + end if + + end function is_absolute_path + + !> Get the HOME directory on Unix and the %USERPROFILE% directory on Windows. + subroutine get_home(home, error) + character(len=:), allocatable, intent(out) :: home + type(error_t), allocatable, intent(out) :: error + + if (os_is_unix()) then + home=get_env('HOME','') + if ( home == '' ) then + call fatal_error(error, "Couldn't retrieve 'HOME' variable") + return + end if + else + home=get_env('USERPROFILE','') + if ( home == '' ) then + call fatal_error(error, "Couldn't retrieve '%USERPROFILE%' variable") + return + end if + end if + end subroutine get_home + + !> Execute command line and return output as a string. + subroutine execute_and_read_output(cmd, output, error, verbose) + !> Command to execute. + character(len=*), intent(in) :: cmd + !> Command line output. + character(len=:), allocatable, intent(out) :: output + !> Error to handle. + type(error_t), allocatable, intent(out) :: error + !> Print additional information if true. + logical, intent(in), optional :: verbose + + integer :: exitstat, unit, stat + character(len=:), allocatable :: cmdmsg, tmp_file, output_line + logical :: is_verbose + + if (present(verbose)) then + is_verbose = verbose + else + is_verbose = .false. + end if + + tmp_file = get_temp_filename() + + call run(cmd//' > '//tmp_file, exitstat=exitstat, echo=is_verbose) + if (exitstat /= 0) call fatal_error(error, '*run*: '//"Command failed: '"//cmd//"'. Message: '"//trim(cmdmsg)//"'.") + + open(newunit=unit, file=tmp_file, action='read', status='old') + output = '' + do + call getline(unit, output_line, stat) + if (stat /= 0) exit + output = output//output_line//' ' + end do + if (is_verbose) print *, output + close(unit, status='delete') + end + + !> Ensure a windows path is converted to an 8.3 DOS path if it contains spaces + function get_dos_path(path,error) + character(len=*), intent(in) :: path + type(error_t), allocatable, intent(out) :: error + character(len=:), allocatable :: get_dos_path + + character(:), allocatable :: redirect,screen_output,line + integer :: stat,cmdstat,iunit,last + + ! Non-Windows OS + if (get_os_type()/=OS_WINDOWS) then + get_dos_path = path + return + end if + + ! Trim path first + get_dos_path = trim(path) + + !> No need to convert if there are no spaces + has_spaces: if (scan(get_dos_path,' ')>0) then + + redirect = get_temp_filename() + call execute_command_line('cmd /c for %A in ("'//path//'") do @echo %~sA >'//redirect//' 2>&1',& + exitstat=stat,cmdstat=cmdstat) + + !> Read screen output + command_OK: if (cmdstat==0 .and. stat==0) then + + allocate(character(len=0) :: screen_output) + open(newunit=iunit,file=redirect,status='old',iostat=stat) + if (stat == 0)then + + do + call getline(iunit, line, stat) + if (stat /= 0) exit + screen_output = screen_output//line//' ' + end do + + ! Close and delete file + close(iunit,status='delete') + + else + call fatal_error(error,'cannot read temporary file from successful DOS path evaluation') + return + endif + + else command_OK + + call fatal_error(error,'unsuccessful Windows->DOS path command') + return + + end if command_OK + + get_dos_path = trim(adjustl(screen_output)) + + endif has_spaces + + !> Ensure there are no trailing slashes + last = len_trim(get_dos_path) + if (last>1 .and. get_dos_path(last:last)=='/' .or. get_dos_path(last:last)=='\') get_dos_path = get_dos_path(1:last-1) + + end function get_dos_path + +end module fpm_filesystem + +!>>>>> ././src/fpm/fpm_release.F90 + +!># Release parameters +!> Module fpm_release contains public constants storing this build's unique version IDs +module fpm_release + use fpm_versioning, only: version_t,new_version + use fpm_error, only: error_t, fpm_stop + implicit none + private + + public :: fpm_version + public :: version_t + + contains + + !> Return the current fpm version from fpm_version_ID as a version type + type(version_t) function fpm_version() + + type(error_t), allocatable :: error + +! Fallback to last known version in case of undefined macro + +! Accept solution from https://stackoverflow.com/questions/31649691/stringify-macro-with-gnu-gfortran +! which provides the "easiest" way to pass a macro to a string in Fortran complying with both +! gfortran's "traditional" cpp and the standard cpp syntaxes + + character (len=:), allocatable :: ver_string + ver_string = "& + &0.10.1" + + call new_version(fpm_version,ver_string,error) + + if (allocated(error)) call fpm_stop(1,'*fpm*:internal error: cannot get version - '//error%message) + + end function fpm_version + +end module fpm_release + +!>>>>> build/dependencies/toml-f/src/tomlf/terminal.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a terminal to provide ANSI escape sequences +!> +!> ANSI escape codes for producing terminal colors. The `ansi_code` derived +!> type is used to store ANSI escape codes and can be combined with other +!> codes or applied to strings by concatenation. The default or uninitialized +!> `ansi_code` is a stub and does not produce escape sequences when applied +!> to a string. +!> +!> Available colors are +!> +!> color | foreground | background +!> -------------- | --------------------- | ------------------------ +!> black | `black` (30) | `bg_black` (40) +!> red | `red` (31) | `bg_red` (41) +!> green | `green` (32) | `bg_green` (42) +!> yellow | `yellow` (33) | `bg_yellow` (43) +!> blue | `blue` (34) | `bg_blue` (44) +!> magenta | `magenta` (35) | `bg_magenta` (45) +!> cyan | `cyan` (36) | `bg_cyan` (46) +!> white | `white` (37) | `bg_white` (47) +!> gray | `gray` (90) | `bg_gray` (100) +!> bright red | `bright_red` (91) | `bg_bright_red` (101) +!> bright green | `bright_green` (92) | `bg_bright_green` (102) +!> bright yellow | `bright_yellow` (93) | `bg_bright_yellow` (103) +!> bright blue | `bright_blue` (94) | `bg_bright_blue` (104) +!> bright magenta | `bright_magenta` (95) | `bg_bright_magenta` (105) +!> bright cyan | `bright_cyan` (96) | `bg_bright_cyan` (106) +!> bright white | `bright_white` (97) | `bg_bright_white` (107) +!> +!> Available styles are +!> +!> style | +!> ------------| --------------- +!> reset | `reset` (0) +!> bold | `bold` (1) +!> dim | `dim` (2) +!> italic | `italic` (3) +!> underline | `underline` (4) +!> blink | `blink` (5) +!> blink rapid | `blink_rapid` (6) +!> reverse | `reverse` (7) +!> hidden | `hidden` (8) +!> crossed | `crossed` (9) +module tomlf_terminal + use tomlf_utils, only : to_string + implicit none + private + + public :: toml_terminal + public :: ansi_code, escape, operator(+), operator(//) + + !> Char length for integers + integer, parameter :: i1 = selected_int_kind(2) + + !> Container for terminal escape code + type :: ansi_code + private + !> Style descriptor + integer(i1) :: style = -1_i1 + !> Background color descriptor + integer(i1) :: bg = -1_i1 + !> Foreground color descriptor + integer(i1) :: fg = -1_i1 + end type + + interface operator(+) + module procedure :: add + end interface operator(+) + + interface operator(//) + module procedure :: concat_left + module procedure :: concat_right + end interface operator(//) + + interface escape + module procedure :: escape + end interface escape + + type(ansi_code), public, parameter :: & + reset = ansi_code(style=0_i1), & + bold = ansi_code(style=1_i1), & + dim = ansi_code(style=2_i1), & + italic = ansi_code(style=3_i1), & + underline = ansi_code(style=4_i1), & + blink = ansi_code(style=5_i1), & + blink_rapid = ansi_code(style=6_i1), & + reverse = ansi_code(style=7_i1), & + hidden = ansi_code(style=8_i1), & + crossed = ansi_code(style=9_i1) + + type(ansi_code), public, parameter :: & + black = ansi_code(fg=30_i1), & + red = ansi_code(fg=31_i1), & + green = ansi_code(fg=32_i1), & + yellow = ansi_code(fg=33_i1), & + blue = ansi_code(fg=34_i1), & + magenta = ansi_code(fg=35_i1), & + cyan = ansi_code(fg=36_i1), & + white = ansi_code(fg=37_i1), & + gray = ansi_code(fg=90_i1), & + bright_red = ansi_code(fg=91_i1), & + bright_green = ansi_code(fg=92_i1), & + bright_yellow = ansi_code(fg=93_i1), & + bright_blue = ansi_code(fg=94_i1), & + bright_magenta = ansi_code(fg=95_i1), & + bright_cyan = ansi_code(fg=96_i1), & + bright_white = ansi_code(fg=97_i1) + + type(ansi_code), public, parameter :: & + bg_black = ansi_code(bg=40_i1), & + bg_red = ansi_code(bg=41_i1), & + bg_green = ansi_code(bg=42_i1), & + bg_yellow = ansi_code(bg=43_i1), & + bg_blue = ansi_code(bg=44_i1), & + bg_magenta = ansi_code(bg=45_i1), & + bg_cyan = ansi_code(bg=46_i1), & + bg_white = ansi_code(bg=47_i1), & + bg_gray = ansi_code(bg=100_i1), & + bg_bright_red = ansi_code(bg=101_i1), & + bg_bright_green = ansi_code(bg=102_i1), & + bg_bright_yellow = ansi_code(bg=103_i1), & + bg_bright_blue = ansi_code(bg=104_i1), & + bg_bright_magenta = ansi_code(bg=105_i1), & + bg_bright_cyan = ansi_code(bg=106_i1), & + bg_bright_white = ansi_code(bg=107_i1) + + !> Terminal wrapper to handle color escape sequences, must be initialized with + !> color support to provide colorful output. Default and uninitialized instances + !> will remain usable but provide only stubs and do not produce colorful output. + !> This behavior is useful for creating applications which can toggle color support. + type :: toml_terminal + type(ansi_code) :: & + reset = ansi_code(), & + bold = ansi_code(), & + dim = ansi_code(), & + italic = ansi_code(), & + underline = ansi_code(), & + blink = ansi_code(), & + blink_rapid = ansi_code(), & + reverse = ansi_code(), & + hidden = ansi_code(), & + crossed = ansi_code() + + type(ansi_code) :: & + black = ansi_code(), & + red = ansi_code(), & + green = ansi_code(), & + yellow = ansi_code(), & + blue = ansi_code(), & + magenta = ansi_code(), & + cyan = ansi_code(), & + white = ansi_code(), & + gray = ansi_code(), & + bright_red = ansi_code(), & + bright_green = ansi_code(), & + bright_yellow = ansi_code(), & + bright_blue = ansi_code(), & + bright_magenta = ansi_code(), & + bright_cyan = ansi_code(), & + bright_white = ansi_code() + + type(ansi_code) :: & + bg_black = ansi_code(), & + bg_red = ansi_code(), & + bg_green = ansi_code(), & + bg_yellow = ansi_code(), & + bg_blue = ansi_code(), & + bg_magenta = ansi_code(), & + bg_cyan = ansi_code(), & + bg_white = ansi_code(), & + bg_gray = ansi_code(), & + bg_bright_red = ansi_code(), & + bg_bright_green = ansi_code(), & + bg_bright_yellow = ansi_code(), & + bg_bright_blue = ansi_code(), & + bg_bright_magenta = ansi_code(), & + bg_bright_cyan = ansi_code(), & + bg_bright_white = ansi_code() + end type toml_terminal + + !> Constructor to create new terminal + interface toml_terminal + module procedure :: new_terminal + end interface toml_terminal + +contains + +!> Create new terminal +pure function new_terminal(use_color) result(new) + !> Enable color support in terminal + logical, intent(in) :: use_color + !> New terminal instance + type(toml_terminal) :: new + + if (use_color) then + new%reset = reset + new%bold = bold + new%dim = dim + new%italic = italic + new%underline = underline + new%blink = blink + new%blink_rapid = blink_rapid + new%reverse = reverse + new%hidden = hidden + new%crossed = crossed + + new%black = black + new%red = red + new%green = green + new%yellow = yellow + new%blue = blue + new%magenta = magenta + new%cyan = cyan + new%white = white + new%gray = gray + new%bright_red = bright_red + new%bright_green = bright_green + new%bright_yellow = bright_yellow + new%bright_blue = bright_blue + new%bright_magenta = bright_magenta + new%bright_cyan = bright_cyan + new%bright_white = bright_white + + new%bg_black = bg_black + new%bg_red = bg_red + new%bg_green = bg_green + new%bg_yellow = bg_yellow + new%bg_blue = bg_blue + new%bg_magenta = bg_magenta + new%bg_cyan = bg_cyan + new%bg_white = bg_white + new%bg_gray = bg_gray + new%bg_bright_red = bg_bright_red + new%bg_bright_green = bg_bright_green + new%bg_bright_yellow = bg_bright_yellow + new%bg_bright_blue = bg_bright_blue + new%bg_bright_magenta = bg_bright_magenta + new%bg_bright_cyan = bg_bright_cyan + new%bg_bright_white = bg_bright_white + end if +end function new_terminal + +!> Add two escape sequences, attributes in the right value override the left value ones. +pure function add(lval, rval) result(code) + !> First escape code + type(ansi_code), intent(in) :: lval + !> Second escape code + type(ansi_code), intent(in) :: rval + !> Combined escape code + type(ansi_code) :: code + + code%style = merge(rval%style, lval%style, rval%style >= 0) + code%fg = merge(rval%fg, lval%fg, rval%fg >= 0) + code%bg = merge(rval%bg, lval%bg, rval%bg >= 0) +end function add + +!> Concatenate an escape code with a string and turn it into an actual escape sequence +pure function concat_left(lval, code) result(str) + !> String to add the escape code to + character(len=*), intent(in) :: lval + !> Escape sequence + type(ansi_code), intent(in) :: code + !> Concatenated string + character(len=:), allocatable :: str + + str = lval // escape(code) +end function concat_left + +!> Concatenate an escape code with a string and turn it into an actual escape sequence +pure function concat_right(code, rval) result(str) + !> String to add the escape code to + character(len=*), intent(in) :: rval + !> Escape sequence + type(ansi_code), intent(in) :: code + !> Concatenated string + character(len=:), allocatable :: str + + str = escape(code) // rval +end function concat_right + +!> Transform a color code into an actual ANSI escape sequence +pure function escape(code) result(str) + !> Color code to be used + type(ansi_code), intent(in) :: code + !> ANSI escape sequence representing the color code + character(len=:), allocatable :: str + + if (anycolor(code)) then + str = achar(27) // "[0" ! Always reset the style + if (code%style > 0) str = str // ";" // to_string(code%style) + if (code%fg >= 0) str = str // ";" // to_string(code%fg) + if (code%bg >= 0) str = str // ";" // to_string(code%bg) + str = str // "m" + else + str = "" + end if +end function escape + +!> Check whether the code describes any color or is just a stub +pure function anycolor(code) + !> Escape sequence + type(ansi_code), intent(in) :: code + !> Any color / style is active + logical :: anycolor + + anycolor = code%fg >= 0 .or. code%bg >= 0 .or. code%style >= 0 +end function anycolor + +end module tomlf_terminal + +!>>>>> build/dependencies/toml-f/src/tomlf/type/value.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Class definitions for basic data types used for handling TOML +module tomlf_type_value + use tomlf_constants, only : tfc, TOML_BAREKEY + use tomlf_utils, only : toml_escape_string + implicit none + private + + public :: toml_value, toml_visitor, toml_key + + !> Abstract base value for TOML data types + type, abstract :: toml_value + + !> Raw representation of the key to the TOML value + character(kind=tfc, len=:), allocatable :: key + + !> Original source of the value + integer :: origin = 0 + + contains + + !> Accept a visitor to transverse the data structure + procedure :: accept + + !> Get escaped key to TOML value + procedure :: get_key + + !> Compare raw key of TOML value to input key + procedure :: match_key + + !> Release allocation hold by TOML value + procedure(destroy), deferred :: destroy + + end type toml_value + + !> Abstract visitor for TOML values + type, abstract :: toml_visitor + contains + + !> Visitor visiting a TOML value + procedure(visit), deferred :: visit + + end type toml_visitor + + !> Thin wrapper around the deferred-size character intrinisc + type :: toml_key + + !> Raw representation of the key to the TOML value + character(kind=tfc, len=:), allocatable :: key + + !> Original source of the value + integer :: origin = 0 + + end type toml_key + + abstract interface + !> Accept a visitor to transverse the data structure + recursive subroutine visit(self, val) + import toml_value, toml_visitor + + !> Instance of the visitor + class(toml_visitor), intent(inout) :: self + + !> Value to visit + class(toml_value), intent(inout) :: val + end subroutine visit + + !> Deconstructor to cleanup allocations (optional) + subroutine destroy(self) + import toml_value + + !> Instance of the TOML value + class(toml_value), intent(inout) :: self + + end subroutine destroy + + end interface + +contains + +!> Accept a visitor to transverse the data structure +recursive subroutine accept(self, visitor) + + !> Instance of the TOML value + class(toml_value), intent(inout) :: self + + !> Visitor for this value + class(toml_visitor), intent(inout) :: visitor + + call visitor%visit(self) + +end subroutine accept + +!> Get escaped key to TOML value +subroutine get_key(self, key) + + !> TOML value instance. + class(toml_value), intent(in) :: self + + !> Contains valid TOML key on exit + character(kind=tfc, len=:), allocatable :: key + + if (allocated(self%key)) then + if (verify(self%key, TOML_BAREKEY) == 0 .and. len(self%key) > 0) then + key = self%key + else + call toml_escape_string(self%key, key) + end if + end if + +end subroutine get_key + +!> Compare raw key of TOML value to input key +pure function match_key(self, key) result(match) + + !> TOML value instance. + class(toml_value), intent(in) :: self + + !> TOML raw key to compare to + character(kind=tfc, len=*), intent(in) :: key + + logical :: match + + if (allocated(self%key)) then + match = key == self%key + else + match = .false. + end if + +end function match_key + +end module tomlf_type_value + +!>>>>> build/dependencies/jonquil/src/jonquil/lexer.f90 + +! This file is part of jonquil. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +module jonquil_lexer + use tomlf_constants, only : tfc, tfi, tfr, toml_escape + use tomlf_datetime, only : toml_datetime + use tomlf_de_abc, only : abstract_lexer + use tomlf_de_token, only : toml_token, token_kind + use tomlf_error, only : toml_error, make_error + use tomlf_utils, only : read_whole_file, read_whole_line + implicit none + private + + public :: json_lexer + public :: new_lexer_from_file, new_lexer_from_unit, new_lexer_from_string + public :: toml_token, token_kind + + !> Tokenizer for JSON documents + type, extends(abstract_lexer) :: json_lexer + !> Name of the source file, used for error reporting + character(len=:), allocatable :: filename + !> Current internal position in the source chunk + integer :: pos = 0 + !> Current source chunk + character(:, tfc), allocatable :: chunk + !> Additional tokens to insert before the actual token stream + integer :: prelude = 2 + contains + !> Obtain the next token + procedure :: next + !> Extract a string from a token + procedure :: extract_string + !> Extract an integer from a token + procedure :: extract_integer + !> Extract a float from a token + procedure :: extract_float + !> Extract a boolean from a token + procedure :: extract_bool + !> Extract a timestamp from a token + procedure :: extract_datetime + !> Get information about source + procedure :: get_info + end type json_lexer + + character(*, tfc), parameter :: terminated = " {}[],:"//& + & toml_escape%tabulator//toml_escape%newline//toml_escape%carriage_return + +contains + +!> Create a new instance of a lexer by reading from a file +subroutine new_lexer_from_file(lexer, filename, error) + !> Instance of the lexer + type(json_lexer), intent(out) :: lexer + !> Name of the file to read from + character(len=*), intent(in) :: filename + !> Error code + type(toml_error), allocatable, intent(out) :: error + + integer :: stat + + lexer%filename = filename + call read_whole_file(filename, lexer%chunk, stat) + + if (stat /= 0) call make_error(error, "Could not open file '"//filename//"'") +end subroutine new_lexer_from_file + +!> Create a new instance of a lexer by reading from a unit. +!> +!> Currently, only sequential access units can be processed by this constructor. +subroutine new_lexer_from_unit(lexer, io, error) + !> Instance of the lexer + type(json_lexer), intent(out) :: lexer + !> Unit to read from + integer, intent(in) :: io + !> Error code + type(toml_error), allocatable, intent(out) :: error + + character(:, tfc), allocatable :: source, line + integer, parameter :: bufsize = 512 + character(bufsize, tfc) :: filename, mode + integer :: stat + + inquire(unit=io, access=mode, name=filename) + select case(trim(mode)) + case default + stat = 1 + + case("sequential", "SEQUENTIAL") + allocate(character(0) :: source) + do + call read_whole_line(io, line, stat) + if (stat > 0) exit + source = source // line // toml_escape%newline + if (stat < 0) then + if (is_iostat_end(stat)) stat = 0 + exit + end if + end do + call new_lexer_from_string(lexer, source) + end select + if (len_trim(filename) > 0) lexer%filename = trim(filename) + + if (stat /= 0) call make_error(error, "Failed to read from unit") +end subroutine new_lexer_from_unit + +!> Create a new instance of a lexer by reading from a string. +subroutine new_lexer_from_string(lexer, string) + !> Instance of the lexer + type(json_lexer), intent(out) :: lexer + !> String to read from + character(len=*), intent(in) :: string + + lexer%chunk = string +end subroutine new_lexer_from_string + +!> Extract information about the source +subroutine get_info(lexer, meta, output) + !> Instance of the lexer + class(json_lexer), intent(in) :: lexer + !> Query about the source + character(*, tfc), intent(in) :: meta + !> Metadata about the source + character(:, tfc), allocatable, intent(out) :: output + + select case(meta) + case("source") + output = lexer%chunk // toml_escape%newline + case("filename") + if (allocated(lexer%filename)) output = lexer%filename + end select +end subroutine get_info + +!> Advance to the next token in the lexer +subroutine next(lexer, token) + !> Instance of the lexer + class(json_lexer), intent(inout) :: lexer + !> Current token + type(toml_token), intent(inout) :: token + + type(toml_token), parameter :: prelude(2) = & + [toml_token(token_kind%equal, 0, 0), toml_token(token_kind%keypath, 1, 0)] + + if (lexer%prelude > 0) then + token = prelude(lexer%prelude) + lexer%prelude = lexer%prelude - 1 + return + end if + + call next_token(lexer, token) +end subroutine next + +!> Actually generate the next token, unbuffered version +subroutine next_token(lexer, token) + !> Instance of the lexer + class(json_lexer), intent(inout) :: lexer + !> Current token + type(toml_token), intent(inout) :: token + + integer :: prev, pos + + ! Consume current token + lexer%pos = lexer%pos + token%last - token%first + 1 + prev = lexer%pos + pos = lexer%pos + + ! If lexer is exhausted, return EOF as early as possible + if (pos > len(lexer%chunk)) then + token = toml_token(token_kind%eof, prev, pos) + return + end if + + select case(lexer%chunk(pos:pos)) + case(" ", toml_escape%tabulator, toml_escape%newline, toml_escape%carriage_return) + do pos = pos, len(lexer%chunk) - 1 + if (all(lexer%chunk(pos+1:pos+1) /= [" ", toml_escape%tabulator,& + & toml_escape%newline, toml_escape%carriage_return])) & + & exit + end do + + token = toml_token(token_kind%whitespace, prev, pos) + return + case(":") + token = toml_token(token_kind%equal, prev, pos) + return + case("{") + token = toml_token(token_kind%lbrace, prev, pos) + return + case("}") + token = toml_token(token_kind%rbrace, prev, pos) + return + case("[") + token = toml_token(token_kind%lbracket, prev, pos) + return + case("]") + token = toml_token(token_kind%rbracket, prev, pos) + return + case('"') + call next_string(lexer, token) + return + case("-", "0":"9") + call next_number(lexer, token) + if (token%kind /= token_kind%invalid) return + case("t", "f") + call next_boolean(lexer, token) + return + case(",") + token = toml_token(token_kind%comma, prev, pos) + return + end select + + do pos=pos,len(lexer%chunk)-1 + if (verify(lexer%chunk(pos+1:pos+1), terminated) <= 0) exit + end do + + token = toml_token(token_kind%invalid, prev, pos) +end subroutine next_token + +!> Process next string token +subroutine next_string(lexer, token) + !> Instance of the lexer + type(json_lexer), intent(inout) :: lexer + !> Current token + type(toml_token), intent(inout) :: token + + character(1, tfc) :: ch + character(*, tfc), parameter :: valid_escape = 'btnfr\"' + integer :: prev, pos, it + logical :: escape, valid, space + + prev = lexer%pos + pos = lexer%pos + + valid = .true. + escape = .false. + + do while(pos < len(lexer%chunk)) + pos = pos + 1 + ch = lexer%chunk(pos:pos) + valid = valid .and. valid_string(ch) + if (escape) then + escape = .false. + valid = valid .and. verify(ch, valid_escape) == 0 + cycle + end if + escape = ch == toml_escape%backslash + if (ch == '"') exit + if (ch == toml_escape%newline) then + pos = pos - 1 + valid = .false. + exit + end if + end do + + valid = valid .and. lexer%chunk(pos:pos) == '"' .and. pos /= prev + token = toml_token(merge(token_kind%string, token_kind%invalid, valid), prev, pos) +end subroutine next_string + +!> Process next number token, can produce either integer or floats +subroutine next_number(lexer, token) + !> Instance of the lexer + type(json_lexer), intent(inout) :: lexer + !> Current token + type(toml_token), intent(inout) :: token + + integer :: prev, pos, point, expo + logical :: minus, okay, zero, first + character(1, tfc) :: ch + integer, parameter :: offset(*) = [0, 1, 2] + + prev = lexer%pos + pos = lexer%pos + token = toml_token(token_kind%invalid, prev, pos) + + point = 0 + expo = 0 + zero = .false. + first = .true. + minus = lexer%chunk(pos:pos) == "-" + if (minus) pos = pos + 1 + + do while(pos <= len(lexer%chunk)) + ch = lexer%chunk(pos:pos) + if (ch == ".") then + if (point > 0 .or. expo > 0) return + zero = .false. + point = pos + pos = pos + 1 + cycle + end if + + if (ch == "e" .or. ch == "E") then + if (expo > 0) return + zero = .false. + expo = pos + pos = pos + 1 + cycle + end if + + if (ch == "+" .or. ch == "-") then + if (.not.any(lexer%chunk(pos-1:pos-1) == ["e", "E"])) return + pos = pos + 1 + cycle + end if + + if (verify(ch, "0123456789") == 0) then + if (zero) return + zero = first .and. ch == "0" + first = .false. + pos = pos + 1 + cycle + end if + + exit + end do + + if (any([expo, point] == pos-1)) return + token = toml_token(merge(token_kind%float, token_kind%int, any([expo, point] > 0)), & + & prev, pos-1) +end subroutine next_number + +!> Process next boolean token +subroutine next_boolean(lexer, token) + !> Instance of the lexer + type(json_lexer), intent(inout) :: lexer + !> Current token + type(toml_token), intent(inout) :: token + + integer :: pos, prev + + prev = lexer%pos + pos = lexer%pos + + do pos=lexer%pos,len(lexer%chunk)-1 + if (verify(lexer%chunk(pos+1:pos+1), terminated) <= 0) exit + end do + + select case(lexer%chunk(prev:pos)) + case default + token = toml_token(token_kind%invalid, prev, pos) + case("true", "false") + token = toml_token(token_kind%bool, prev, pos) + end select +end subroutine next_boolean + +!> Validate characters in string, non-printable characters are invalid in this context +pure function valid_string(ch) result(valid) + character(1, tfc), intent(in) :: ch + logical :: valid + + character(1, tfc), parameter :: x00 = achar(int(z"00")), x08 = achar(int(z"08")), & + & x0b = achar(int(z"0b")), x1f = achar(int(z"1f")), x7f = achar(int(z"7f")) + + valid = & + & .not.(x00 <= ch .and. ch <= x08) .and. & + & .not.(x0b <= ch .and. ch <= x1f) .and. & + & ch /= x7f +end function valid_string + +!> Extract string value of token +subroutine extract_string(lexer, token, string) + !> Instance of the lexer + class(json_lexer), intent(in) :: lexer + !> Token to extract string value from + type(toml_token), intent(in) :: token + !> String value of token + character(len=:), allocatable, intent(out) :: string + + integer :: it, length + logical :: escape + character(1, tfc) :: ch + + length = token%last - token%first + 1 + + select case(token%kind) + case(token_kind%keypath) ! dummy token inserted by lexer prelude + string = "_" + case(token_kind%string) + string = "" + escape = .false. + do it = token%first + 1, token%last - 1 + ch = lexer%chunk(it:it) + if (escape) then + escape = .false. + select case(ch) + case(toml_escape%dquote, toml_escape%backslash); string = string // ch + case("b"); string = string // toml_escape%bspace + case("t"); string = string // toml_escape%tabulator + case("n"); string = string // toml_escape%newline + case("r"); string = string // toml_escape%carriage_return + case("f"); string = string // toml_escape%formfeed + end select + cycle + end if + escape = ch == toml_escape%backslash + if (.not.escape) string = string // ch + end do + end select +end subroutine extract_string + +!> Extract integer value of token +subroutine extract_integer(lexer, token, val) + !> Instance of the lexer + class(json_lexer), intent(in) :: lexer + !> Token to extract integer value from + type(toml_token), intent(in) :: token + !> Integer value of token + integer(tfi), intent(out) :: val + + integer :: first, it, tmp + character(1, tfc) :: ch + character(*, tfc), parameter :: num = "0123456789" + + if (token%kind /= token_kind%int) return + + val = 0 + first = token%first + + if (lexer%chunk(first:first) == "-") first = first + 1 + if (lexer%chunk(first:first) == "0") return + + do it = first, token%last + ch = lexer%chunk(it:it) + tmp = scan(num, ch) - 1 + if (tmp < 0) cycle + val = val * 10 - tmp + end do + + if (lexer%chunk(token%first:token%first) /= "-") val = -val +end subroutine extract_integer + +!> Extract floating point value of token +subroutine extract_float(lexer, token, val) + use, intrinsic :: ieee_arithmetic, only : ieee_value, & + & ieee_positive_inf, ieee_negative_inf, ieee_quiet_nan + !> Instance of the lexer + class(json_lexer), intent(in) :: lexer + !> Token to extract floating point value from + type(toml_token), intent(in) :: token + !> Floating point value of token + real(tfr), intent(out) :: val + + integer :: stat + + if (token%kind /= token_kind%float) return + + read(lexer%chunk(token%first:token%last), *, iostat=stat) val +end subroutine extract_float + +!> Extract boolean value of token +subroutine extract_bool(lexer, token, val) + !> Instance of the lexer + class(json_lexer), intent(in) :: lexer + !> Token to extract boolean value from + type(toml_token), intent(in) :: token + !> Boolean value of token + logical, intent(out) :: val + + if (token%kind /= token_kind%bool) return + + val = lexer%chunk(token%first:token%last) == "true" +end subroutine extract_bool + +!> Extract datetime value of token +subroutine extract_datetime(lexer, token, val) + !> Instance of the lexer + class(json_lexer), intent(in) :: lexer + !> Token to extract datetime value from + type(toml_token), intent(in) :: token + !> Datetime value of token + type(toml_datetime), intent(out) :: val +end subroutine extract_datetime + +end module jonquil_lexer + +!>>>>> ././src/fpm_os.F90 + +module fpm_os + use, intrinsic :: iso_c_binding, only: c_char, c_int, c_null_char, c_ptr, c_associated + use fpm_filesystem, only: exists, join_path, get_home + use fpm_environment, only: os_is_unix + use fpm_error, only: error_t, fatal_error + + implicit none + private + public :: change_directory, get_current_directory, get_absolute_path, convert_to_absolute_path, & + & get_absolute_path_by_cd + + integer(c_int), parameter :: buffersize = 1000_c_int + + character(len=*), parameter :: pwd_env = "PWD" + + interface + function chdir_(path) result(stat) & + + bind(C, name="chdir") + + import :: c_char, c_int + character(kind=c_char, len=1), intent(in) :: path(*) + integer(c_int) :: stat + end function chdir_ + + function getcwd_(buf, bufsize) result(path) & + + bind(C, name="getcwd") + + import :: c_char, c_int, c_ptr + character(kind=c_char, len=1), intent(in) :: buf(*) + integer(c_int), value, intent(in) :: bufsize + type(c_ptr) :: path + end function getcwd_ + + !> Determine the absolute, canonicalized path for a given path. Unix-only. + function realpath(path, resolved_path) result(ptr) bind(C) + import :: c_ptr, c_char, c_int + character(kind=c_char, len=1), intent(in) :: path(*) + character(kind=c_char, len=1), intent(out) :: resolved_path(*) + type(c_ptr) :: ptr + end function realpath + + !> Determine the absolute, canonicalized path for a given path. Windows-only. + function fullpath(resolved_path, path, maxLength) result(ptr) bind(C, name="_fullpath") + import :: c_ptr, c_char, c_int + character(kind=c_char, len=1), intent(in) :: path(*) + character(kind=c_char, len=1), intent(out) :: resolved_path(*) + integer(c_int), value, intent(in) :: maxLength + type(c_ptr) :: ptr + end function fullpath + + !> Determine the absolute, canonicalized path for a given path. + !> Calls custom C routine because the `_WIN32` macro is correctly exported + !> in C using `gfortran`. + function c_realpath(path, resolved_path, maxLength) result(ptr) & + bind(C, name="c_realpath") + import :: c_ptr, c_char, c_int + character(kind=c_char, len=1), intent(in) :: path(*) + character(kind=c_char, len=1), intent(out) :: resolved_path(*) + integer(c_int), value, intent(in) :: maxLength + type(c_ptr) :: ptr + end function c_realpath + end interface + +contains + + subroutine change_directory(path, error) + character(len=*), intent(in) :: path + type(error_t), allocatable, intent(out) :: error + + character(kind=c_char, len=1), allocatable :: cpath(:) + integer :: stat + + allocate (cpath(len(path) + 1)) + call f_c_character(path, cpath, len(path) + 1) + + stat = chdir_(cpath) + + if (stat /= 0) then + call fatal_error(error, "Failed to change directory to '"//path//"'") + end if + end subroutine change_directory + + subroutine get_current_directory(path, error) + character(len=:), allocatable, intent(out) :: path + type(error_t), allocatable, intent(out) :: error + + character(kind=c_char, len=1), allocatable :: cpath(:) + type(c_ptr) :: tmp + + allocate (cpath(buffersize)) + + tmp = getcwd_(cpath, buffersize) + if (c_associated(tmp)) then + call c_f_character(cpath, path) + else + call fatal_error(error, "Failed to retrieve current directory") + end if + + end subroutine get_current_directory + + subroutine f_c_character(rhs, lhs, len) + character(kind=c_char), intent(out) :: lhs(*) + character(len=*), intent(in) :: rhs + integer, intent(in) :: len + integer :: length + length = min(len - 1, len_trim(rhs)) + + lhs(1:length) = transfer(rhs(1:length), lhs(1:length)) + lhs(length + 1:length + 1) = c_null_char + + end subroutine f_c_character + + subroutine c_f_character(rhs, lhs) + character(kind=c_char), intent(in) :: rhs(*) + character(len=:), allocatable, intent(out) :: lhs + + integer :: ii + + do ii = 1, huge(ii) - 1 + if (rhs(ii) == c_null_char) then + exit + end if + end do + + allocate (character(len=ii - 1) :: lhs) + lhs = transfer(rhs(1:ii - 1), lhs) + + end subroutine c_f_character + + !> Determine the canonical, absolute path for the given path. + !> + !> Calls a C routine that uses the `_WIN32` macro to determine the correct function. + !> + !> Cannot be used in bootstrap mode. + subroutine get_realpath(path, real_path, error) + character(len=*), intent(in) :: path + character(len=:), allocatable, intent(out) :: real_path + type(error_t), allocatable, intent(out) :: error + + character(kind=c_char, len=1), allocatable :: appended_path(:) + character(kind=c_char, len=1), allocatable :: cpath(:) + type(c_ptr) :: ptr + + if (.not. exists(path)) then + call fatal_error(error, "Cannot determine absolute path. Path '"//path//"' does not exist.") + return + end if + + allocate (appended_path(len(path) + 1)) + call f_c_character(path, appended_path, len(path) + 1) + + allocate (cpath(buffersize)) + + ptr = c_realpath(appended_path, cpath, buffersize) + + if (c_associated(ptr)) then + call c_f_character(cpath, real_path) + else + call fatal_error(error, "Failed to retrieve absolute path for '"//path//"'.") + end if + + end subroutine + + !> Determine the canonical, absolute path for the given path. + !> Expands home folder (~) on both Unix and Windows. + subroutine get_absolute_path(path, absolute_path, error) + character(len=*), intent(in) :: path + character(len=:), allocatable, intent(out) :: absolute_path + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: home + + if (len_trim(path) < 1) then + call fatal_error(error, 'Path cannot be empty'); return + else if (path(1:1) == '~') then + call get_home(home, error) + if (allocated(error)) return + + if (len_trim(path) == 1) then + absolute_path = home; return + end if + + if (os_is_unix()) then + if (path(2:2) /= '/') then + call fatal_error(error, "Wrong separator in path: '"//path//"'"); return + end if + else + if (path(2:2) /= '\') then + call fatal_error(error, "Wrong separator in path: '"//path//"'"); return + end if + end if + + if (len_trim(path) == 2) then + absolute_path = home; return + end if + + absolute_path = join_path(home, path(3:len_trim(path))) + + if (.not. exists(absolute_path)) then + call fatal_error(error, "Path not found: '"//absolute_path//"'"); return + end if + else + ! Get canonicalized absolute path from either the absolute or the relative path. + call get_realpath(path, absolute_path, error) + end if + end subroutine + + !> Alternative to `get_absolute_path` that uses `chdir`/`_chdir` to determine the absolute path. + !> + !> `get_absolute_path` is preferred but `get_absolute_path_by_cd` can be used in bootstrap mode. + subroutine get_absolute_path_by_cd(path, absolute_path, error) + character(len=*), intent(in) :: path + character(len=:), allocatable, intent(out) :: absolute_path + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: current_path + + call get_current_directory(current_path, error) + if (allocated(error)) return + + call change_directory(path, error) + if (allocated(error)) return + + call get_current_directory(absolute_path, error) + if (allocated(error)) return + + call change_directory(current_path, error) + if (allocated(error)) return + end subroutine + + !> Converts a path to an absolute, canonical path. + subroutine convert_to_absolute_path(path, error) + character(len=:), allocatable, intent(inout) :: path + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: absolute_path + + call get_absolute_path(path, absolute_path, error) + path = absolute_path + end subroutine + +end module fpm_os + +!>>>>> ././src/fpm_pkg_config.f90 + +!># 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 + +!>>>>> ././src/fpm/installer.f90 + +!> Implementation of an installer object. +!> +!> The installer provides a way to install objects to their respective directories +!> in the installation prefix, a generic install command allows to install +!> to any directory within the prefix. +module fpm_installer + use, intrinsic :: iso_fortran_env, only : output_unit + use fpm_environment, only : get_os_type, os_is_unix + use fpm_error, only : error_t, fatal_error + use fpm_filesystem, only : join_path, mkdir, exists, unix_path, windows_path, get_local_prefix + + implicit none + private + public :: installer_t, new_installer + + !> Declaration of the installer type + type :: installer_t + !> Path to installation directory + character(len=:), allocatable :: prefix + !> Binary dir relative to the installation prefix + character(len=:), allocatable :: bindir + !> Library directory relative to the installation prefix + character(len=:), allocatable :: libdir + !> Test program directory relative to the installation prefix + character(len=:), allocatable :: testdir + !> Include directory relative to the installation prefix + character(len=:), allocatable :: includedir + !> Output unit for informative printout + integer :: unit = output_unit + !> Verbosity of the installer + integer :: verbosity = 1 + !> Command to copy objects into the installation prefix + character(len=:), allocatable :: copy + !> Command to move objects into the installation prefix + character(len=:), allocatable :: move + !> Cached operating system + integer :: os + contains + !> Install an executable in its correct subdirectory + procedure :: install_executable + !> Install a library in its correct subdirectory + procedure :: install_library + !> Install a header/module in its correct subdirectory + procedure :: install_header + !> Install a test program in its correct subdirectory + procedure :: install_test + !> Install a generic file into a subdirectory in the installation prefix + procedure :: install + !> Run an installation command, type-bound for unit testing purposes + procedure :: run + !> Create a new directory in the prefix, type-bound for unit testing purposes + procedure :: make_dir + end type installer_t + + !> Default name of the binary subdirectory + character(len=*), parameter :: default_bindir = "bin" + + !> Default name of the library subdirectory + character(len=*), parameter :: default_libdir = "lib" + + !> Default name of the test subdirectory + character(len=*), parameter :: default_testdir = "test" + + !> Default name of the include subdirectory + character(len=*), parameter :: default_includedir = "include" + + !> Copy command on Unix platforms + character(len=*), parameter :: default_copy_unix = "cp" + + !> Copy command on Windows platforms + character(len=*), parameter :: default_copy_win = "copy" + + !> Copy command on Unix platforms + character(len=*), parameter :: default_force_copy_unix = "cp -f" + + !> Copy command on Windows platforms + character(len=*), parameter :: default_force_copy_win = "copy /Y" + + !> Move command on Unix platforms + character(len=*), parameter :: default_move_unix = "mv" + + !> Move command on Windows platforms + character(len=*), parameter :: default_move_win = "move" + +contains + + !> Create a new instance of an installer + subroutine new_installer(self, prefix, bindir, libdir, includedir, testdir, verbosity, & + copy, move) + !> Instance of the installer + type(installer_t), intent(out) :: self + !> Path to installation directory + character(len=*), intent(in), optional :: prefix + !> Binary dir relative to the installation prefix + character(len=*), intent(in), optional :: bindir + !> Library directory relative to the installation prefix + character(len=*), intent(in), optional :: libdir + !> Include directory relative to the installation prefix + character(len=*), intent(in), optional :: includedir + !> Test directory relative to the installation prefix + character(len=*), intent(in), optional :: testdir + !> Verbosity of the installer + integer, intent(in), optional :: verbosity + !> Copy command + character(len=*), intent(in), optional :: copy + !> Move command + character(len=*), intent(in), optional :: move + + self%os = get_os_type() + + ! By default, never prompt the user for overwrites + if (present(copy)) then + self%copy = copy + else + if (os_is_unix(self%os)) then + self%copy = default_force_copy_unix + else + self%copy = default_force_copy_win + end if + end if + + if (present(move)) then + self%move = move + else + if (os_is_unix(self%os)) then + self%move = default_move_unix + else + self%move = default_move_win + end if + end if + + if (present(includedir)) then + self%includedir = includedir + else + self%includedir = default_includedir + end if + + if (present(testdir)) then + self%testdir = testdir + else + self%testdir = default_testdir + end if + + if (present(prefix)) then + self%prefix = prefix + else + self%prefix = get_local_prefix(self%os) + end if + + if (present(bindir)) then + self%bindir = bindir + else + self%bindir = default_bindir + end if + + if (present(libdir)) then + self%libdir = libdir + else + self%libdir = default_libdir + end if + + if (present(verbosity)) then + self%verbosity = verbosity + else + self%verbosity = 1 + end if + + end subroutine new_installer + + !> Install an executable in its correct subdirectory + subroutine install_executable(self, executable, error) + !> Instance of the installer + class(installer_t), intent(inout) :: self + !> Path to the executable + character(len=*), intent(in) :: executable + !> Error handling + type(error_t), allocatable, intent(out) :: error + integer :: ll + + if (.not.os_is_unix(self%os)) then + ll = len(executable) + if (executable(max(1, ll-3):ll) /= ".exe") then + call self%install(executable//".exe", self%bindir, error) + return + end if + end if + + call self%install(executable, self%bindir, error) + + end subroutine install_executable + + !> Install a library in its correct subdirectory + subroutine install_library(self, library, error) + !> Instance of the installer + class(installer_t), intent(inout) :: self + !> Path to the library + character(len=*), intent(in) :: library + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call self%install(library, self%libdir, error) + end subroutine install_library + + !> Install a test program in its correct subdirectory + subroutine install_test(self, test, error) + !> Instance of the installer + class(installer_t), intent(inout) :: self + !> Path to the test executable + character(len=*), intent(in) :: test + !> Error handling + type(error_t), allocatable, intent(out) :: error + integer :: ll + + if (.not.os_is_unix(self%os)) then + ll = len(test) + if (test(max(1, ll-3):ll) /= ".exe") then + call self%install(test//".exe", self%testdir, error) + return + end if + end if + + call self%install(test, self%testdir, error) + + end subroutine install_test + + !> Install a header/module in its correct subdirectory + subroutine install_header(self, header, error) + !> Instance of the installer + class(installer_t), intent(inout) :: self + !> Path to the header + character(len=*), intent(in) :: header + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call self%install(header, self%includedir, error) + end subroutine install_header + + !> Install a generic file into a subdirectory in the installation prefix + subroutine install(self, source, destination, error) + !> Instance of the installer + class(installer_t), intent(inout) :: self + !> Path to the original file + character(len=*), intent(in) :: source + !> Path to the destination inside the prefix + character(len=*), intent(in) :: destination + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: install_dest + + install_dest = join_path(self%prefix, destination) + if (os_is_unix(self%os)) then + install_dest = unix_path(install_dest) + else + install_dest = windows_path(install_dest) + end if + call self%make_dir(install_dest, error) + if (allocated(error)) return + + if (self%verbosity > 0) then + if (exists(install_dest)) then + write(self%unit, '("# Update:", 1x, a, 1x, "->", 1x, a)') & + source, install_dest + else + write(self%unit, '("# Install:", 1x, a, 1x, "->", 1x, a)') & + source, install_dest + end if + end if + + ! Use force-copy to never prompt the user for overwrite if a package was already installed + call self%run(self%copy//' "'//source//'" "'//install_dest//'"', error) + + if (allocated(error)) return + + end subroutine install + + !> Create a new directory in the prefix + subroutine make_dir(self, dir, error) + !> Instance of the installer + class(installer_t), intent(inout) :: self + !> Directory to be created + character(len=*), intent(in) :: dir + !> Error handling + type(error_t), allocatable, intent(out) :: error + + if (.not.exists(dir)) then + if (self%verbosity > 1) then + write(self%unit, '("# Dir:", 1x, a)') dir + end if + call mkdir(dir) + end if + end subroutine make_dir + + !> Run an installation command + subroutine run(self, command, error) + !> Instance of the installer + class(installer_t), intent(inout) :: self + !> Command to be launched + character(len=*), intent(in) :: command + !> Error handling + type(error_t), allocatable, intent(out) :: error + integer :: stat + + if (self%verbosity > 1) then + write(self%unit, '("# Run:", 1x, a)') command + end if + call execute_command_line(command, exitstat=stat) + + if (stat /= 0) then + call fatal_error(error, "Failed in command: '"//command//"'") + return + end if + end subroutine run + +end module fpm_installer + +!>>>>> build/dependencies/toml-f/src/tomlf/diagnostic.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Diagnostic message support for TOML Fortran +module tomlf_diagnostic + use tomlf_terminal, only : toml_terminal, ansi_code, operator(//), operator(+) + implicit none + private + + public :: render + public :: toml_diagnostic, toml_label + + interface render + module procedure render_diagnostic + module procedure render_text + module procedure render_text_with_label + module procedure render_text_with_labels + end interface render + + !> Enumerator for diagnostic levels + type :: level_enum + integer :: error = 0 + integer :: warning = 1 + integer :: help = 2 + integer :: note = 3 + integer :: info = 4 + end type level_enum + + !> Actual enumerator values + type(level_enum), parameter, public :: toml_level = level_enum() + + type toml_label + !> Level of message + integer :: level + !> Primary message + logical :: primary + !> First and last character of message + integer :: first, last + !> Message text + character(len=:), allocatable :: text + !> Identifier of context + character(len=:), allocatable :: source + end type toml_label + + interface toml_label + module procedure new_label + end interface toml_label + + !> Definition of diagnostic message + type :: toml_diagnostic + !> Level of message + integer :: level + !> Primary message + character(len=:), allocatable :: message + !> Context of the diagnostic source + character(len=:), allocatable :: source + !> Messages associated with this diagnostic + type(toml_label), allocatable :: label(:) + end type toml_diagnostic + + interface toml_diagnostic + module procedure new_diagnostic + end interface toml_diagnostic + + type :: line_token + integer :: first, last + end type line_token + + character(len=*), parameter :: nl = new_line('a') + +contains + +pure function new_label(level, first, last, text, primary) result(new) + integer, intent(in) :: level + integer, intent(in) :: first, last + character(len=*), intent(in), optional :: text + logical, intent(in), optional :: primary + type(toml_label) :: new + + if (present(text)) new%text = text + new%level = level + new%first = first + new%last = last + if (present(primary)) then + new%primary = primary + else + new%primary = .false. + end if +end function new_label + +!> Create new diagnostic message +pure function new_diagnostic(level, message, source, label) result(new) + !> Level of message + integer, intent(in) :: level + !> Primary message + character(len=*), intent(in), optional :: message + !> Context of the diagnostic source + character(len=*), intent(in), optional :: source + !> Messages associated with this diagnostic + type(toml_label), intent(in), optional :: label(:) + type(toml_diagnostic) :: new + + new%level = level + if (present(message)) new%message = message + if (present(source)) new%source = source + if (present(label)) new%label = label +end function new_diagnostic + +pure function line_tokens(input) result(token) + character(len=*), intent(in) :: input + type(line_token), allocatable :: token(:) + + integer :: first, last + + first = 1 + last = 1 + allocate(token(0)) + do while (first <= len(input)) + if (input(last:last) /= nl) then + last = last + 1 + cycle + end if + + token = [token, line_token(first, last-1)] + first = last + 1 + last = first + end do +end function line_tokens + +recursive pure function render_diagnostic(diag, input, color) result(string) + character(len=*), intent(in) :: input + type(toml_diagnostic), intent(in) :: diag + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + string = & + render_message(diag%level, diag%message, color) + + if (allocated(diag%label)) then + string = string // nl // & + render_text_with_labels(input, diag%label, color, source=diag%source) + end if +end function render_diagnostic + +pure function render_message(level, message, color) result(string) + integer, intent(in) :: level + character(len=*), intent(in), optional :: message + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + if (present(message)) then + string = & + level_name(level, color) // color%bold // ": " // message // color%reset + else + string = & + level_name(level, color) + end if +end function render_message + +pure function level_name(level, color) result(string) + integer, intent(in) :: level + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + select case(level) + case(toml_level%error) + string = color%bold + color%red // "error" // color%reset + case(toml_level%warning) + string = color%bold + color%yellow // "warning" // color%reset + case(toml_level%help) + string = color%bold + color%cyan // "help" // color%reset + case(toml_level%note) + string = color%bold + color%blue // "note" // color%reset + case(toml_level%info) + string = color%bold + color%magenta // "info" // color%reset + case default + string = color%bold + color%blue // "unknown" // color%reset + end select +end function level_name + +pure function render_source(source, offset, color) result(string) + character(len=*), intent(in) :: source + integer, intent(in) :: offset + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + string = & + & repeat(" ", offset) // (color%bold + color%blue) // "-->" // color%reset // " " // source +end function render_source + +function render_text(input, color, source) result(string) + character(len=*), intent(in) :: input + type(toml_terminal), intent(in) :: color + character(len=*), intent(in), optional :: source + character(len=:), allocatable :: string + + integer :: it, offset + type(line_token), allocatable :: token(:) + + allocate(token(0)) ! avoid compiler warning + token = line_tokens(input) + offset = integer_width(size(token)) + + if (present(source)) then + string = render_source(source, offset, color) // nl // & + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + else + string = & + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + end if + + do it = 1, size(token) + string = string // nl //& + & render_line(input(token(it)%first:token(it)%last), to_string(it, offset), color) + end do + string = string // nl // & + repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + +end function render_text + +function render_text_with_label(input, label, color, source) result(string) + character(len=*), intent(in) :: input + type(toml_label), intent(in) :: label + type(toml_terminal), intent(in) :: color + character(len=*), intent(in), optional :: source + character(len=:), allocatable :: string + + integer :: it, offset, first, last, line, shift + type(line_token), allocatable :: token(:) + + allocate(token(0)) ! avoid compiler warning + token = line_tokens(input) + line = count(token%first < label%first) + shift = token(line)%first - 1 + first = max(1, line - 1) + last = min(size(token), line + 1) + offset = integer_width(last) + + if (present(source)) then + string = render_source(source, offset, color) // ":" // & + & to_string(line) // ":" // & + & to_string(label%first) + if (label%first /= label%last) then + string = string // "-" // to_string(label%last) + end if + end if + string = string // nl // & + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + + do it = first, last + string = string // nl //& + & render_line(input(token(it)%first:token(it)%last), & + & to_string(it, offset), color) + if (it == line) then + string = string // nl //& + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset // & + & render_label(label, shift, color) + end if + end do + string = string // nl // & + repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + +end function render_text_with_label + +pure function render_text_with_labels(input, label, color, source) result(string) + character(len=*), intent(in) :: input + type(toml_label), intent(in) :: label(:) + type(toml_terminal), intent(in) :: color + character(len=*), intent(in), optional :: source + character(len=:), allocatable :: string + + integer :: it, il, offset, first, last, line(size(label)), shift(size(label)) + type(line_token), allocatable :: token(:) + logical, allocatable :: display(:) + + allocate(token(0)) ! avoid compiler warning + token = line_tokens(input) + line(:) = [(count(token%first <= label(it)%first), it = 1, size(label))] + shift(:) = token(line)%first - 1 + first = max(1, minval(line)) + last = min(size(token), maxval(line)) + offset = integer_width(last) + + it = 1 ! Without a primary we use the first label + do il = 1, size(label) + if (label(il)%primary) then + it = il + exit + end if + end do + + if (present(source)) then + string = render_source(source, offset, color) // ":" // & + & to_string(line(it)) // ":" // & + & to_string(label(it)%first-shift(it)) + if (label(it)%first /= label(it)%last) then + string = string // "-" // to_string(label(it)%last-shift(it)) + end if + end if + string = string // nl // & + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + + allocate(display(first:last), source=.false.) + do il = 1, size(label) + ! display(max(first, line(il) - 1):min(last, line(il) + 1)) = .true. + display(line(il)) = .true. + end do + + do it = first, last + if (.not.display(it)) then + if (display(it-1) .and. count(display(it:)) > 0) then + string = string // nl //& + & repeat(" ", offset + 1) // (color%bold + color%blue) // ":" // color%reset + end if + cycle + end if + + string = string // nl //& + & render_line(input(token(it)%first:token(it)%last), & + & to_string(it, offset), color) + if (any(it == line)) then + do il = 1, size(label) + if (line(il) /= it) cycle + string = string // nl //& + & repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset // & + & render_label(label(il), shift(il), color) + end do + end if + end do + string = string // nl // & + repeat(" ", offset + 1) // (color%bold + color%blue) // "|" // color%reset + +end function render_text_with_labels + +pure function render_label(label, shift, color) result(string) + type(toml_label), intent(in) :: label + integer, intent(in) :: shift + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + integer :: width + character :: marker + type(ansi_code) :: this_color + + marker = merge("^", "-", label%primary) + width = label%last - label%first + 1 + this_color = level_color(label%level, color) + + string = & + & repeat(" ", label%first - shift) // this_color // repeat(marker, width) // color%reset + if (allocated(label%text)) then + string = string // & + & " " // this_color // label%text // color%reset + end if + +end function render_label + +pure function level_color(level, color) result(this_color) + integer, intent(in) :: level + type(toml_terminal), intent(in) :: color + type(ansi_code) :: this_color + + select case(level) + case(toml_level%error) + this_color = color%bold + color%red + case(toml_level%warning) + this_color = color%bold + color%yellow + case(toml_level%help) + this_color = color%bold + color%cyan + case(toml_level%info) + this_color = color%bold + color%magenta + case default + this_color = color%bold + color%blue + end select +end function level_color + +pure function render_line(input, line, color) result(string) + character(len=*), intent(in) :: input + character(len=*), intent(in) :: line + type(toml_terminal), intent(in) :: color + character(len=:), allocatable :: string + + string = & + & line // " " // (color%bold + color%blue) // "|" // color%reset // " " // input +end function render_line + +pure function integer_width(input) result(width) + integer, intent(in) :: input + integer :: width + + integer :: val + + val = input + width = 0 + do while (val /= 0) + val = val / 10 + width = width + 1 + end do + +end function integer_width + +!> Represent an integer as character sequence. +pure function to_string(val, width) result(string) + integer, intent(in) :: val + integer, intent(in), optional :: width + character(len=:), allocatable :: string + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer :: n + character(len=1), parameter :: numbers(0:9) = & + ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"] + + if (val == 0) then + string = numbers(0) + return + end if + + n = abs(val) + buffer = "" + + pos = buffer_len + 1 + do while (n > 0) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10)) + n = n/10 + end do + if (val < 0) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + if (present(width)) then + string = repeat(" ", max(width-(buffer_len+1-pos), 0)) // buffer(pos:) + else + string = buffer(pos:) + end if +end function to_string + +end module tomlf_diagnostic + +!>>>>> build/dependencies/toml-f/src/tomlf/structure/list.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Abstract base class definitions for data structures to store TOML values +module tomlf_structure_list + use tomlf_constants, only : tfc + use tomlf_type_value, only : toml_value, toml_key + implicit none + private + + public :: toml_list_structure + + !> Ordered data structure, allows iterations + type, abstract :: toml_list_structure + contains + + !> Get number of TOML values in the structure + procedure(get_len), deferred :: get_len + + !> Push back a TOML value to the structure + procedure(push_back), deferred :: push_back + + !> Remove the first element from the structure + procedure(shift), deferred :: shift + + !> Remove the last element from the structure + procedure(pop), deferred :: pop + + !> Get TOML value at a given index + procedure(get), deferred :: get + + !> Destroy the data structure + procedure(destroy), deferred :: destroy + + end type toml_list_structure + + abstract interface + !> Get number of TOML values in the structure + pure function get_len(self) result(length) + import :: toml_list_structure + + !> Instance of the structure + class(toml_list_structure), intent(in), target :: self + + !> Current length of the ordered structure + integer :: length + end function get_len + + !> Get TOML value at a given index + subroutine get(self, idx, ptr) + import :: toml_list_structure, toml_value + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> Position in the ordered structure + integer, intent(in) :: idx + + !> Pointer to the stored value at given index + class(toml_value), pointer, intent(out) :: ptr + end subroutine get + + !> Push back a TOML value to the structure + subroutine push_back(self, val) + import :: toml_list_structure, toml_value + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> TOML value to be stored + class(toml_value), allocatable, intent(inout) :: val + + end subroutine push_back + + !> Remove the first element from the data structure + subroutine shift(self, val) + import :: toml_list_structure, toml_value + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + end subroutine shift + + !> Remove the last element from the data structure + subroutine pop(self, val) + import :: toml_list_structure, toml_value + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + end subroutine pop + + !> Delete TOML value at a given key + subroutine delete(self, key) + import :: toml_list_structure, toml_value, tfc + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + end subroutine delete + + !> Deconstructor for data structure + subroutine destroy(self) + import :: toml_list_structure + + !> Instance of the structure + class(toml_list_structure), intent(inout), target :: self + + end subroutine destroy + + end interface + +end module tomlf_structure_list + +!>>>>> build/dependencies/toml-f/src/tomlf/structure/map.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Abstract base class definitions for data structures to store TOML values +module tomlf_structure_map + use tomlf_constants, only : tfc + use tomlf_type_value, only : toml_value, toml_key + implicit none + private + + public :: toml_map_structure + + !> Abstract data structure + type, abstract :: toml_map_structure + contains + + !> Get TOML value at a given key + procedure(get), deferred :: get + + !> Push back a TOML value to the structure + procedure(push_back), deferred :: push_back + + !> Get list of all keys in the structure + procedure(get_keys), deferred :: get_keys + + !> Remove TOML value at a given key and return it + procedure(pop), deferred :: pop + + !> Delete TOML value at a given key + procedure(delete), deferred :: delete + + !> Destroy the data structure + procedure(destroy), deferred :: destroy + + end type toml_map_structure + + abstract interface + !> Get TOML value at a given key + subroutine get(self, key, ptr) + import :: toml_map_structure, toml_value, tfc + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the stored value at given key + class(toml_value), pointer, intent(out) :: ptr + end subroutine get + + !> Push back a TOML value to the structure + subroutine push_back(self, val) + import :: toml_map_structure, toml_value + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> TOML value to be stored + class(toml_value), allocatable, intent(inout) :: val + + end subroutine push_back + + !> Get list of all keys in the structure + subroutine get_keys(self, list) + import :: toml_map_structure, toml_key + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> List of all keys + type(toml_key), allocatable, intent(out) :: list(:) + + end subroutine get_keys + + !> Remove TOML value at a given key and return it + subroutine pop(self, key, val) + import :: toml_map_structure, toml_value, tfc + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Removed TOML value + class(toml_value), allocatable, intent(out) :: val + + end subroutine pop + + !> Delete TOML value at a given key + subroutine delete(self, key) + import :: toml_map_structure, toml_value, tfc + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + end subroutine delete + + !> Deconstructor for data structure + subroutine destroy(self) + import :: toml_map_structure + + !> Instance of the structure + class(toml_map_structure), intent(inout), target :: self + + end subroutine destroy + + end interface + +end module tomlf_structure_map + +!>>>>> build/dependencies/toml-f/src/tomlf/structure/node.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a basic storage structure as pointer list of pointers. +!> +!> This implementation does purposely not use pointer attributes in the +!> datastructure to make it safer to work with. +module tomlf_structure_node + use tomlf_type_value, only : toml_value + implicit none + private + + public :: toml_node, resize + + !> Wrapped TOML value to generate pointer list + type :: toml_node + + !> TOML value payload + class(toml_value), allocatable :: val + + end type toml_node + + !> Initial storage capacity of the datastructure + integer, parameter :: initial_size = 16 + +contains + +!> Change size of the TOML value list +subroutine resize(list, n) + + !> Array of TOML values to be resized + type(toml_node), allocatable, intent(inout), target :: list(:) + + !> New size of the list + integer, intent(in) :: n + + type(toml_node), allocatable, target :: tmp(:) + integer :: i + + if (allocated(list)) then + call move_alloc(list, tmp) + allocate(list(n)) + + do i = 1, min(size(tmp), n) + if (allocated(tmp(i)%val)) then + call move_alloc(tmp(i)%val, list(i)%val) + end if + end do + + do i = n+1, size(tmp) + if (allocated(tmp(i)%val)) then + call tmp(i)%val%destroy + deallocate(tmp(i)%val) + end if + end do + + deallocate(tmp) + else + allocate(list(n)) + end if + +end subroutine resize + +end module tomlf_structure_node + +!>>>>> build/dependencies/toml-f/src/tomlf/type/keyval.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML key-value pair +module tomlf_type_keyval + use tomlf_constants, only : tfc, tfr, tfi, toml_type + use tomlf_datetime, only : toml_datetime + use tomlf_type_value, only : toml_value, toml_visitor + implicit none + private + + public :: toml_keyval, new_keyval, new + + !> Generic TOML value + type, abstract :: generic_value + end type generic_value + + !> TOML real value + type, extends(generic_value) :: float_value + real(tfr) :: raw + end type float_value + + !> TOML integer value + type, extends(generic_value) :: integer_value + integer(tfi) :: raw + end type integer_value + + !> TOML boolean value + type, extends(generic_value) :: boolean_value + logical :: raw + end type boolean_value + + !> TOML datetime value + type, extends(generic_value) :: datetime_value + type(toml_datetime) :: raw + end type datetime_value + + !> TOML string value + type, extends(generic_value) :: string_value + character(:, tfc), allocatable :: raw + end type string_value + + !> TOML key-value pair + type, extends(toml_value) :: toml_keyval + + !> Actual TOML value + class(generic_value), allocatable :: val + + !> Origin of value + integer :: origin_value = 0 + + contains + + !> Get the value stored in the key-value pair + generic :: get => get_float, get_integer, get_boolean, get_datetime, get_string + procedure :: get_float + procedure :: get_integer + procedure :: get_boolean + procedure :: get_datetime + procedure :: get_string + + !> Set the value for the key-value pair + generic :: set => set_float, set_integer, set_boolean, set_datetime, set_string + procedure :: set_float + procedure :: set_integer + procedure :: set_boolean + procedure :: set_datetime + procedure :: set_string + + !> Get the type of the value stored in the key-value pair + procedure :: get_type + + !> Release allocation hold by TOML key-value pair + procedure :: destroy + + end type toml_keyval + + !> Overloaded constructor for TOML values + interface new + module procedure :: new_keyval + end interface + +contains + +!> Constructor to create a new TOML key-value pair +subroutine new_keyval(self) + + !> Instance of the TOML key-value pair + type(toml_keyval), intent(out) :: self + + associate(self => self); end associate + +end subroutine new_keyval + +!> Deconstructor to cleanup allocations (optional) +subroutine destroy(self) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + if (allocated(self%key)) then + deallocate(self%key) + end if + + if (allocated(self%val)) then + deallocate(self%val) + end if + +end subroutine destroy + +!> Obtain real value from TOML key-value pair +subroutine get_float(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + real(tfr), pointer, intent(out) :: val + + val => cast_float(self%val) +end subroutine get_float + +!> Obtain integer value from TOML key-value pair +subroutine get_integer(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + integer(tfi), pointer, intent(out) :: val + + val => cast_integer(self%val) +end subroutine get_integer + +!> Obtain boolean value from TOML key-value pair +subroutine get_boolean(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + logical, pointer, intent(out) :: val + + val => cast_boolean(self%val) +end subroutine get_boolean + +!> Obtain datetime value from TOML key-value pair +subroutine get_datetime(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + type(toml_datetime), pointer, intent(out) :: val + + val => cast_datetime(self%val) +end subroutine get_datetime + +!> Obtain datetime value from TOML key-value pair +subroutine get_string(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value to be assigned + character(:, tfc), pointer, intent(out) :: val + + val => cast_string(self%val) +end subroutine get_string + +!> Obtain real value from TOML key-value pair +subroutine set_float(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + real(tfr), intent(in) :: val + + type(float_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_float + +!> Obtain integer value from TOML key-value pair +subroutine set_integer(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + integer(tfi), intent(in) :: val + + type(integer_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_integer + +!> Obtain boolean value from TOML key-value pair +subroutine set_boolean(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + logical, intent(in) :: val + + type(boolean_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_boolean + +!> Obtain datetime value from TOML key-value pair +subroutine set_datetime(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + type(toml_datetime), intent(in) :: val + + type(datetime_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_datetime + +!> Obtain datetime value from TOML key-value pair +subroutine set_string(self, val) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(inout) :: self + + !> Value to be assigned + character(*, tfc), intent(in) :: val + + type(string_value), allocatable :: tmp + + allocate(tmp) + tmp%raw = val + call move_alloc(tmp, self%val) +end subroutine set_string + +!> Get the type of the value stored in the key-value pair +pure function get_type(self) result(value_type) + + !> Instance of the TOML key-value pair + class(toml_keyval), intent(in) :: self + + !> Value type + integer :: value_type + + select type(val => self%val) + class default + value_type = toml_type%invalid + type is(float_value) + value_type = toml_type%float + type is(integer_value) + value_type = toml_type%int + type is(boolean_value) + value_type = toml_type%boolean + type is(datetime_value) + value_type = toml_type%datetime + type is(string_value) + value_type = toml_type%string + end select +end function get_type + +function cast_float(val) result(ptr) + class(generic_value), intent(in), target :: val + real(tfr), pointer :: ptr + + nullify(ptr) + select type(val) + type is(float_value) + ptr => val%raw + end select +end function cast_float + +function cast_integer(val) result(ptr) + class(generic_value), intent(in), target :: val + integer(tfi), pointer :: ptr + + nullify(ptr) + select type(val) + type is(integer_value) + ptr => val%raw + end select +end function cast_integer + +function cast_boolean(val) result(ptr) + class(generic_value), intent(in), target :: val + logical, pointer :: ptr + + nullify(ptr) + select type(val) + type is(boolean_value) + ptr => val%raw + end select +end function cast_boolean + +function cast_datetime(val) result(ptr) + class(generic_value), intent(in), target :: val + type(toml_datetime), pointer :: ptr + + nullify(ptr) + select type(val) + type is(datetime_value) + ptr => val%raw + end select +end function cast_datetime + +function cast_string(val) result(ptr) + class(generic_value), intent(in), target :: val + character(:, tfc), pointer :: ptr + + nullify(ptr) + select type(val) + type is(string_value) + ptr => val%raw + end select +end function cast_string + +end module tomlf_type_keyval + +!>>>>> build/dependencies/toml-f/src/tomlf/utils/sort.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Sorting algorithms to work with hash maps +module tomlf_utils_sort + use tomlf_type_value, only : toml_key + implicit none + private + + public :: sort, compare_less + + !> Create overloaded interface for export + interface sort + module procedure :: sort_keys + end interface + + abstract interface + !> Define order relation between two TOML keys + pure function compare_less(lhs, rhs) result(less) + import :: toml_key + !> Left hand side TOML key in comparison + type(toml_key), intent (in) :: lhs + !> Right hand side TOML key in comparison + type(toml_key), intent (in) :: rhs + !> Comparison result + logical :: less + end function compare_less + end interface + +contains + + !> Entry point for sorting algorithm + pure subroutine sort_keys(list, idx, compare) + + !> List of TOML keys to be sorted + type(toml_key), intent(inout) :: list(:) + + !> Optionally, mapping from unsorted list to sorted list + integer, intent(out), optional :: idx(:) + + !> Function implementing the order relation between two TOML keys + procedure(compare_less), optional :: compare + + integer :: low, high, i + type(toml_key), allocatable :: sorted(:) + integer, allocatable :: indexarray(:) + + low = 1 + high = size(list) + + allocate(sorted, source=list) + + allocate(indexarray(high), source=[(i, i=low, high)]) + + if (present(compare)) then + call quicksort(sorted, indexarray, low, high, compare) + else + call quicksort(sorted, indexarray, low, high, compare_keys_less) + end if + + do i = low, high + list(i) = sorted(indexarray(i)) + end do + + if (present(idx)) then + idx = indexarray + end if + + end subroutine sort_keys + + !> Actual quick sort implementation + pure recursive subroutine quicksort(list, idx, low, high, less) + type(toml_key), intent(inout) :: list(:) + integer, intent(inout) :: idx(:) + integer, intent(in) :: low, high + procedure(compare_less) :: less + + integer :: i, last + integer :: pivot + + if (low < high) then + + call swap(idx(low), idx((low + high)/2)) + last = low + do i = low + 1, high + if (less(list(idx(i)), list(idx(low)))) then + last = last + 1 + call swap(idx(last), idx(i)) + end if + end do + call swap(idx(low), idx(last)) + pivot = last + + call quicksort(list, idx, low, pivot - 1, less) + call quicksort(list, idx, pivot + 1, high, less) + end if + + end subroutine quicksort + + !> Swap two integer values + pure subroutine swap(lhs, rhs) + integer, intent(inout) :: lhs + integer, intent(inout) :: rhs + + integer :: tmp + + tmp = lhs + lhs = rhs + rhs = tmp + + end subroutine swap + + !> Default comparison between two TOML keys + pure function compare_keys_less(lhs, rhs) result(less) + type(toml_key), intent (in) :: lhs + type(toml_key), intent (in) :: rhs + logical :: less + + less = lhs%key < rhs%key + + end function compare_keys_less + +end module tomlf_utils_sort + +!>>>>> ././src/fpm_command_line.f90 + +!># Definition of the command line interface +!> +!> This module uses [M_CLI2](https://github.com/urbanjost/M_CLI2) to define +!> the command line interface. +!> To define a command line interface create a new command settings type +!> from the [[fpm_cmd_settings]] base class or the respective parent command +!> settings. +!> +!> The subcommand is selected by the first non-option argument in the command +!> line. In the subcase block the actual command line is defined and transferred +!> to an instance of the [[fpm_cmd_settings]], the actual type is used by the +!> *fpm* main program to determine which command entry point is chosen. +!> +!> To add a new subcommand add a new case to select construct and specify the +!> wanted command line and the expected default values. +!> Some of the following points also apply if you add a new option or argument +!> to an existing *fpm* subcommand. +!> At this point you should create a help page for the new command in a simple +!> catman-like format as well in the ``set_help`` procedure. +!> Make sure to register new subcommands in the ``fpm-manual`` command by adding +!> them to the manual character array and in the help/manual case as well. +!> You should add the new command to the synopsis section of the ``fpm-list``, +!> ``fpm-help`` and ``fpm --list`` help pages below to make sure the help output +!> is complete and consistent as well. +module fpm_command_line +use fpm_environment, only : get_os_type, get_env, & + OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & + OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD, OS_NAME +use M_CLI2, only : set_args, lget, sget, unnamed, remaining, specified +use M_CLI2, only : get_subcommand, CLI_RESPONSE_FILE +use fpm_strings, only : lower, split, to_fortran_name, is_fortran_name, remove_characters_in_set, & + string_t, glob +use fpm_filesystem, only : basename, canon_path, which, run +use fpm_environment, only : get_command_arguments_quoted +use fpm_error, only : fpm_stop, error_t +use fpm_os, only : get_current_directory +use fpm_release, only : fpm_version, version_t +use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & + & stdout=>output_unit, & + & stderr=>error_unit + +implicit none + +private +public :: fpm_cmd_settings, & + fpm_build_settings, & + fpm_install_settings, & + fpm_export_settings, & + fpm_new_settings, & + fpm_run_settings, & + fpm_test_settings, & + fpm_update_settings, & + fpm_clean_settings, & + fpm_publish_settings, & + get_command_line_settings, & + get_fpm_env + +type, abstract :: fpm_cmd_settings + character(len=:), allocatable :: working_dir + logical :: verbose=.true. +end type + +integer,parameter :: ibug=4096 + +type, extends(fpm_cmd_settings) :: fpm_new_settings + character(len=:),allocatable :: name + logical :: with_executable=.false. + logical :: with_test=.false. + logical :: with_lib=.true. + logical :: with_example=.false. + logical :: with_full=.false. + logical :: with_bare=.false. + logical :: backfill=.true. +end type + +type, extends(fpm_cmd_settings) :: fpm_build_settings + logical :: list=.false. + logical :: show_model=.false. + logical :: build_tests=.false. + logical :: prune=.true. + character(len=:),allocatable :: dump + character(len=:),allocatable :: compiler + character(len=:),allocatable :: c_compiler + character(len=:),allocatable :: cxx_compiler + character(len=:),allocatable :: archiver + character(len=:),allocatable :: profile + character(len=:),allocatable :: flag + character(len=:),allocatable :: cflag + character(len=:),allocatable :: cxxflag + character(len=:),allocatable :: ldflag +end type + +type, extends(fpm_build_settings) :: fpm_run_settings + character(len=ibug),allocatable :: name(:) + character(len=:),allocatable :: args ! passed to the app + character(len=:),allocatable :: runner + character(len=:),allocatable :: runner_args ! passed to the runner + logical :: example + contains + procedure :: runner_command + procedure :: name_ID +end type + +type, extends(fpm_run_settings) :: fpm_test_settings +end type + +type, extends(fpm_build_settings) :: fpm_install_settings + character(len=:), allocatable :: prefix + character(len=:), allocatable :: bindir + character(len=:), allocatable :: libdir + character(len=:), allocatable :: testdir + character(len=:), allocatable :: includedir + logical :: no_rebuild +end type + +!> Settings for interacting and updating with project dependencies +type, extends(fpm_cmd_settings) :: fpm_update_settings + character(len=ibug),allocatable :: name(:) + character(len=:),allocatable :: dump + logical :: fetch_only + logical :: clean +end type + +!> Settings for exporting model data +type, extends(fpm_build_settings) :: fpm_export_settings + character(len=:),allocatable :: dump_manifest + character(len=:),allocatable :: dump_dependencies + character(len=:),allocatable :: dump_model +end type + +type, extends(fpm_cmd_settings) :: fpm_clean_settings + logical :: clean_skip = .false. + logical :: clean_all = .false. + logical :: registry_cache = .false. +end type + +type, extends(fpm_build_settings) :: fpm_publish_settings + logical :: show_package_version = .false. + logical :: show_upload_data = .false. + logical :: is_dry_run = .false. + character(len=:), allocatable :: token +end type + +character(len=:),allocatable :: name +character(len=:),allocatable :: os_type +character(len=ibug),allocatable :: names(:) +character(len=:),allocatable :: tnames(:) + +character(len=:), allocatable :: version_text(:) +character(len=:), allocatable :: help_new(:), help_fpm(:), help_run(:), & + & help_test(:), help_build(:), help_usage(:), help_runner(:), & + & help_text(:), help_install(:), help_help(:), help_update(:), & + & help_list(:), help_list_dash(:), help_list_nodash(:), & + & help_clean(:), help_publish(:) +character(len=20),parameter :: manual(*)=[ character(len=20) ::& +& ' ', 'fpm', 'new', 'build', 'run', 'clean', & +& 'test', 'runner', 'install', 'update', 'list', 'help', 'version', 'publish' ] + +character(len=:), allocatable :: val_runner, val_compiler, val_flag, val_cflag, val_cxxflag, val_ldflag, & + val_profile, val_runner_args, val_dump + +! '12345678901234567890123456789012345678901234567890123456789012345678901234567890',& +character(len=80), parameter :: help_text_build_common(*) = [character(len=80) :: & + ' --profile PROF Selects the compilation profile for the build. ',& + ' Currently available profiles are "release" for ',& + ' high optimization and "debug" for full debug options. ',& + ' If --flag is not specified the "debug" flags are the ',& + ' default. ',& + ' --no-prune Disable tree-shaking/pruning of unused module dependencies '& + ] +! '12345678901234567890123456789012345678901234567890123456789012345678901234567890',& +character(len=80), parameter :: help_text_compiler(*) = [character(len=80) :: & + ' --compiler NAME Specify a compiler name. The default is "gfortran" ',& + ' unless set by the environment variable FPM_FC. ',& + ' --c-compiler NAME Specify the C compiler name. Automatically determined by ',& + ' default unless set by the environment variable FPM_CC. ',& + ' --cxx-compiler NAME Specify the C++ compiler name. Automatically determined by',& + ' default unless set by the environment variable FPM_CXX. ',& + ' --archiver NAME Specify the archiver name. Automatically determined by ',& + ' default unless set by the environment variable FPM_AR. '& + ] + +! '12345678901234567890123456789012345678901234567890123456789012345678901234567890',& +character(len=80), parameter :: help_text_flag(*) = [character(len=80) :: & + ' --flag FFLAGS selects compile arguments for the build, the default value is',& + ' set by the FPM_FFLAGS environment variable. These are added ',& + ' to the profile options if --profile is specified, else these ',& + ' are added to the defaults. To override the defaults, use the ',& + ' keyword [fortran] in the manifest. Note object and .mod ',& + ' directory locations are always built in. ',& + ' --c-flag CFLAGS selects compile arguments specific for C source in the build.',& + ' The default value is set by the FPM_CFLAGS environment ',& + ' variable. ',& + ' --cxx-flag CFLAGS selects compile arguments specific for C++ source in the ',& + ' build. The default value is set by the FPM_CXXFLAGS ',& + ' environment variable. ',& + ' --link-flag LDFLAGS select arguments passed to the linker for the build. The ',& + ' default value is set by the FPM_LDFLAGS environment variable.'& + ] + +character(len=80), parameter :: help_text_environment(*) = [character(len=80) :: & + 'ENVIRONMENT VARIABLES',& + ' FPM_FC sets the path to the Fortran compiler used for the build,', & + ' will be overwritten by --compiler command line option', & + '', & + ' FPM_FFLAGS sets the arguments for the Fortran compiler', & + ' will be overwritten by --flag command line option', & + '', & + ' FPM_CC sets the path to the C compiler used for the build,', & + ' will be overwritten by --c-compiler command line option', & + '', & + ' FPM_CFLAGS sets the arguments for the C compiler', & + ' will be overwritten by --c-flag command line option', & + '', & + ' FPM_CXX sets the path to the C++ compiler used for the build,', & + ' will be overwritten by --cxx-compiler command line option', & + '', & + ' FPM_CXXFLAGS sets the arguments for the C++ compiler', & + ' will be overwritten by --cxx-flag command line option', & + '', & + ' FPM_AR sets the path to the archiver used for the build,', & + ' will be overwritten by --archiver command line option', & + '', & + ' FPM_LDFLAGS sets additional link arguments for creating executables', & + ' will be overwritten by --link-flag command line option' & + ] + +contains + subroutine get_command_line_settings(cmd_settings) + class(fpm_cmd_settings), allocatable, intent(out) :: cmd_settings + + integer, parameter :: widest = 256 + character(len=4096) :: cmdarg + integer :: i + integer :: os + type(fpm_install_settings), allocatable :: install_settings + type(fpm_publish_settings), allocatable :: publish_settings + type(fpm_export_settings) , allocatable :: export_settings + type(version_t) :: version + character(len=:), allocatable :: common_args, compiler_args, run_args, working_dir, & + & c_compiler, cxx_compiler, archiver, version_s, token_s + + character(len=*), parameter :: fc_env = "FC", cc_env = "CC", ar_env = "AR", & + & fflags_env = "FFLAGS", cflags_env = "CFLAGS", cxxflags_env = "CXXFLAGS", ldflags_env = "LDFLAGS", & + & fc_default = "gfortran", cc_default = " ", ar_default = " ", flags_default = " ", & + & cxx_env = "CXX", cxx_default = " " + type(error_t), allocatable :: error + + call set_help() + os = get_os_type() + ! text for --version switch, + select case (os) + case (OS_LINUX); os_type = "OS Type: Linux" + case (OS_MACOS); os_type = "OS Type: macOS" + case (OS_WINDOWS); os_type = "OS Type: Windows" + case (OS_CYGWIN); os_type = "OS Type: Cygwin" + case (OS_SOLARIS); os_type = "OS Type: Solaris" + case (OS_FREEBSD); os_type = "OS Type: FreeBSD" + case (OS_OPENBSD); os_type = "OS Type: OpenBSD" + case (OS_UNKNOWN); os_type = "OS Type: Unknown" + case default ; os_type = "OS Type: UNKNOWN" + end select + + ! Get current release version + version = fpm_version() + version_s = version%s() + + version_text = [character(len=80) :: & + & 'Version: '//trim(version_s)//', alpha', & + & 'Program: fpm(1)', & + & 'Description: A Fortran package manager and build system', & + & 'Home Page: https://github.com/fortran-lang/fpm', & + & 'License: MIT', & + & os_type] + ! find the subcommand name by looking for first word on command + ! not starting with dash + CLI_RESPONSE_FILE=.true. + cmdarg = get_subcommand() + + common_args = & + ' --directory:C " "' // & + ' --verbose F' + + run_args = & + ' --target " "' // & + ' --list F' // & + ' --runner " "' // & + ' --runner-args " "' + + compiler_args = & + ' --profile " "' // & + ' --no-prune F' // & + ' --compiler "'//get_fpm_env(fc_env, fc_default)//'"' // & + ' --c-compiler "'//get_fpm_env(cc_env, cc_default)//'"' // & + ' --cxx-compiler "'//get_fpm_env(cxx_env, cxx_default)//'"' // & + ' --archiver "'//get_fpm_env(ar_env, ar_default)//'"' // & + ' --flag:: "'//get_fpm_env(fflags_env, flags_default)//'"' // & + ' --c-flag:: "'//get_fpm_env(cflags_env, flags_default)//'"' // & + ' --cxx-flag:: "'//get_fpm_env(cxxflags_env, flags_default)//'"' // & + ' --link-flag:: "'//get_fpm_env(ldflags_env, flags_default)//'"' + + ! now set subcommand-specific help text and process commandline + ! arguments. Then call subcommand routine + select case(trim(cmdarg)) + + case('run') + call set_args(common_args // compiler_args // run_args //'& + & --all F & + & --example F& + & --',help_run,version_text) + + call check_build_vals() + + if( size(unnamed) > 1 )then + names=unnamed(2:) + else + names=[character(len=len(names)) :: ] + endif + + if(specified('target') )then + call split(sget('target'),tnames,delimiters=' ,:') + names=[character(len=max(len(names),len(tnames))) :: names,tnames] + endif + + ! convert --all to '*' + if(lget('all'))then + names=[character(len=max(len(names),1)) :: names,'*' ] + endif + + ! convert special string '..' to equivalent (shorter) '*' + ! to allow for a string that does not require shift-key and quoting + do i=1,size(names) + if(names(i)=='..')names(i)='*' + enddo + + ! If there are additional command-line arguments, remove the additional + ! double quotes which have been added by M_CLI2 + val_runner_args=sget('runner-args') + call remove_characters_in_set(val_runner_args,set='"') + + c_compiler = sget('c-compiler') + cxx_compiler = sget('cxx-compiler') + archiver = sget('archiver') + allocate(fpm_run_settings :: cmd_settings) + val_runner=sget('runner') + if(specified('runner') .and. val_runner=='')val_runner='echo' + + cmd_settings=fpm_run_settings(& + & args=remaining,& + & profile=val_profile,& + & prune=.not.lget('no-prune'), & + & compiler=val_compiler, & + & c_compiler=c_compiler, & + & cxx_compiler=cxx_compiler, & + & archiver=archiver, & + & flag=val_flag, & + & cflag=val_cflag, & + & cxxflag=val_cxxflag, & + & ldflag=val_ldflag, & + & example=lget('example'), & + & list=lget('list'),& + & build_tests=.false.,& + & name=names,& + & runner=val_runner,& + & runner_args=val_runner_args, & + & verbose=lget('verbose') ) + + case('build') + call set_args(common_args // compiler_args //'& + & --list F & + & --show-model F & + & --dump " " & + & --tests F & + & --',help_build,version_text) + + call check_build_vals() + + c_compiler = sget('c-compiler') + cxx_compiler = sget('cxx-compiler') + archiver = sget('archiver') + + val_dump = sget('dump') + if (specified('dump') .and. val_dump=='')val_dump='fpm_model.toml' + + allocate( fpm_build_settings :: cmd_settings ) + cmd_settings=fpm_build_settings( & + & profile=val_profile,& + & dump=val_dump,& + & prune=.not.lget('no-prune'), & + & compiler=val_compiler, & + & c_compiler=c_compiler, & + & cxx_compiler=cxx_compiler, & + & archiver=archiver, & + & flag=val_flag, & + & cflag=val_cflag, & + & cxxflag=val_cxxflag, & + & ldflag=val_ldflag, & + & list=lget('list'),& + & show_model=lget('show-model'),& + & build_tests=lget('tests'),& + & verbose=lget('verbose') ) + + case('new') + call set_args(common_args // '& + & --src F & + & --lib F & + & --app F & + & --test F & + & --example F & + & --backfill F & + & --full F & + & --bare F', & + & help_new, version_text) + select case(size(unnamed)) + case(1) + if(lget('backfill'))then + name='.' + else + write(stderr,'(*(7x,g0,/))') & + & ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]|[--full|--bare] [--backfill]' + call fpm_stop(1,'directory name required') + endif + case(2) + name=trim(unnamed(2)) + case default + write(stderr,'(7x,g0)') & + & ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]| [--full|--bare] [--backfill]' + call fpm_stop(2,'only one directory name allowed') + end select + !*! canon_path is not converting ".", etc. + if(name=='.')then + call get_current_directory(name, error) + if (allocated(error)) then + write(stderr, '("[Error]", 1x, a)') error%message + stop 1 + endif + endif + name=canon_path(name) + if( .not.is_fortran_name(to_fortran_name(basename(name))) )then + write(stderr,'(g0)') [ character(len=72) :: & + & ' the fpm project name must be made of up to 63 ASCII letters,', & + & ' numbers, underscores, or hyphens, and start with a letter.'] + call fpm_stop(4,' ') + endif + + allocate(fpm_new_settings :: cmd_settings) + if (any( specified([character(len=10) :: 'src','lib','app','test','example','bare'])) & + & .and.lget('full') )then + write(stderr,'(*(a))')& + &' --full and any of [--src|--lib,--app,--test,--example,--bare]', & + &' are mutually exclusive.' + call fpm_stop(5,' ') + elseif (any( specified([character(len=10) :: 'src','lib','app','test','example','full'])) & + & .and.lget('bare') )then + write(stderr,'(*(a))')& + &' --bare and any of [--src|--lib,--app,--test,--example,--full]', & + &' are mutually exclusive.' + call fpm_stop(3,' ') + elseif (any( specified([character(len=10) :: 'src','lib','app','test','example']) ) )then + cmd_settings=fpm_new_settings(& + & backfill=lget('backfill'), & + & name=name, & + & with_executable=lget('app'), & + & with_lib=any([lget('lib'),lget('src')]), & + & with_test=lget('test'), & + & with_example=lget('example'), & + & verbose=lget('verbose') ) + else ! default if no specific directories are requested + cmd_settings=fpm_new_settings(& + & backfill=lget('backfill') , & + & name=name, & + & with_executable=.true., & + & with_lib=.true., & + & with_test=.true., & + & with_example=lget('full'), & + & with_full=lget('full'), & + & with_bare=lget('bare'), & + & verbose=lget('verbose') ) + endif + + case('help','manual') + call set_args(common_args, help_help,version_text) + if(size(unnamed)<2)then + if(unnamed(1)=='help')then + unnamed=[' ', 'fpm'] + else + unnamed=manual + endif + elseif(unnamed(2)=='manual')then + unnamed=manual + endif + allocate(character(len=widest) :: help_text(0)) + do i=2,size(unnamed) + select case(unnamed(i)) + case(' ' ) + case('fpm ' ) + help_text=[character(len=widest) :: help_text, help_fpm] + case('new ' ) + help_text=[character(len=widest) :: help_text, help_new] + case('build ' ) + help_text=[character(len=widest) :: help_text, help_build] + case('install' ) + help_text=[character(len=widest) :: help_text, help_install] + case('run ' ) + help_text=[character(len=widest) :: help_text, help_run] + case('test ' ) + help_text=[character(len=widest) :: help_text, help_test] + case('runner' ) + help_text=[character(len=widest) :: help_text, help_runner] + case('list ' ) + help_text=[character(len=widest) :: help_text, help_list] + case('update ' ) + help_text=[character(len=widest) :: help_text, help_update] + case('help ' ) + help_text=[character(len=widest) :: help_text, help_help] + case('version' ) + help_text=[character(len=widest) :: help_text, version_text] + case('clean' ) + help_text=[character(len=widest) :: help_text, help_clean] + case('publish') + help_text=[character(len=widest) :: help_text, help_publish] + case default + help_text=[character(len=widest) :: help_text, & + & ' unknown help topic "'//trim(unnamed(i))//'"'] + !!& ' unknown help topic "'//trim(unnamed(i)).'not found in:',manual] + end select + enddo + call printhelp(help_text) + + case('install') + call set_args(common_args // compiler_args // '& + & --no-rebuild F --prefix " " & + & --list F --test F & + & --libdir "lib" --bindir "bin" --testdir "test" --includedir "include"', & + help_install, version_text) + + call check_build_vals() + + c_compiler = sget('c-compiler') + cxx_compiler = sget('cxx-compiler') + archiver = sget('archiver') + allocate(install_settings, source=fpm_install_settings(& + list=lget('list'), & + build_tests=lget('test'), & + profile=val_profile,& + prune=.not.lget('no-prune'), & + compiler=val_compiler, & + c_compiler=c_compiler, & + cxx_compiler=cxx_compiler, & + archiver=archiver, & + flag=val_flag, & + cflag=val_cflag, & + cxxflag=val_cxxflag, & + ldflag=val_ldflag, & + no_rebuild=lget('no-rebuild'), & + verbose=lget('verbose'))) + call get_char_arg(install_settings%prefix, 'prefix') + call get_char_arg(install_settings%libdir, 'libdir') + call get_char_arg(install_settings%testdir, 'testdir') + call get_char_arg(install_settings%bindir, 'bindir') + call get_char_arg(install_settings%includedir, 'includedir') + call move_alloc(install_settings, cmd_settings) + + case('list') + call set_args(common_args // '& + & --list F& + &', help_list, version_text) + if(lget('list'))then + help_text = [character(widest) :: help_list_nodash, help_list_dash] + else + help_text = help_list_nodash + endif + call printhelp(help_text) + + case('test') + call set_args(common_args // compiler_args // run_args // ' --', & + help_test,version_text) + + call check_build_vals() + + if( size(unnamed) > 1 )then + names=unnamed(2:) + else + names=[character(len=len(names)) :: ] + endif + + if(specified('target') )then + call split(sget('target'),tnames,delimiters=' ,:') + names=[character(len=max(len(names),len(tnames))) :: names,tnames] + endif + + ! convert special string '..' to equivalent (shorter) '*' + ! to allow for a string that does not require shift-key and quoting + do i=1,size(names) + if(names(i)=='..')names(i)='*' + enddo + + ! If there are additional command-line arguments, remove the additional + ! double quotes which have been added by M_CLI2 + val_runner_args=sget('runner-args') + call remove_characters_in_set(val_runner_args,set='"') + + c_compiler = sget('c-compiler') + cxx_compiler = sget('cxx-compiler') + archiver = sget('archiver') + allocate(fpm_test_settings :: cmd_settings) + val_runner=sget('runner') + if(specified('runner') .and. val_runner=='')val_runner='echo' + + cmd_settings=fpm_test_settings(& + & args=remaining, & + & profile=val_profile, & + & prune=.not.lget('no-prune'), & + & compiler=val_compiler, & + & c_compiler=c_compiler, & + & cxx_compiler=cxx_compiler, & + & archiver=archiver, & + & flag=val_flag, & + & cflag=val_cflag, & + & cxxflag=val_cxxflag, & + & ldflag=val_ldflag, & + & example=.false., & + & list=lget('list'), & + & build_tests=.true., & + & name=names, & + & runner=val_runner, & + & runner_args=val_runner_args, & + & verbose=lget('verbose')) + + case('update') + call set_args(common_args // ' --fetch-only F --clean F --dump " " ', & + help_update, version_text) + + if( size(unnamed) > 1 )then + names=unnamed(2:) + else + names=[character(len=len(names)) :: ] + endif + + val_dump = sget('dump') + if (specified('dump') .and. val_dump=='')val_dump='fpm_dependencies.toml' + + allocate(fpm_update_settings :: cmd_settings) + cmd_settings=fpm_update_settings(name=names, dump=val_dump, & + fetch_only=lget('fetch-only'), verbose=lget('verbose'), & + clean=lget('clean')) + + case('export') + + call set_args(common_args // compiler_args // '& + & --manifest "filename" & + & --model "filename" & + & --dependencies "filename" ', & + help_build, version_text) + + call check_build_vals() + + c_compiler = sget('c-compiler') + cxx_compiler = sget('cxx-compiler') + archiver = sget('archiver') + allocate(export_settings, source=fpm_export_settings(& + profile=val_profile,& + prune=.not.lget('no-prune'), & + compiler=val_compiler, & + c_compiler=c_compiler, & + cxx_compiler=cxx_compiler, & + archiver=archiver, & + flag=val_flag, & + cflag=val_cflag, & + show_model=.true., & + cxxflag=val_cxxflag, & + ldflag=val_ldflag, & + verbose=lget('verbose'))) + call get_char_arg(export_settings%dump_model, 'model') + call get_char_arg(export_settings%dump_manifest, 'manifest') + call get_char_arg(export_settings%dump_dependencies, 'dependencies') + call move_alloc(export_settings, cmd_settings) + + case('clean') + call set_args(common_args // & + & ' --registry-cache' // & + & ' --skip' // & + & ' --all', & + help_clean, version_text) + + block + logical :: skip, clean_all + + skip = lget('skip') + clean_all = lget('all') + + if (all([skip, clean_all])) then + call fpm_stop(6, 'Do not specify both --skip and --all options on the clean subcommand.') + end if + + allocate(fpm_clean_settings :: cmd_settings) + cmd_settings = fpm_clean_settings( & + & registry_cache=lget('registry-cache'), & + & clean_skip=skip, & + & clean_all=clean_all) + end block + + case('publish') + call set_args(common_args // compiler_args //'& + & --show-package-version F & + & --show-upload-data F & + & --dry-run F & + & --token " " & + & --list F & + & --show-model F & + & --tests F & + & --', help_publish, version_text) + + call check_build_vals() + + c_compiler = sget('c-compiler') + cxx_compiler = sget('cxx-compiler') + archiver = sget('archiver') + token_s = sget('token') + + allocate(fpm_publish_settings :: cmd_settings) + cmd_settings = fpm_publish_settings( & + & show_package_version = lget('show-package-version'), & + & show_upload_data = lget('show-upload-data'), & + & is_dry_run = lget('dry-run'), & + & profile=val_profile,& + & prune=.not.lget('no-prune'), & + & compiler=val_compiler, & + & c_compiler=c_compiler, & + & cxx_compiler=cxx_compiler, & + & archiver=archiver, & + & flag=val_flag, & + & cflag=val_cflag, & + & cxxflag=val_cxxflag, & + & ldflag=val_ldflag, & + & list=lget('list'),& + & show_model=lget('show-model'),& + & build_tests=lget('tests'),& + & verbose=lget('verbose'),& + & token=token_s) + + case default + + if(cmdarg.ne.''.and.which('fpm-'//cmdarg).ne.'')then + call run('fpm-'//trim(cmdarg)//' '// get_command_arguments_quoted(),.false.) + stop + else + call set_args('& + & --list F& + &', help_fpm, version_text) + ! Note: will not get here if --version or --usage or --help + ! is present on commandline + if(lget('list'))then + help_text = help_list_dash + elseif(len_trim(cmdarg)==0)then + write(stdout,'(*(a))')'Fortran Package Manager:' + write(stdout,'(*(a))')' ' + help_text = [character(widest) :: help_list_nodash, help_usage] + else + write(stderr,'(*(a))')' unknown subcommand [', & + & trim(cmdarg), ']' + help_text = [character(widest) :: help_list_dash, help_usage] + endif + call printhelp(help_text) + endif + + end select + + if (allocated(cmd_settings)) then + working_dir = sget("directory") + call move_alloc(working_dir, cmd_settings%working_dir) + end if + + contains + + subroutine check_build_vals() + val_compiler=sget('compiler') + if(val_compiler=='') val_compiler='gfortran' + + val_flag = " " // sget('flag') + val_cflag = " " // sget('c-flag') + val_cxxflag = " "// sget('cxx-flag') + val_ldflag = " " // sget('link-flag') + val_profile = sget('profile') + + end subroutine check_build_vals + + !> Print help text and stop + subroutine printhelp(lines) + character(len=:),intent(in),allocatable :: lines(:) + integer :: iii,ii + if(allocated(lines))then + ii=size(lines) + if(ii > 0 .and. len(lines)> 0) then + write(stdout,'(g0)')(trim(lines(iii)), iii=1, ii) + else + write(stdout,'(a)')' *printhelp* output requested is empty' + endif + endif + stop + end subroutine printhelp + + end subroutine get_command_line_settings + + subroutine set_help() + help_list_nodash=[character(len=80) :: & + 'USAGE: fpm [ SUBCOMMAND [SUBCOMMAND_OPTIONS] ]|[--list|--help|--version]', & + ' where SUBCOMMAND is commonly new|build|run|test ', & + ' ', & + ' subcommand may be one of ', & + ' ', & + ' build Compile the package placing results in the "build" directory', & + ' help Display help ', & + ' list Display this list of subcommand descriptions ', & + ' new Create a new Fortran package directory with sample files ', & + ' run Run the local package application programs ', & + ' test Run the test programs ', & + ' update Update and manage project dependencies ', & + ' install Install project ', & + ' clean Delete the build ', & + ' publish Publish package to the registry ', & + ' ', & + ' Enter "fpm --list" for a brief list of subcommand options. Enter ', & + ' "fpm --help" or "fpm SUBCOMMAND --help" for detailed descriptions. ', & + ' '] + help_list_dash = [character(len=80) :: & + ' ', & + ' build [--compiler COMPILER_NAME] [--profile PROF] [--flag FFLAGS] [--list] ', & + ' [--tests] [--no-prune] [--dump [FILENAME]] ', & + ' help [NAME(s)] ', & + ' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & + ' [--full|--bare][--backfill] ', & + ' update [NAME(s)] [--fetch-only] [--clean] [--verbose] [--dump [FILENAME]] ', & + ' list [--list] ', & + ' run [[--target] NAME(s) [--example] [--profile PROF] [--flag FFLAGS] [--all] ', & + ' [--runner "CMD"] [--compiler COMPILER_NAME] [--list] [-- ARGS] ', & + ' test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--runner "CMD"] ', & + ' [--list] [--compiler COMPILER_NAME] [-- ARGS] ', & + ' install [--profile PROF] [--flag FFLAGS] [--no-rebuild] [--prefix PATH] ', & + ' [options] ', & + ' clean [--skip] [--all] [--registry-cache] ', & + ' publish [--token TOKEN] [--show-package-version] [--show-upload-data] ', & + ' [--dry-run] [--verbose] ', & + ' '] + help_usage=[character(len=80) :: & + '' ] + help_runner=[character(len=80) :: & + 'NAME ', & + ' --runner(1) - a shared option for specifying an application to launch ', & + ' executables. ', & + ' ', & + 'SYNOPSIS ', & + ' fpm run|test --runner CMD ... --runner-args ARGS -- SUFFIX_OPTIONS ', & + ' ', & + 'DESCRIPTION ', & + ' The --runner option allows specifying a program to launch ', & + ' executables selected via the fpm(1) subcommands "run" and "test". This ', & + ' gives easy recourse to utilities such as debuggers and other tools ', & + ' that wrap other executables. ', & + ' ', & + ' These external commands are not part of fpm(1) itself as they vary ', & + ' from platform to platform or require independent installation. ', & + ' ', & + 'OPTION ', & + ' --runner ''CMD'' quoted command used to launch the fpm(1) executables. ', & + ' Available for both the "run" and "test" subcommands. ', & + ' If the keyword is specified without a value the default command ', & + ' is "echo". ', & + ' --runner-args "args" an additional option to pass command-line arguments ', & + ' to the runner command, instead of to the fpm app. ', & + ' -- SUFFIX_OPTIONS additional options to suffix the command CMD and executable ', & + ' file names with. These options are passed as command-line ', & + ' arguments to the app. ', & + 'EXAMPLES ', & + ' Use cases for ''fpm run|test --runner "CMD"'' include employing ', & + ' the following common GNU/Linux and Unix commands: ', & + ' ', & + ' INTERROGATE ', & + ' + nm - list symbols from object files ', & + ' + size - list section sizes and total size. ', & + ' + ldd - print shared object dependencies ', & + ' + ls - list directory contents ', & + ' + stat - display file or file system status ', & + ' + file - determine file type ', & + ' PERFORMANCE AND DEBUGGING ', & + ' + gdb - The GNU Debugger ', & + ' + valgrind - a suite of tools for debugging and profiling ', & + ' + time - time a simple command or give resource usage ', & + ' + timeout - run a command with a time limit ', & + ' COPY ', & + ' + install - copy files and set attributes ', & + ' + tar - an archiving utility ', & + ' ALTER ', & + ' + rm - remove files or directories ', & + ' + chmod - change permissions of a file ', & + ' + strip - remove unnecessary information from strippable files ', & + ' ', & + ' For example ', & + ' ', & + ' fpm test --runner gdb ', & + ' fpm run --runner "tar cvfz $HOME/bundle.tgz" ', & + ' fpm run --runner "mpiexec" --runner-args "-np 12" ', & + ' fpm run --runner ldd ', & + ' fpm run --runner strip ', & + ' fpm run --runner ''cp -t /usr/local/bin'' ', & + ' ', & + ' # options after executable name can be specified after the -- option ', & + ' fpm --runner cp run -- /usr/local/bin/ ', & + ' # generates commands of the form "cp $FILENAME /usr/local/bin/" ', & + ' ', & + ' # bash(1) alias example: ', & + ' alias fpm-install=\ ', & + ' "fpm run --profile release --runner ''install -vbp -m 0711 -t ~/.local/bin''" ', & + ' fpm-install ', & + '' ] + help_fpm=[character(len=80) :: & + 'NAME ', & + ' fpm(1) - A Fortran package manager and build system ', & + ' ', & + 'SYNOPSIS ', & + ' fpm SUBCOMMAND [SUBCOMMAND_OPTIONS] ', & + ' ', & + ' fpm --help|--version|--list ', & + ' ', & + 'DESCRIPTION ', & + ' fpm(1) is a package manager that helps you create Fortran projects ', & + ' from source -- it automatically determines dependencies! ', & + ' ', & + ' Most significantly fpm(1) lets you draw upon other fpm(1) packages ', & + ' in distributed git(1) repositories as if the packages were a basic ', & + ' part of your default programming environment, as well as letting ', & + ' you share your projects with others in a similar manner. ', & + ' ', & + ' All output goes into the directory "build/" which can generally be ', & + ' removed and rebuilt if required. Note that if external packages are ', & + ' being used you need network connectivity to rebuild from scratch. ', & + ' ', & + 'SUBCOMMANDS ', & + ' Valid fpm(1) subcommands are: ', & + ' ', & + ' + build Compile the packages into the "build/" directory. ', & + ' + new Create a new Fortran package directory with sample files. ', & + ' + update Update the project dependencies. ', & + ' + run Run the local package binaries. Defaults to all binaries ', & + ' for that release. ', & + ' + test Run the tests. ', & + ' + help Alternate to the --help switch for displaying help text. ', & + ' + list Display brief descriptions of all subcommands. ', & + ' + install Install project. ', & + ' + clean Delete directories in the "build/" directory, except ', & + ' dependencies. Prompts for confirmation to delete. ', & + ' + publish Publish package to the registry. ', & + ' ', & + ' Their syntax is ', & + ' ', & + ' build [--profile PROF] [--flag FFLAGS] [--list] [--compiler COMPILER_NAME] ', & + ' [--tests] [--no-prune] [--dump [FILENAME]] ', & + ' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & + ' [--full|--bare][--backfill] ', & + ' update [NAME(s)] [--fetch-only] [--clean] [--dump [FILENAME]] ', & + ' run [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--list] [--all] ', & + ' [--example] [--runner "CMD"] [--compiler COMPILER_NAME] ', & + ' [--no-prune] [-- ARGS] ', & + ' test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--list] ', & + ' [--runner "CMD"] [--compiler COMPILER_NAME] [--no-prune] [-- ARGS] ', & + ' help [NAME(s)] ', & + ' list [--list] ', & + ' install [--profile PROF] [--flag FFLAGS] [--no-rebuild] [--prefix PATH] ', & + ' [options] ', & + ' clean [--skip] [--all] [--registry-cache] ', & + ' publish [--token TOKEN] [--show-package-version] [--show-upload-data] ', & + ' [--dry-run] [--verbose] ', & + ' ', & + 'SUBCOMMAND OPTIONS ', & + ' -C, --directory PATH', & + ' Change working directory to PATH before running any command', & + help_text_build_common, & + help_text_compiler, & + help_text_flag, & + ' --list List candidates instead of building or running them. On ', & + ' the fpm(1) command this shows a brief list of subcommands.', & + ' --runner CMD Provides a command to prefix program execution paths. ', & + ' -- ARGS Arguments to pass to executables. ', & + ' --skip Delete directories in the build/ directory without ', & + ' prompting, but skip dependencies. Cannot be used together ', & + ' with --all. ', & + ' --all Delete directories in the build/ directory without ', & + ' prompting, including dependencies. Cannot be used together', & + ' with --skip. ', & + ' --registry-cache Delete registry cache. ', & + ' ', & + 'VALID FOR ALL SUBCOMMANDS ', & + ' --help Show help text and exit ', & + ' --verbose Display additional information when available ', & + ' --version Show version information and exit. ', & + ' ', & + '@file ', & + ' You may replace the default options for the fpm(1) command from a ', & + ' file if your first options begin with @file. Initial options will ', & + ' then be read from the "response file" "file.rsp" in the current ', & + ' directory. ', & + ' ', & + ' If "file" does not exist or cannot be read, then an error occurs and', & + ' the program stops. Each line of the file is prefixed with "options" ', & + ' and interpreted as a separate argument. The file itself may not ', & + ' contain @file arguments. That is, it is not processed recursively. ', & + ' ', & + ' For more information on response files see ', & + ' ', & + ' https://urbanjost.github.io/M_CLI2/set_args.3m_cli2.html ', & + ' ', & + ' The basic functionality described here will remain the same, but ', & + ' other features described at the above reference may change. ', & + ' ', & + ' An example file: ', & + ' ', & + ' # my build options ', & + ' options build ', & + ' options --compiler gfortran ', & + ' options --flag "-pg -static -pthread -Wunreachable-code -Wunused ', & + ' -Wuninitialized -g -O -fbacktrace -fdump-core -fno-underscoring ', & + ' -frecord-marker=4 -L/usr/X11R6/lib -L/usr/X11R6/lib64 -lX11" ', & + ' ', & + ' Note --flag would have to be on one line as response files do not ', & + ' (currently) allow for continued lines or multiple specifications of ', & + ' the same option. ', & + ' ', & + help_text_environment, & + ' ', & + 'EXAMPLES ', & + ' sample commands: ', & + ' ', & + ' fpm new mypackage --app --test ', & + ' fpm build ', & + ' fpm test ', & + ' fpm run ', & + ' fpm run --example ', & + ' fpm new --help ', & + ' fpm run myprogram --profile release -- -x 10 -y 20 --title "my title" ', & + ' fpm install --prefix ~/.local ', & + ' fpm clean --all ', & + ' ', & + 'SEE ALSO ', & + ' ', & + ' + The fpm(1) home page is at https://github.com/fortran-lang/fpm ', & + ' + Registered fpm(1) packages are at https://fortran-lang.org/packages ', & + ' + The fpm(1) TOML file format is described at ', & + ' https://fpm.fortran-lang.org/spec/manifest.html ', & + ''] + help_list=[character(len=80) :: & + 'NAME ', & + ' list(1) - list summary of fpm(1) subcommands ', & + ' ', & + 'SYNOPSIS ', & + ' fpm list ', & + ' ', & + ' fpm list --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' Display a short description for each fpm(1) subcommand. ', & + ' ', & + 'OPTIONS ', & + ' --list display a list of command options as well. This is the ', & + ' same output as generated by "fpm --list". ', & + ' ', & + 'EXAMPLES ', & + ' display a short list of fpm(1) subcommands ', & + ' ', & + ' fpm list ', & + ' fpm --list ', & + '' ] + help_run=[character(len=80) :: & + 'NAME ', & + ' run(1) - the fpm(1) subcommand to run project applications ', & + ' ', & + 'SYNOPSIS ', & + ' fpm run [[--target] NAME(s) [--profile PROF] [--flag FFLAGS]', & + ' [--compiler COMPILER_NAME] [--runner "CMD"] [--example]', & + ' [--list] [--all] [-- ARGS]', & + ' ', & + ' fpm run --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' Run the applications in your fpm(1) package. By default applications ', & + ' in /app or specified as "executable" in your "fpm.toml" manifest are ', & + ' used. Alternatively demonstration programs in example/ or specified in', & + ' the "example" section in "fpm.toml" can be executed. The applications ', & + ' are automatically rebuilt before being run if they are out of date. ', & + ' ', & + 'OPTIONS ', & + ' --target NAME(s) list of application names to execute. No name is ', & + ' required if only one target exists. If no name is ', & + ' supplied and more than one candidate exists or a ', & + ' name has no match a list is produced and fpm(1) ', & + ' exits. ', & + ' ', & + ' Basic "globbing" is supported where "?" represents ', & + ' any single character and "*" represents any string. ', & + ' Note The glob string normally needs quoted to ', & + ' the special characters from shell expansion. ', & + ' --all Run all examples or applications. An alias for --target ''*''. ', & + ' --example Run example programs instead of applications. ', & + help_text_build_common, & + help_text_compiler, & + help_text_flag, & + ' --runner CMD A command to prefix the program execution paths with. ', & + ' see "fpm help runner" for further details. ', & + ' --list list basenames of candidates instead of running them. Note ', & + ' out-of-date candidates will still be rebuilt before being ', & + ' listed. ', & + ' -- ARGS optional arguments to pass to the program(s). The same ', & + ' arguments are passed to all program names specified. ', & + ' ', & + help_text_environment, & + ' ', & + 'EXAMPLES ', & + ' fpm(1) - run or display project applications: ', & + ' ', & + ' fpm run # run a target when only one exists or list targets ', & + ' fpm run --list # list basename of all targets, running nothing. ', & + ' fpm run "demo*" --list # list target basenames starting with "demo*".', & + ' fpm run "psi*" --runner # list target pathnames starting with "psi*".', & + ' fpm run --all # run all targets, no matter how many there are. ', & + ' ', & + ' # run default program built or to be built with the compiler command ', & + ' # "f90". If more than one app exists a list displays and target names', & + ' # are required. ', & + ' fpm run --compiler f90 ', & + ' ', & + ' # run example programs instead of the application programs. ', & + ' fpm run --example "*" ', & + ' ', & + ' # run a specific program and pass arguments to the command ', & + ' fpm run myprog -- -x 10 -y 20 --title "my title line" ', & + ' ', & + ' # run production version of two applications ', & + ' fpm run --target prg1,prg2 --profile release ', & + ' ', & + ' # install executables in directory (assuming install(1) exists) ', & + ' fpm run --runner ''install -b -m 0711 -p -t /usr/local/bin'' ', & + '' ] + help_build=[character(len=80) :: & + 'NAME ', & + ' build(1) - the fpm(1) subcommand to build a project ', & + ' ', & + 'SYNOPSIS ', & + ' fpm build [--profile PROF] [--flag FFLAGS] [--compiler COMPILER_NAME] ', & + ' [--list] [--tests] [--dump [FILENAME]] ', & + ' ', & + ' fpm build --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' The "fpm build" command ', & + ' o Fetches any dependencies ', & + ' o Scans your sources ', & + ' o Builds them in the proper order ', & + ' ', & + ' The Fortran source files are assumed by default to be in ', & + ' o src/ for modules and procedure source ', & + ' o app/ main program(s) for applications ', & + ' o test/ main program(s) and support files for project tests ', & + ' o example/ main program(s) for example programs ', & + ' Changed or new files found are rebuilt. The results are placed in ', & + ' the build/ directory. ', & + ' ', & + ' Non-default pathnames and remote dependencies are used if ', & + ' specified in the "fpm.toml" file. ', & + ' ', & + 'OPTIONS ', & + help_text_build_common,& + help_text_compiler, & + help_text_flag, & + ' --list list candidates instead of building or running them ', & + ' --tests build all tests (otherwise only if needed) ', & + ' --show-model show the model and exit (do not build) ', & + ' --dump [FILENAME] save model representation to file. use JSON format ', & + ' if file name is *.json; use TOML format otherwise ', & + ' (default file name: model.toml) ', & + ' --help print this help and exit ', & + ' --version print program version information and exit ', & + ' ', & + help_text_environment, & + ' ', & + 'EXAMPLES ', & + ' Sample commands: ', & + ' ', & + ' fpm build # build with debug options ', & + ' fpm build --profile release # build with high optimization ', & + '' ] + + help_help=[character(len=80) :: & + 'NAME ', & + ' help(1) - the fpm(1) subcommand to display help ', & + ' ', & + 'SYNOPSIS ', & + ' fpm help [fpm] [new] [build] [run] [test] [help] [version] [manual] ', & + ' [runner] ', & + ' ', & + 'DESCRIPTION ', & + ' The "fpm help" command is an alternative to the --help parameter ', & + ' on the fpm(1) command and its subcommands. ', & + ' ', & + 'OPTIONS ', & + ' NAME(s) A list of topic names to display. All the subcommands ', & + ' have their own page (new, build, run, test, ...). ', & + ' ', & + ' The special name "manual" displays all the fpm(1) ', & + ' built-in documentation. ', & + ' ', & + ' The default is to display help for the fpm(1) command ', & + ' itself. ', & + ' ', & + 'EXAMPLES ', & + ' Sample usage: ', & + ' ', & + ' fpm help # general fpm(1) command help ', & + ' fpm help version # show program version ', & + ' fpm help new # display help for "new" subcommand ', & + ' fpm help manual # All fpm(1) built-in documentation ', & + ' ', & + '' ] + help_new=[character(len=80) :: & + 'NAME ', & + ' new(1) - the fpm(1) subcommand to initialize a new project ', & + ' ', & + 'SYNOPSIS ', & + ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & + ' [--full|--bare][--backfill] ', & + ' fpm new --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' "fpm new" creates and populates a new programming project directory. ', & + ' ', & + ' It ', & + ' o creates a directory with the specified name ', & + ' o runs the command "git init" in that directory ', & + ' o populates the directory with the default project directories ', & + ' o adds sample Fortran source files ', & + ' ', & + ' The default file structure (that will be automatically scanned) is ', & + ' ', & + ' NAME/ ', & + ' fpm.toml ', & + ' src/ ', & + ' NAME.f90 ', & + ' app/ ', & + ' main.f90 ', & + ' test/ ', & + ' check.f90 ', & + ' example/ ', & + ' demo.f90 ', & + ' ', & + ' Using this file structure is highly encouraged, particularly for ', & + ' small packages primarily intended to be used as dependencies. ', & + ' ', & + ' If you find this restrictive and need to customize the package ', & + ' structure you will find using the --full switch creates a ', & + ' heavily annotated manifest file with references to documentation ', & + ' to aid in constructing complex package structures. ', & + ' ', & + ' Remember to update the information in the sample "fpm.toml" ', & + ' file with your name and e-mail address. ', & + ' ', & + 'OPTIONS ', & + ' NAME the name of the project directory to create. The name ', & + ' must be made of up to 63 ASCII letters, digits, underscores, ', & + ' or hyphens, and start with a letter. ', & + ' ', & + ' The default is to create the src/, app/, and test/ directories. ', & + ' If any of the following options are specified then only the ', & + ' selected subdirectories are generated: ', & + ' ', & + ' --lib,--src create directory src/ and a placeholder module ', & + ' named "NAME.f90" for use with subcommand "build". ', & + ' --app create directory app/ and a placeholder main ', & + ' program for use with subcommand "run". ', & + ' --test create directory test/ and a placeholder program ', & + ' for use with the subcommand "test". Note that sans ', & + ' "--lib" it really does not have anything to test. ', & + ' --example create directory example/ and a placeholder program ', & + ' for use with the subcommand "run --example". ', & + ' It is only created by default if "--full is" specified. ', & + ' ', & + ' So the default is equivalent to ',& + ' ', & + ' fpm NAME --lib --app --test ', & + ' ', & + ' --backfill By default the directory must not exist. If this ', & + ' option is present the directory may pre-exist and ', & + ' only subdirectories and files that do not ', & + ' already exist will be created. For example, if you ', & + ' previously entered "fpm new myname --lib" entering ', & + ' "fpm new myname -full --backfill" will create any missing', & + ' app/, example/, and test/ directories and programs. ', & + ' ', & + ' --full By default a minimal manifest file ("fpm.toml") is ', & + ' created that depends on auto-discovery. With this ', & + ' option a much more extensive manifest sample is written ', & + ' and the example/ directory is created and populated. ', & + ' It is designed to facilitate creating projects that ', & + ' depend extensively on non-default build options. ', & + ' ', & + ' --bare A minimal manifest file ("fpm.toml") is created and ', & + ' "README.md" file is created but no directories or ', & + ' sample Fortran are generated. ', & + ' ', & + ' --help print this help and exit ', & + ' --version print program version information and exit ', & + ' ', & + 'EXAMPLES ', & + ' Sample use ', & + ' ', & + ' fpm new myproject # create new project directory and seed it ', & + ' cd myproject # Enter the new directory ', & + ' # and run commands such as ', & + ' fpm build ', & + ' fpm run # run lone example application program ', & + ' fpm test # run example test program(s) ', & + ' fpm run --example # run lone example program ', & + ' ', & + ' fpm new A --full # create example/ and an annotated fpm.toml as well', & + ' fpm new A --bare # create no directories ', & + ' create any missing files in current directory ', & + ' fpm new --full --backfill ', & + '' ] + help_test=[character(len=80) :: & + 'NAME ', & + ' test(1) - the fpm(1) subcommand to run project tests ', & + ' ', & + 'SYNOPSIS ', & + ' fpm test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS]', & + ' [--compiler COMPILER_NAME ] [--runner "CMD"] [--list][-- ARGS]', & + ' ', & + ' fpm test --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' Run applications you have built to test your project. ', & + ' ', & + 'OPTIONS ', & + ' --target NAME(s) optional list of specific test names to execute. ', & + ' The default is to run all the tests in test/ ', & + ' or the tests listed in the "fpm.toml" file. ', & + ' ', & + ' Basic "globbing" is supported where "?" represents ', & + ' any single character and "*" represents any string. ', & + ' Note The glob string normally needs quoted to ', & + ' protect the special characters from shell expansion.', & + help_text_build_common,& + help_text_compiler, & + help_text_flag, & + ' --runner CMD A command to prefix the program execution paths with. ', & + ' see "fpm help runner" for further details. ', & + ' --list list candidate basenames instead of running them. Note they', & + ' --list will still be built if not currently up to date. ', & + ' -- ARGS optional arguments to pass to the test program(s). ', & + ' The same arguments are passed to all test names ', & + ' specified. ', & + ' ', & + help_text_environment, & + ' ', & + 'EXAMPLES ', & + 'run tests ', & + ' ', & + ' # run default tests in /test or as specified in "fpm.toml" ', & + ' fpm test ', & + ' ', & + ' # run using compiler command "f90" ', & + ' fpm test --compiler f90 ', & + ' ', & + ' # run a specific test and pass arguments to the command ', & + ' fpm test mytest -- -x 10 -y 20 --title "my title line" ', & + ' ', & + ' fpm test tst1 tst2 --profile PROF # run production version of two tests', & + '' ] + help_update=[character(len=80) :: & + 'NAME', & + ' update(1) - manage project dependencies', & + '', & + 'SYNOPSIS', & + ' fpm update [--fetch-only] [--clean] [--verbose] [--dump [FILENAME]] [NAME(s)]', & + '', & + 'DESCRIPTION', & + ' Manage and update project dependencies. If no dependency names are', & + ' provided all the dependencies are updated automatically.', & + '', & + 'OPTIONS', & + ' --fetch-only Only fetch dependencies, do not update existing projects', & + ' --clean Do not use previous dependency cache', & + ' --verbose Show additional printout', & + ' --dump [FILENAME] Dump updated dependency tree to file. use JSON format ', & + ' if file name is *.json; use TOML format otherwise ', & + ' (default file name: fpm_dependencies.toml) ', & + '', & + 'SEE ALSO', & + ' The fpm(1) home page at https://github.com/fortran-lang/fpm', & + '' ] + help_install=[character(len=80) :: & + 'NAME', & + ' install(1) - install fpm projects', & + '', & + 'SYNOPSIS', & + ' fpm install [--profile PROF] [--flag FFLAGS] [--list] [--no-rebuild]', & + ' [--prefix DIR] [--bindir DIR] [--libdir DIR] [--includedir DIR]', & + ' [--verbose]', & + '', & + 'DESCRIPTION', & + ' Subcommand to install fpm projects. Running install will export the', & + ' current project to the selected prefix, this will by default install all', & + ' executables (tests and examples are excluded) which are part of the projects.', & + ' Libraries and module files are only installed for projects requiring the', & + ' installation of those components in the package manifest.', & + '', & + 'OPTIONS', & + ' --list list all installable targets for this project,', & + ' but do not install any of them', & + help_text_build_common,& + help_text_flag, & + ' --no-rebuild do not rebuild project before installation', & + ' --test also install test programs', & + ' --prefix DIR path to installation directory (requires write access),', & + ' the default prefix on Unix systems is $HOME/.local', & + ' and %APPDATA%\local on Windows', & + ' --bindir DIR subdirectory to place executables in (default: bin)', & + ' --libdir DIR subdirectory to place libraries and archives in', & + ' (default: lib)', & + ' --includedir DIR subdirectory to place headers and module files in', & + ' (default: include)', & + ' --testdir DIR subdirectory to place test programs in (default: test)', & + ' --verbose print more information', & + '', & + help_text_environment, & + '', & + 'EXAMPLES', & + ' 1. Install release version of project:', & + '', & + ' fpm install --profile release', & + '', & + ' 2. Install the project without rebuilding the executables:', & + '', & + ' fpm install --no-rebuild', & + '', & + ' 3. Install executables to a custom prefix into the exe directory:', & + '', & + ' fpm install --prefix $PWD --bindir exe', & + ' 4. Install executables and test programs into the same "exe" directory:', & + '', & + ' fpm install --prefix $PWD --test --bindir exe --testdir exe', & + '' ] + help_clean=[character(len=80) :: & + 'NAME', & + ' clean(1) - delete the build', & + '', & + 'SYNOPSIS', & + ' fpm clean', & + '', & + 'DESCRIPTION', & + ' Prompts the user to confirm deletion of the build. If affirmative,', & + ' directories in the build/ directory are deleted, except dependencies.', & + ' Use the --registry-cache option to delete the registry cache.', & + '', & + 'OPTIONS', & + ' --skip Delete the build without prompting but skip dependencies.', & + ' --all Delete the build without prompting including dependencies.', & + ' --registry-cache Delete registry cache.', & + '' ] + help_publish=[character(len=80) :: & + 'NAME', & + ' publish(1) - publish package to the registry', & + '', & + 'SYNOPSIS', & + ' fpm publish [--token TOKEN] [--show-package-version] [--show-upload-data]', & + ' [--dry-run] [--verbose] ', & + '', & + ' fpm publish --help|--version', & + '', & + 'DESCRIPTION', & + ' Follow the steps to create a tarball and upload a package to the registry:', & + '', & + ' 1. Register on the website (https://registry-phi.vercel.app/).', & + ' 2. Create a namespace. Uploaded packages must be assigned to a unique', & + ' namespace to avoid conflicts among packages with similar names. A', & + ' namespace can accommodate multiple packages.', & + ' 3. Create a token for that namespace. A token is linked to your username', & + ' and is used to authenticate you during the upload process. Do not share', & + ' the token with others.', & + ' 4. Run fpm publish --token TOKEN to upload the package to the registry.', & + ' But be aware that the upload is permanent. An uploaded package cannot be', & + ' deleted.', & + '', & + ' See documentation for more information regarding package upload and usage:', & + '', & + ' Package upload:', & + ' https://fpm.fortran-lang.org/spec/publish.html', & + '', & + ' Package usage:', & + ' https://fpm.fortran-lang.org/spec/manifest.html#dependencies-from-a-registry', & + '', & + 'OPTIONS', & + ' --show-package-version show package version without publishing', & + ' --show-upload-data show upload data without publishing', & + ' --dry-run perform dry run without publishing', & + ' --help print this help and exit', & + ' --version print program version information and exit', & + ' --verbose print more information', & + '', & + 'EXAMPLES', & + '', & + ' fpm publish --show-package-version # show package version without publishing', & + ' fpm publish --show-upload-data # show upload data without publishing', & + ' fpm publish --token TOKEN --dry-run # perform dry run without publishing', & + ' fpm publish --token TOKEN # upload package to the registry', & + '' ] + end subroutine set_help + + subroutine get_char_arg(var, arg) + character(len=:), allocatable, intent(out) :: var + character(len=*), intent(in) :: arg + var = sget(arg) + if (len_trim(var) == 0) deallocate(var) + end subroutine get_char_arg + + !> Get an environment variable for fpm, this routine ensures that every variable + !> used by fpm is prefixed with FPM_. + function get_fpm_env(env, default) result(val) + character(len=*), intent(in) :: env + character(len=*), intent(in) :: default + character(len=:), allocatable :: val + + character(len=*), parameter :: fpm_prefix = "FPM_" + + val = get_env(fpm_prefix//env, default) + end function get_fpm_env + + !> Build a full runner command (executable + command-line arguments) + function runner_command(cmd) result(run_cmd) + class(fpm_run_settings), intent(in) :: cmd + character(len=:), allocatable :: run_cmd + !> Get executable + if (len_trim(cmd%runner)>0) then + run_cmd = trim(cmd%runner) + else + run_cmd = '' + end if + !> Append command-line arguments + if (len_trim(cmd%runner_args)>0) run_cmd = run_cmd//' '//trim(cmd%runner_args) + end function runner_command + + !> Check name in list ID. return 0 if not found + integer function name_ID(cmd,name) + class(fpm_run_settings), intent(in) :: cmd + character(*), intent(in) :: name + + integer :: j + + !> Default: not found + name_ID = 0 + if (.not.allocated(cmd%name)) return + + do j=1,size(cmd%name) + + if (glob(trim(name),trim(cmd%name(j)))) then + name_ID = j + return + end if + + end do + + end function name_ID + +end module fpm_command_line + +!>>>>> build/dependencies/toml-f/src/tomlf/de/context.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Provides a container to store tokens for later use +module tomlf_de_context + use tomlf_constants, only : tfc + use tomlf_de_token, only : toml_token, resize + use tomlf_diagnostic, only : toml_diagnostic, toml_label, render, toml_level + use tomlf_terminal, only : toml_terminal + implicit none + private + + public :: toml_context + + !> Container storing tokens + type :: toml_context + !> Filename of the input + character(:, tfc), allocatable :: filename + !> Actual source + character(:, tfc), allocatable :: source + !> Stack of stored tokens + type(toml_token), allocatable :: token(:) + !> Last stored token + integer :: top = 0 + contains + !> Push a new token to the stack + procedure :: push_back + !> Create a report + generic :: report => report1, report2 + !> Create a report with a single label + procedure :: report1 + !> Create a report with a two labels + procedure :: report2 + end type toml_context + +contains + +!> Push a new token to the stack +subroutine push_back(self, token) + !> Instance of the token storage + class(toml_context), intent(inout) :: self + !> New token to be added + type(toml_token), intent(in) :: token + + if (.not.allocated(self%token)) call resize(self%token) + if (self%top >= size(self%token)) call resize(self%token) + + self%top = self%top + 1 + self%token(self%top) = token +end subroutine push_back + +!> Create a report with a single label +pure function report1(self, message, origin, label, level, color) result(string) + !> Instance of the token storage + class(toml_context), intent(in) :: self + !> Message for the report + character(*, tfc), intent(in) :: message + !> Position to report at + integer, intent(in) :: origin + !> String for the label + character(*, tfc), intent(in), optional :: label + !> Highlight level + integer, intent(in), optional :: level + !> Color terminal + type(toml_terminal), intent(in), optional :: color + !> Final rendered report + character(:, tfc), allocatable :: string + + type(toml_diagnostic) :: diagnostic + type(toml_label), allocatable :: labels(:) + integer :: level_ + + level_ = toml_level%error + if (present(level)) level_ = level + + if (origin > 0 .and. origin <= self%top) then + allocate(labels(1)) + labels(1) = toml_label(level_, & + & self%token(origin)%first, self%token(origin)%last, label, .true.) + end if + + diagnostic = toml_diagnostic( & + & level_, & + & message, & + & self%filename, & + & labels) + + if (.not.present(color)) then + string = render(diagnostic, self%source, toml_terminal(.false.)) + else + string = render(diagnostic, self%source, color) + end if +end function report1 + +!> Create a report with two labels +pure function report2(self, message, origin1, origin2, label1, label2, level1, level2, color) & + & result(string) + !> Instance of the token storage + class(toml_context), intent(in) :: self + !> Message for the report + character(*, tfc), intent(in) :: message + !> Position to report at + integer, intent(in) :: origin1, origin2 + !> String for the label + character(*, tfc), intent(in), optional :: label1, label2 + !> Highlight level + integer, intent(in), optional :: level1, level2 + !> Color terminal + type(toml_terminal), intent(in), optional :: color + !> Final rendered report + character(:, tfc), allocatable :: string + + type(toml_diagnostic) :: diagnostic + type(toml_label), allocatable :: labels(:) + integer :: level1_, level2_ + + level1_ = toml_level%error + if (present(level1)) level1_ = level1 + level2_ = toml_level%info + if (present(level2)) level2_ = level2 + + if (origin1 > 0 .and. origin1 <= self%top & + & .and. origin2 > 0 .and. origin2 <= self%top) then + allocate(labels(2)) + labels(1) = toml_label(level1_, & + & self%token(origin1)%first, self%token(origin1)%last, label1, .true.) + labels(2) = toml_label(level2_, & + & self%token(origin2)%first, self%token(origin2)%last, label2, .false.) + end if + + diagnostic = toml_diagnostic( & + & level1_, & + & message, & + & self%filename, & + & labels) + + if (.not.present(color)) then + string = render(diagnostic, self%source, toml_terminal(.false.)) + else + string = render(diagnostic, self%source, color) + end if +end function report2 + +end module tomlf_de_context + +!>>>>> build/dependencies/toml-f/src/tomlf/structure/array_list.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a basic storage structure as pointer list of pointers. +!> +!> This implementation does purposely not use pointer attributes in the +!> datastructure to make it safer to work with. +module tomlf_structure_array_list + use tomlf_constants, only : tfc + use tomlf_structure_list, only : toml_list_structure + use tomlf_structure_node, only : toml_node, resize + use tomlf_type_value, only : toml_value, toml_key + implicit none + private + + public :: toml_array_list, new_array_list + + !> Stores TOML values in a list of pointers + type, extends(toml_list_structure) :: toml_array_list + + !> Current number of stored TOML values + integer :: n = 0 + + !> List of TOML values + type(toml_node), allocatable :: lst(:) + + contains + + !> Get number of TOML values in the structure + procedure :: get_len + + !> Get TOML value at a given index + procedure :: get + + !> Push back a TOML value to the structure + procedure :: push_back + + !> Remove the first element from the structure + procedure :: shift + + !> Remove the last element from the structure + procedure :: pop + + !> Destroy the data structure + procedure :: destroy + + end type toml_array_list + + !> Initial storage capacity of the datastructure + integer, parameter :: initial_size = 16 + +contains + +!> Constructor for the storage data structure +subroutine new_array_list(self, n) + + !> Instance of the structure + type(toml_array_list), intent(out) :: self + + !> Initial storage capacity + integer, intent(in), optional :: n + + self%n = 0 + if (present(n)) then + allocate(self%lst(min(1, n))) + else + allocate(self%lst(initial_size)) + end if + +end subroutine new_array_list + +!> Get number of TOML values in the structure +pure function get_len(self) result(length) + + !> Instance of the structure + class(toml_array_list), intent(in), target :: self + + !> Current length of the ordered structure + integer :: length + + length = self%n + +end function get_len + +!> Get TOML value at a given index +subroutine get(self, idx, ptr) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + !> Position in the ordered structure + integer, intent(in) :: idx + + !> Pointer to the stored value at given index + class(toml_value), pointer, intent(out) :: ptr + + nullify(ptr) + + if (idx > 0 .and. idx <= self%n) then + if (allocated(self%lst(idx)%val)) then + ptr => self%lst(idx)%val + end if + end if + +end subroutine get + +!> Push back a TOML value to the structure +subroutine push_back(self, val) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + !> TOML value to be stored + class(toml_value), allocatable, intent(inout) :: val + + integer :: m + + if (.not.allocated(self%lst)) then + call resize(self%lst, initial_size) + end if + + m = size(self%lst) + if (self%n >= m) then + call resize(self%lst, m + m/2 + 1) + end if + + self%n = self%n + 1 + call move_alloc(val, self%lst(self%n)%val) + +end subroutine push_back + +!> Remove the first element from the data structure +subroutine shift(self, val) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + integer :: i + + if (self%n > 0) then + call move_alloc(self%lst(1)%val, val) + do i = 2, self%n + call move_alloc(self%lst(i)%val, self%lst(i-1)%val) + end do + self%n = self%n - 1 + end if + +end subroutine shift + +!> Remove the last element from the data structure +subroutine pop(self, val) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + if (self%n > 0) then + call move_alloc(self%lst(self%n)%val, val) + self%n = self%n - 1 + end if + +end subroutine pop + +!> Deconstructor for data structure +subroutine destroy(self) + + !> Instance of the structure + class(toml_array_list), intent(inout), target :: self + + integer :: i + + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + call self%lst(i)%val%destroy + end if + end do + + deallocate(self%lst) + self%n = 0 + +end subroutine destroy + +end module tomlf_structure_array_list + +!>>>>> build/dependencies/toml-f/src/tomlf/structure/ordered_map.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a basic storage structure as pointer list of pointers. +!> +!> This implementation does purposely not use pointer attributes in the +!> datastructure to make it safer to work with. +module tomlf_structure_ordered_map + use tomlf_constants, only : tfc + use tomlf_structure_map, only : toml_map_structure + use tomlf_structure_node, only : toml_node, resize + use tomlf_type_value, only : toml_value, toml_key + implicit none + private + + public :: toml_ordered_map, new_ordered_map + + !> Stores TOML values in a list of pointers + type, extends(toml_map_structure) :: toml_ordered_map + + !> Current number of stored TOML values + integer :: n = 0 + + !> List of TOML values + type(toml_node), allocatable :: lst(:) + + contains + + !> Get TOML value at a given key + procedure :: get + + !> Push back a TOML value to the structure + procedure :: push_back + + !> Remove TOML value at a given key and return it + procedure :: pop + + !> Get list of all keys in the structure + procedure :: get_keys + + !> Delete TOML value at a given key + procedure :: delete + + !> Destroy the data structure + procedure :: destroy + + end type toml_ordered_map + + !> Initial storage capacity of the datastructure + integer, parameter :: initial_size = 16 + +contains + +!> Constructor for the storage data structure +subroutine new_ordered_map(self, n) + + !> Instance of the structure + type(toml_ordered_map), intent(out) :: self + + !> Initial storage capacity + integer, intent(in), optional :: n + + self%n = 0 + if (present(n)) then + allocate(self%lst(min(1, n))) + else + allocate(self%lst(initial_size)) + end if + +end subroutine new_ordered_map + +!> Get TOML value at a given key +subroutine get(self, key, ptr) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the stored value at given key + class(toml_value), pointer, intent(out) :: ptr + + integer :: i + + nullify(ptr) + + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + if (self%lst(i)%val%match_key(key)) then + ptr => self%lst(i)%val + exit + end if + end if + end do + +end subroutine get + +!> Push back a TOML value to the structure +subroutine push_back(self, val) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> TOML value to be stored + class(toml_value), allocatable, intent(inout) :: val + + integer :: m + + if (.not.allocated(self%lst)) then + call resize(self%lst, initial_size) + end if + + m = size(self%lst) + if (self%n >= m) then + call resize(self%lst, m + m/2 + 1) + end if + + self%n = self%n + 1 + call move_alloc(val, self%lst(self%n)%val) + +end subroutine push_back + +!> Get list of all keys in the structure +subroutine get_keys(self, list) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> List of all keys + type(toml_key), allocatable, intent(out) :: list(:) + + integer :: i + + allocate(list(self%n)) + + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + if (allocated(self%lst(i)%val%key)) then + list(i)%key = self%lst(i)%val%key + list(i)%origin = self%lst(i)%val%origin + end if + end if + end do + +end subroutine get_keys + +!> Remove TOML value at a given key and return it +subroutine pop(self, key, val) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Removed TOML value + class(toml_value), allocatable, intent(out) :: val + + integer :: idx, i + + idx = 0 + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + if (self%lst(i)%val%match_key(key)) then + idx = i + exit + end if + end if + end do + + if (idx > 0) then + call move_alloc(self%lst(idx)%val, val) + do i = idx+1, self%n + call move_alloc(self%lst(i)%val, self%lst(i-1)%val) + end do + self%n = self%n - 1 + end if + +end subroutine pop + +!> Delete TOML value at a given key +subroutine delete(self, key) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + class(toml_value), allocatable :: val + + call self%pop(key, val) + if (allocated(val)) then + call val%destroy() + end if + +end subroutine delete + +!> Deconstructor for data structure +subroutine destroy(self) + + !> Instance of the structure + class(toml_ordered_map), intent(inout), target :: self + + integer :: i + + do i = 1, self%n + if (allocated(self%lst(i)%val)) then + call self%lst(i)%val%destroy + end if + end do + + deallocate(self%lst) + self%n = 0 + +end subroutine destroy + +end module tomlf_structure_ordered_map + +!>>>>> build/dependencies/toml-f/src/tomlf/structure.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Abstraction layer for the actual storage of the data structure. +!> +!> The structure implementations provide the actual storage for TOML values, with +!> a generic enough interface to make the definition of the TOML data structures +!> independent of the actual algorithm used for storing the TOML values. +!> +!> Every data structure defined here should strive to only use allocatable +!> data types and limit the use of pointer attributes as they interfer with +!> the automatic memory management of Fortran. A well defined data structure +!> in allocatables allows deep-copying of TOML values by assignment, data structures +!> requiring pointer attributes have to define an assignment(=) interface to +!> allow deep-copying of TOML values. +module tomlf_structure + use tomlf_structure_list, only : toml_list_structure + use tomlf_structure_map, only : toml_map_structure + use tomlf_structure_array_list, only : toml_array_list, new_array_list + use tomlf_structure_ordered_map, only : toml_ordered_map, new_ordered_map + implicit none + private + + public :: toml_list_structure, toml_map_structure + public :: new_list_structure, new_map_structure + +contains + +!> Constructor for the ordered storage data structure +subroutine new_list_structure(self) + + !> Instance of the structure + class(toml_list_structure), allocatable, intent(out) :: self + + block + type(toml_array_list), allocatable :: list + + allocate(list) + call new_array_list(list) + call move_alloc(list, self) + end block + +end subroutine new_list_structure + +!> Constructor for the storage data structure +subroutine new_map_structure(self) + + !> Instance of the structure + class(toml_map_structure), allocatable, intent(out) :: self + + block + type(toml_ordered_map), allocatable :: map + + allocate(map) + call new_ordered_map(map) + call move_alloc(map, self) + end block + +end subroutine new_map_structure + +end module tomlf_structure + +!>>>>> build/dependencies/toml-f/src/tomlf/de/lexer.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Provides tokenization for TOML documents. +!> +!> The lexer provides a way to turn a stream of characters into tokens which +!> are further processed by the parser and turned into actual TOML data structures. +!> In the current structure no knowledge about the character stream is required +!> in the parser to generate the data structures. +!> +!> The validity of all tokens can be guaranteed by the lexer, however syntax errors +!> and semantic errors are not detected until the parser is run. Identification of +!> invalid tokens and recovery of the tokenization is done on a best effort basis. +!> +!> To avoid overflows in the parser due to deeply nested but unclosed groups, the +!> lexer will always tokenize a complete group to verify it is closed properly. +!> Unclosed groups will lead to the first token of the group getting invalidated, +!> to allow reporting in the parsing phase. +module tomlf_de_lexer + use tomlf_constants, only : tfc, tfi, tfr, TOML_BACKSPACE, TOML_TABULATOR, TOML_NEWLINE, & + & TOML_CARRIAGE_RETURN, TOML_FORMFEED + use tomlf_datetime, only : toml_datetime, toml_date, toml_time + use tomlf_de_abc, only : abstract_lexer + use tomlf_de_context, only : toml_context + use tomlf_de_token, only : toml_token, stringify, token_kind, resize + use tomlf_error, only : toml_error, toml_stat, make_error + use tomlf_utils, only : read_whole_file, read_whole_line + implicit none + private + + public :: toml_lexer, new_lexer_from_file, new_lexer_from_unit, new_lexer_from_string + public :: toml_token, stringify, token_kind + + !> Possible characters encountered in a lexeme + type :: enum_char + character(1, tfc) :: space = tfc_" " + character(1, tfc) :: hash = tfc_"#" + character(1, tfc) :: squote = tfc_"'" + character(3, tfc) :: squote3 = repeat(tfc_"'", 3) + character(1, tfc) :: dquote = tfc_"""" + character(3, tfc) :: dquote3 = repeat(tfc_"""", 3) + character(1, tfc) :: backslash = tfc_"\" + character(1, tfc) :: dot = tfc_"." + character(1, tfc) :: comma = tfc_"," + character(1, tfc) :: equal = tfc_"=" + character(1, tfc) :: lbrace = tfc_"{" + character(1, tfc) :: rbrace = tfc_"}" + character(1, tfc) :: lbracket = tfc_"[" + character(1, tfc) :: rbracket = tfc_"]" + character(1, tfc) :: newline = achar(10, kind=tfc) + character(1, tfc) :: formfeed = achar(12, kind=tfc) + character(1, tfc) :: carriage_return = achar(13, kind=tfc) + character(1, tfc) :: bspace = achar(8, kind=tfc) + character(1, tfc) :: tab = achar(9, kind=tfc) + character(1, tfc) :: plus = tfc_"+" + character(1, tfc) :: minus = tfc_"-" + character(12, tfc) :: literal = tfc_"0123456789-_" + end type enum_char + + !> Actual enumerator for possible characters + type(enum_char), parameter :: char_kind = enum_char() + + !> Set of characters marking a terminated lexeme, mainly used for values and to + !> obtain boundaries of invalid tokens. + character(*, tfc), parameter :: terminated = & + & char_kind%space//char_kind%tab//char_kind%newline//char_kind%carriage_return//& + & char_kind%hash//char_kind%rbrace//char_kind%rbracket//char_kind%comma//& + & char_kind%equal + + !> Scopes to identify the state of the lexer. + type :: enum_scope + !> Table scopes allow keypaths, in this scenario only bare keys, strings and + !> literals are allowed, furthermore dots become special characters to separate + !> the keypaths. + integer :: table = 1 + !> Terminates a table scope and opens a value scope. Here usual values, like integer, + !> floats or strings are allowed. + integer :: equal = 2 + !> Opens an array scope, similar to the value scope for allowed characters but with + !> simplified closing rules to allow handling of values and inline tables in arrays. + integer :: array = 3 + end type enum_scope + + !> Actual enumerator for auxiliary scopes + type(enum_scope), parameter :: lexer_scope = enum_scope() + + !> Item identifying the scope and the corresponding token index + type :: stack_item + !> Current scope of the item, can only be removed with matching scope + integer :: scope + !> Token index in the buffer of the lexer, used for invalidation of unclosed groups + integer :: token + end type stack_item + + !> Reallocate the stack of scopes + interface resize + module procedure :: resize_scope + end interface + + !> Tokenizer for TOML documents. + type, extends(abstract_lexer) :: toml_lexer + !> Name of the source file, used for error reporting + character(len=:), allocatable :: filename + !> Current internal position in the source chunk + integer :: pos = 0 + !> Current source chunk, for convenience stored as character array rather than string + character(:, tfc), allocatable :: chunk + !> Last scope of the lexer + integer :: top = 0 + !> Stack of scopes, used to identify the current state of the lexer + type(stack_item), allocatable :: stack(:) + !> Index in the buffer queue + integer :: buffer = 0 + !> Douple-ended queue for buffering tokens + type(toml_context) :: context + contains + !> Obtain the next token + procedure :: next + !> Extract a string from a token + procedure :: extract_string + !> Extract an integer from a token + procedure :: extract_integer + !> Extract a float from a token + procedure :: extract_float + !> Extract a boolean from a token + procedure :: extract_bool + !> Extract a timestamp from a token + procedure :: extract_datetime + !> Get information about source + procedure :: get_info + end type toml_lexer + +contains + +!> Create a new instance of a lexer by reading from a file +subroutine new_lexer_from_file(lexer, filename, error) + !> Instance of the lexer + type(toml_lexer), intent(out) :: lexer + !> Name of the file to read from + character(len=*), intent(in) :: filename + !> Error code + type(toml_error), allocatable, intent(out) :: error + + integer :: stat + + lexer%pos = 0 + lexer%filename = filename + call resize(lexer%stack) + call read_whole_file(filename, lexer%chunk, stat) + + if (stat /= 0) then + call make_error(error, "Could not open file '"//filename//"'") + end if +end subroutine new_lexer_from_file + +!> Create a new instance of a lexer by reading from a unit. +!> +!> Currently, only sequential access units can be processed by this constructor. +subroutine new_lexer_from_unit(lexer, io, error) + !> Instance of the lexer + type(toml_lexer), intent(out) :: lexer + !> Unit to read from + integer, intent(in) :: io + !> Error code + type(toml_error), allocatable, intent(out) :: error + + character(:, tfc), allocatable :: source, line + integer, parameter :: bufsize = 512 + character(bufsize, tfc) :: filename, mode + integer :: stat + + inquire(unit=io, access=mode, name=filename) + select case(trim(mode)) + case default + stat = 1 + + case("sequential", "SEQUENTIAL") + allocate(character(0) :: source) + do + call read_whole_line(io, line, stat) + if (stat > 0) exit + source = source // line // TOML_NEWLINE + if (stat < 0) then + if (is_iostat_end(stat)) stat = 0 + exit + end if + end do + call new_lexer_from_string(lexer, source) + end select + if (len_trim(filename) > 0) lexer%filename = trim(filename) + + if (stat /= 0) then + call make_error(error, "Failed to read from unit") + end if +end subroutine new_lexer_from_unit + +!> Create a new instance of a lexer by reading from a string. +subroutine new_lexer_from_string(lexer, string) + !> Instance of the lexer + type(toml_lexer), intent(out) :: lexer + !> String to read from + character(*, tfc), intent(in) :: string + + integer :: length + + length = len(string) + lexer%pos = 0 + lexer%buffer = 0 + allocate(character(length) :: lexer%chunk) + lexer%chunk(:length) = string + call resize(lexer%stack) +end subroutine new_lexer_from_string + +!> Advance the lexer to the next token. +subroutine next(lexer, token) + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + if (lexer%buffer >= lexer%context%top) then + call fill_buffer(lexer) + end if + + lexer%buffer = lexer%buffer + 1 + token = lexer%context%token(lexer%buffer) +end subroutine next + +!> Fill the buffer with tokens, this routine will attempt to create as many tokens as +!> necessary to determine whether all opened groups are closed properly. +!> +!> The state of the buffer can be changed while this routine is running, therefore +!> accessing the buffer concurrently is not allowed. +subroutine fill_buffer(lexer) + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + + type(toml_token) :: token + integer :: stack_top, it + + lexer%buffer = 0 + lexer%context%top = 0 + stack_top = lexer%top + + ! Tokenization will cover always a complete scope + do while(lexer%top >= stack_top .and. token%kind /= token_kind%eof) + call next_token(lexer, token) + call lexer%context%push_back(token) + end do + + ! Flag all incomplete inline table and array scopes for the parser + if (lexer%top > stack_top) then + do it = lexer%top, stack_top + 1, -1 + select case(lexer%stack(it)%scope) + case(lexer_scope%table, lexer_scope%array) + lexer%context%token(lexer%stack(it)%token)%kind = token_kind%unclosed + end select + end do + end if +end subroutine fill_buffer + +!> Actually generate the next token, unbuffered version +subroutine next_token(lexer, token) + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + integer :: prev, pos + + ! Consume current token + lexer%pos = lexer%pos + token%last - token%first + 1 + prev = lexer%pos + pos = lexer%pos + + ! If lexer is exhausted, return EOF as early as possible + if (pos > len(lexer%chunk)) then + call pop(lexer, lexer_scope%equal) + token = toml_token(token_kind%eof, prev, pos) + return + end if + + select case(peek(lexer, pos)) + case(char_kind%hash) + do while(all(peek(lexer, pos+1) /= [char_kind%carriage_return, char_kind%newline]) & + & .and. pos <= len(lexer%chunk)) + pos = pos + 1 + end do + token = toml_token(token_kind%comment, prev, pos) + + case(char_kind%space, char_kind%tab) + do while(any(match(lexer, pos+1, [char_kind%space, char_kind%tab])) & + & .and. pos <= len(lexer%chunk)) + pos = pos + 1 + end do + token = toml_token(token_kind%whitespace, prev, pos) + + case(char_kind%newline) + call pop(lexer, lexer_scope%equal) + token = toml_token(token_kind%newline, prev, pos) + + case(char_kind%carriage_return) + if (match(lexer, pos+1, char_kind%newline)) then + pos = pos + 1 + call pop(lexer, lexer_scope%equal) + token = toml_token(token_kind%newline, prev, pos) + else + token = toml_token(token_kind%invalid, prev, pos) + end if + + case(char_kind%dot) + if (view_scope(lexer) == lexer_scope%table) then + token = toml_token(token_kind%dot, prev, pos) + else + token = toml_token(token_kind%invalid, prev, pos) + end if + + case(char_kind%comma) + call pop(lexer, lexer_scope%equal) + token = toml_token(token_kind%comma, prev, pos) + + case(char_kind%equal) + token = toml_token(token_kind%equal, prev, pos) + call push_back(lexer, lexer_scope%equal, lexer%context%top + 1) + + case(char_kind%lbrace) + token = toml_token(token_kind%lbrace, prev, pos) + call push_back(lexer, lexer_scope%table, lexer%context%top + 1) + + case(char_kind%rbrace) + call pop(lexer, lexer_scope%equal) + call pop(lexer, lexer_scope%table) + token = toml_token(token_kind%rbrace, prev, pos) + + case(char_kind%lbracket) + token = toml_token(token_kind%lbracket, prev, pos) + if (any(view_scope(lexer) == [lexer_scope%equal, lexer_scope%array])) then + call push_back(lexer, lexer_scope%array, lexer%context%top + 1) + end if + + case(char_kind%rbracket) + call pop(lexer, lexer_scope%array) + token = toml_token(token_kind%rbracket, prev, pos) + + case(char_kind%squote) + call next_sstring(lexer, token) + + case(char_kind%dquote) + call next_dstring(lexer, token) + + case default + if (view_scope(lexer) == lexer_scope%table) then + call next_keypath(lexer, token) + else + call next_literal(lexer, token) + end if + + end select +end subroutine next_token + +!> Process next literal string token, can produce normal literals and multiline literals +subroutine next_sstring(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + character(1, tfc) :: ch + integer :: prev, pos, it + logical :: valid + + prev = lexer%pos + pos = lexer%pos + + if (all(match(lexer, [pos+1, pos+2], char_kind%squote))) then + pos = pos + 3 + + pos = strstr(lexer%chunk(pos:), char_kind%squote3) + pos - 1 + if (pos < prev + 3) then + token = toml_token(token_kind%invalid, prev, len(lexer%chunk)) + return + end if + + do it = 1, 2 + if (match(lexer, pos+3, char_kind%squote)) pos = pos + 1 + end do + + valid = .true. + do it = prev + 3, pos - 1 + ch = peek(lexer, it) + valid = valid .and. valid_string(ch) + end do + + token = toml_token(merge(token_kind%mliteral, token_kind%invalid, valid), prev, pos+2) + return + end if + + valid = .true. + + do while(pos < len(lexer%chunk)) + pos = pos + 1 + ch = peek(lexer, pos) + valid = valid .and. valid_string(ch) + if (ch == char_kind%squote) exit + if (ch == char_kind%newline) then + pos = pos - 1 + valid = .false. + exit + end if + end do + + valid = valid .and. peek(lexer, pos) == char_kind%squote .and. pos /= prev + token = toml_token(merge(token_kind%literal, token_kind%invalid, valid), prev, pos) +end subroutine next_sstring + +!> Process next string token, can produce normal string and multiline string tokens +subroutine next_dstring(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + character(1, tfc) :: ch + character(*, tfc), parameter :: hexnum = "0123456789ABCDEF", valid_escape = "btnfr\""" + integer :: prev, pos, expect, it, hex + logical :: escape, valid, space + + prev = lexer%pos + pos = lexer%pos + hex = 0 + + if (all(match(lexer, [pos+1, pos+2], char_kind%dquote))) then + pos = pos + 3 + + do + it = strstr(lexer%chunk(pos:), char_kind%dquote3) + pos = it + pos - 1 + if (pos < prev + 3 .or. it == 0) then + token = toml_token(token_kind%invalid, prev, len(lexer%chunk)) + return + end if + + if (match(lexer, pos-1, char_kind%backslash)) then + pos = pos + 1 + cycle + end if + + do it = 1, 2 + if (match(lexer, pos+3, char_kind%dquote)) pos = pos + 1 + end do + exit + end do + + valid = .true. + escape = .false. + space = .false. + expect = 0 + + do it = prev + 3, pos - 1 + ch = peek(lexer, it) + if (escape) then + space = verify(ch, char_kind%space//char_kind%tab//& + & char_kind%carriage_return//char_kind%newline) == 0 + end if + if (space) then + escape = .false. + if (ch == char_kind%newline) then + if (expect > 0) expect = expect - 1 + space = .false. + cycle + end if + if (verify(ch, char_kind%space//char_kind%tab) == 0 .and. expect == 0) cycle + if (ch == char_kind%carriage_return) then + expect = 1 + cycle + end if + valid = .false. + space = .false. + expect = 0 + cycle + end if + valid = valid .and. valid_string(ch) + if (escape) then + escape = .false. + space = .false. + if (verify(ch, valid_escape) == 0) cycle + if (ch == "u") then + expect = 4 + hex = pos + 1 + cycle + end if + if (ch == "U") then + expect = 8 + hex = pos + 1 + cycle + end if + valid = .false. + cycle + end if + if (expect > 0) then + expect = expect - 1 + valid = valid .and. verify(ch, hexnum) == 0 + if (expect == 0) valid = valid .and. verify_ucs(lexer%chunk(hex:pos)) + cycle + end if + escape = ch == char_kind%backslash + end do + + ! Check for any unfinished escape sequences + valid = valid .and. expect == 0 .and. .not.(escape.or.space) + + token = toml_token(merge(token_kind%mstring, token_kind%invalid, valid), prev, pos+2) + return + end if + + valid = .true. + escape = .false. + expect = 0 + + do while(pos < len(lexer%chunk)) + pos = pos + 1 + ch = peek(lexer, pos) + valid = valid .and. valid_string(ch) + if (escape) then + escape = .false. + if (verify(ch, valid_escape) == 0) cycle + if (ch == "u") then + expect = 4 + hex = pos + 1 + cycle + end if + if (ch == "U") then + expect = 8 + hex = pos + 1 + cycle + end if + valid = .false. + cycle + end if + if (expect > 0) then + expect = expect - 1 + valid = valid .and. verify(ch, hexnum) == 0 + if (expect == 0) valid = valid .and. verify_ucs(lexer%chunk(hex:pos)) + cycle + end if + escape = ch == char_kind%backslash + if (ch == char_kind%dquote) exit + if (ch == char_kind%newline) then + pos = pos - 1 + valid = .false. + exit + end if + end do + + valid = valid .and. peek(lexer, pos) == char_kind%dquote .and. pos /= prev + token = toml_token(merge(token_kind%string, token_kind%invalid, valid), prev, pos) +end subroutine next_dstring + +!> Validate characters in string, non-printable characters are invalid in this context +pure function valid_string(ch) result(valid) + character(1, tfc), intent(in) :: ch + logical :: valid + + character(1, tfc), parameter :: x00 = achar(int(z"00")), x08 = achar(int(z"08")), & + & x0b = achar(int(z"0b")), x1f = achar(int(z"1f")), x7f = achar(int(z"7f")) + + valid = & + & .not.(x00 <= ch .and. ch <= x08) .and. & + & .not.(x0b <= ch .and. ch <= x1f) .and. & + & ch /= x7f +end function + +!> Process next bare key token, produces keypath tokens. +subroutine next_keypath(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + logical :: valid + integer :: prev, pos + character(1, tfc) :: ch + + prev = lexer%pos + pos = lexer%pos + ch = peek(lexer, pos) + + valid = (tfc_"A" <= ch .and. ch <= tfc_"Z") & + & .or. (tfc_"a" <= ch .and. ch <= tfc_"z") & + & .or. (verify(ch, char_kind%literal) == 0) + do while(verify(peek(lexer, pos+1), terminated//char_kind%dot) > 0) + pos = pos + 1 + ch = peek(lexer, pos) + + if (tfc_"A" <= ch .and. ch <= tfc_"Z") cycle + if (tfc_"a" <= ch .and. ch <= tfc_"z") cycle + if (verify(ch, char_kind%literal) == 0) cycle + + valid = .false. + cycle + end do + + token = toml_token(merge(token_kind%keypath, token_kind%invalid, valid), prev, pos) +end subroutine next_keypath + +!> Identify literal values, produces integer, float, boolean, and datetime tokens. +subroutine next_literal(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + integer :: prev, pos + integer, parameter :: offset(*) = [0, 1, 2, 3, 4, 5] + character(1, tfc), parameter :: & + & true(4) = ["t", "r", "u", "e"], false(5) = ["f", "a", "l", "s", "e"] + + prev = lexer%pos + pos = lexer%pos + + select case(peek(lexer, pos)) + case("t") + if (match_all(lexer, pos+offset(:4), true) .and. & + & verify(peek(lexer, pos+4), terminated) == 0) then + token = toml_token(token_kind%bool, prev, pos+3) + return + end if + + case("f") + if (match_all(lexer, pos+offset(:5), false) .and. & + & verify(peek(lexer, pos+5), terminated) == 0) then + token = toml_token(token_kind%bool, prev, pos+4) + return + end if + + case default + call next_datetime(lexer, token) + if (token%kind == token_kind%datetime) return + + call next_integer(lexer, token) + if (token%kind == token_kind%int) return + + call next_float(lexer, token) + if (token%kind == token_kind%float) return + + end select + + ! If the current token is invalid, advance to the next terminator + do while(verify(peek(lexer, pos+1), terminated) > 0) + pos = pos + 1 + end do + token = toml_token(token_kind%invalid, prev, pos) +end subroutine next_literal + +!> Process integer tokens and binary, octal, and hexadecimal literals. +subroutine next_integer(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + character(*, tfc), parameter :: toml_base(4) = [& + & "0123456789abcdefABCDEF", & + & "0123456789000000000000", & + & "0123456700000000000000", & + & "0100000000000000000000"] + integer, parameter :: b10 = 2, b16 = 1, b8 = 3, b2 = 4 + + character(1, tfc) :: ch + integer :: prev, pos, base + logical :: underscore, okay + + prev = lexer%pos + pos = lexer%pos + okay = .true. + underscore = .true. + base = b10 + + if (any(match(lexer, pos, ["+", "-"]))) then + pos = pos + 1 + end if + + if (match(lexer, pos, "0")) then + select case(peek(lexer, pos+1)) + case("x") + okay = pos == prev + base = b16 + pos = pos + 2 + case("o") + okay = pos == prev + base = b8 + pos = pos + 2 + case("b") + okay = pos == prev + base = b2 + pos = pos + 2 + case(char_kind%space, char_kind%tab, char_kind%newline, char_kind%carriage_return, & + & char_kind%hash, char_kind%rbrace, char_kind%rbracket, char_kind%comma) + token = toml_token(token_kind%int, prev, pos) + return + case default + do while(verify(peek(lexer, pos), terminated) > 0) + pos = pos + 1 + end do + token = toml_token(token_kind%invalid, prev, pos-1) + return + end select + end if + + do while(pos <= len(lexer%chunk)) + ch = peek(lexer, pos) + if (ch == "_") then + if (underscore) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + underscore = .true. + pos = pos + 1 + cycle + end if + + if (verify(ch, toml_base(base)) == 0) then + pos = pos + 1 + underscore = .false. + cycle + end if + + okay = okay .and. verify(ch, terminated) == 0 + exit + end do + + okay = .not.underscore .and. okay + token = toml_token(merge(token_kind%int, token_kind%invalid, okay), prev, pos-1) +end subroutine next_integer + +!> Process float tokens. +subroutine next_float(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + integer :: prev, pos + logical :: plus_minus, underscore, point, expo, okay, zero, first + character(1, tfc) :: ch + integer, parameter :: offset(*) = [0, 1, 2] + character(1, tfc), parameter :: nan(3) = ["n", "a", "n"], inf(3) = ["i", "n", "f"] + + prev = lexer%pos + pos = lexer%pos + point = .false. + expo = .false. + zero = .false. + first = .true. + underscore = .true. + plus_minus = any(match(lexer, pos, ["+", "-"])) + if (plus_minus) pos = pos + 1 + + if (match_all(lexer, pos+offset, nan) .and. & + & verify(peek(lexer, pos+3), terminated) == 0) then + token = toml_token(token_kind%float, prev, pos+2) + return + end if + + if (match_all(lexer, pos+offset, inf) .and. & + & verify(peek(lexer, pos+3), terminated) == 0) then + token = toml_token(token_kind%float, prev, pos+2) + return + end if + + do while(pos <= len(lexer%chunk)) + ch = peek(lexer, pos) + if (ch == "_") then + if (underscore) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + underscore = .true. + pos = pos + 1 + cycle + end if + + if (ch == ".") then + if (point .or. expo .or. underscore) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + zero = .false. + underscore = .true. + point = .true. + pos = pos + 1 + cycle + end if + + if (ch == "e" .or. ch == "E") then + if (expo .or. underscore) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + zero = .false. + underscore = .true. + expo = .true. + pos = pos + 1 + cycle + end if + + if (ch == "+" .or. ch == "-") then + if (.not.any(match(lexer, pos-1, ["e", "E"]))) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + underscore = .true. + pos = pos + 1 + cycle + end if + + if (verify(ch, "0123456789") == 0) then + if (zero) then + token = toml_token(token_kind%invalid, prev, pos) + return + end if + zero = first .and. ch == "0" + first = .false. + pos = pos + 1 + underscore = .false. + cycle + end if + + exit + end do + + okay = .not.underscore .and. (expo .or. point) + token = toml_token(merge(token_kind%float, token_kind%invalid, okay), prev, pos-1) +end subroutine next_float + +!> Find the next datetime expression +subroutine next_datetime(lexer, token) + !> Instance of the lexer + type(toml_lexer), intent(inout) :: lexer + !> Current lexeme + type(toml_token), intent(inout) :: token + + logical :: has_date, has_time, has_millisec, has_local, okay + integer :: prev, pos, it + integer, parameter :: offset(*) = [(it, it = 0, 10)], & + & offset_date = 10, offset_time = 8, offset_local = 6 + character(*, tfc), parameter :: num = "0123456789" + + prev = lexer%pos + pos = lexer%pos + + has_date = valid_date(peek(lexer, pos+offset(:offset_date))) + if (has_date) then + if (verify(peek(lexer, pos+offset_date), "Tt ") == 0 & + & .and. pos + offset_date < len(lexer%chunk) & + & .and. verify(peek(lexer, pos+offset_date+1), num) == 0) then + pos = pos + offset_date + 1 + end if + end if + + has_time = valid_time(peek(lexer, pos+offset(:offset_time))) + if (has_time) then + pos = pos + offset_time - 1 + if (match(lexer, pos+1, char_kind%dot)) then + it = 1 + do while(verify(peek(lexer, pos+it+1), num) == 0) + it = it + 1 + end do + has_millisec = it > 1 + if (.not.has_millisec) then + token = toml_token(token_kind%invalid, prev, prev) + return + end if + + pos = pos + it + end if + + has_local = valid_local(peek(lexer, pos+offset(:offset_local)+1)) + if (has_local) then + if (.not.has_date) then + token = toml_token(token_kind%invalid, prev, prev) + return + end if + pos = pos + offset_local + else if (verify(peek(lexer, pos+1), "zZ") == 0) then + pos = pos + 1 + end if + end if + + if (.not.(has_time.or.has_date)) then + token = toml_token(token_kind%invalid, prev, prev) + return + end if + + if (.not.has_time.and.has_date) pos = pos + offset_date - 1 + okay = verify(peek(lexer, pos+1), terminated) == 0 .and. pos <= len(lexer%chunk) + token = toml_token(merge(token_kind%datetime, token_kind%invalid, okay), prev, pos) +end subroutine next_datetime + +!> Validate a string as date +pure function valid_date(string) result(valid) + !> Input string, 10 characters + character(1, tfc), intent(in) :: string(:) + !> Valid date + logical :: valid + + integer :: it, val + character(*, tfc), parameter :: num = "0123456789" + integer :: year, month, day, mday + logical :: leap + + valid = .false. + if (any(string([5, 8]) /= "-")) return + + year = 0 + do it = 1, 4 + val = scan(num, string(it)) - 1 + if (val < 0) return + year = year * 10 + val + end do + + month = 0 + do it = 6, 7 + val = scan(num, string(it)) - 1 + if (val < 0) return + month = month * 10 + val + end do + + day = 0 + do it = 9, 10 + val = scan(num, string(it)) - 1 + if (val < 0) return + day = day * 10 + val + end do + + mday = 0 + select case(month) + case(1, 3, 5, 7, 8, 10, 12) + mday = 31 + case(2) + leap = mod(year, 4) == 0 .and. (mod(year, 100) /= 0 .or. mod(year, 400) == 0) + mday = merge(29, 28, leap) + case(4, 6, 9, 11) + mday = 30 + end select + valid = day >= 1 .and. day <= mday +end function valid_date + +!> Validate a string as time +function valid_time(string) result(valid) + !> Input string, 8 characters + character(1, tfc), intent(in) :: string(:) + !> Valid time + logical :: valid + + integer :: it, val + character(*, tfc), parameter :: num = "0123456789" + integer :: hour, minute, second + + valid = .false. + if (any(string([3, 6]) /= ":")) return + + hour = 0 + do it = 1, 2 + val = scan(num, string(it)) - 1 + if (val < 0) return + hour = hour * 10 + val + end do + + minute = 0 + do it = 4, 5 + val = scan(num, string(it)) - 1 + if (val < 0) return + minute = minute * 10 + val + end do + + second = 0 + do it = 7, 8 + val = scan(num, string(it)) - 1 + if (val < 0) return + second = second * 10 + val + end do + + valid = second >= 0 .and. second < 60 & + & .and. minute >= 0 .and. minute < 60 & + & .and. hour >= 0 .and. hour < 24 +end function valid_time + +!> Validate a string as timezone +function valid_local(string) result(valid) + !> Input string, 6 characters + character(1, tfc), intent(in) :: string(:) + !> Valid timezone + logical :: valid + + integer :: it, val + character(*, tfc), parameter :: num = "0123456789" + integer :: hour, minute + + valid = .false. + if (string(4) /= ":" .or. all(string(1) /= ["+", "-"])) return + + hour = 0 + do it = 2, 3 + val = scan(num, string(it)) - 1 + if (val < 0) return + hour = hour * 10 + val + end do + + minute = 0 + do it = 5, 6 + val = scan(num, string(it)) - 1 + if (val < 0) return + minute = minute * 10 + val + end do + + valid = minute >= 0 .and. minute < 60 & + & .and. hour >= 0 .and. hour < 24 +end function valid_local + +!> Show current character +elemental function peek(lexer, pos) result(ch) + !> Instance of the lexer + type(toml_lexer), intent(in) :: lexer + !> Position to fetch character from + integer, intent(in) :: pos + !> Character found + character(1, tfc) :: ch + + if (pos <= len(lexer%chunk)) then + ch = lexer%chunk(pos:pos) + else + ch = char_kind%space + end if +end function peek + +!> Compare a character +elemental function match(lexer, pos, kind) + !> Instance of the lexer + type(toml_lexer), intent(in) :: lexer + !> Position to fetch character from + integer, intent(in) :: pos + !> Character to compare against + character(1, tfc), intent(in) :: kind + !> Characters match + logical :: match + + match = peek(lexer, pos) == kind +end function match + +!> Compare a set of characters +pure function match_all(lexer, pos, kind) result(match) + !> Instance of the lexer + type(toml_lexer), intent(in) :: lexer + !> Position to fetch character from + integer, intent(in) :: pos(:) + !> Character to compare against + character(1, tfc), intent(in) :: kind(:) + !> Characters match + logical :: match + + match = all(peek(lexer, pos) == kind) +end function match_all + +pure function strstr(string, pattern) result(res) + character(*, tfc), intent(in) :: string + character(*, tfc), intent(in) :: pattern + integer :: lps_array(len(pattern)) + integer :: res, s_i, p_i, length_string, length_pattern + res = 0 + length_string = len(string) + length_pattern = len(pattern) + + if (length_pattern > 0 .and. length_pattern <= length_string) then + lps_array = compute_lps(pattern) + + s_i = 1 + p_i = 1 + do while(s_i <= length_string) + if (string(s_i:s_i) == pattern(p_i:p_i)) then + if (p_i == length_pattern) then + res = s_i - length_pattern + 1 + exit + end if + s_i = s_i + 1 + p_i = p_i + 1 + else if (p_i > 1) then + p_i = lps_array(p_i - 1) + 1 + else + s_i = s_i + 1 + end if + end do + end if + +contains + + pure function compute_lps(string) result(lps_array) + character(*, tfc), intent(in) :: string + integer :: lps_array(len(string)) + integer :: i, j, length_string + + length_string = len(string) + + if (length_string > 0) then + lps_array(1) = 0 + + i = 2 + j = 1 + do while (i <= length_string) + if (string(j:j) == string(i:i)) then + lps_array(i) = j + i = i + 1 + j = j + 1 + else if (j > 1) then + j = lps_array(j - 1) + 1 + else + lps_array(i) = 0 + i = i + 1 + end if + end do + end if + + end function compute_lps + +end function strstr + +!> Extract string value of token, works for keypath, string, multiline string, literal, +!> and mulitline literal tokens. +subroutine extract_string(lexer, token, string) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract string value from + type(toml_token), intent(in) :: token + !> String value of token + character(len=:), allocatable, intent(out) :: string + + integer :: it, length + logical :: escape, leading_newline + character(1, tfc) :: ch + + length = token%last - token%first + 1 + + select case(token%kind) + case(token_kind%string) + string = "" + escape = .false. + it = token%first + 1 + do while(it <= token%last - 1) + ch = peek(lexer, it) + if (escape) then + escape = .false. + select case(ch) + case("""", "\"); string = string // ch + case("b"); string = string // TOML_BACKSPACE + case("t"); string = string // TOML_TABULATOR + case("n"); string = string // TOML_NEWLINE + case("r"); string = string // TOML_CARRIAGE_RETURN + case("f"); string = string // TOML_FORMFEED + case("u"); string = string // convert_ucs(lexer%chunk(it+1:it+4)); it = it + 5 + case("U"); string = string // convert_ucs(lexer%chunk(it+1:it+8)); it = it + 9 + end select + else + escape = ch == char_kind%backslash + if (.not.escape) string = string // ch + end if + it = it + 1 + end do + case(token_kind%mstring) + leading_newline = peek(lexer, token%first+3) == char_kind%newline + string = "" + escape = .false. + it = token%first + merge(4, 3, leading_newline) + do while(it <= token%last - 3) + ch = peek(lexer, it) + if (escape) then + escape = .false. + select case(ch) + case("""", "\"); string = string // ch + case("b"); string = string // TOML_BACKSPACE + case("t"); string = string // TOML_TABULATOR + case("n"); string = string // TOML_NEWLINE + case("r"); string = string // TOML_CARRIAGE_RETURN + case("f"); string = string // TOML_FORMFEED + case("u"); string = string // convert_ucs(lexer%chunk(it+1:it+4)); it = it + 5 + case("U"); string = string // convert_ucs(lexer%chunk(it+1:it+8)); it = it + 9 + case(char_kind%space, char_kind%tab, char_kind%carriage_return) + escape = .true. + case(char_kind%newline) + continue + end select + else + escape = ch == char_kind%backslash + if (.not.escape) string = string // ch + end if + it = it + 1 + end do + case(token_kind%literal) + allocate(character(length - 2)::string) + string = lexer%chunk(token%first+1:token%last-1) + case(token_kind%mliteral) + leading_newline = peek(lexer, token%first+3) == char_kind%newline + allocate(character(length - merge(7, 6, leading_newline))::string) + string = lexer%chunk(token%first+merge(4, 3, leading_newline):token%last-3) + case(token_kind%keypath) + allocate(character(length)::string) + string = lexer%chunk(token%first:token%last) + end select + +end subroutine extract_string + +!> Extract integer value of token +subroutine extract_integer(lexer, token, val) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract integer value from + type(toml_token), intent(in) :: token + !> Integer value of token + integer(tfi), intent(out) :: val + + integer :: first, base, it, tmp + logical :: minus + character(1, tfc) :: ch + character(*, tfc), parameter :: num = "0123456789abcdef" + + if (token%kind /= token_kind%int) return + + val = 0 + base = 10 + first = token%first + + if (any(peek(lexer, first) == ["+", "-"])) first = first + 1 + + if (peek(lexer, first) == "0") then + select case(peek(lexer, first + 1)) + case("x") + first = first + 2 + base = 16 + case("o") + first = first + 2 + base = 8 + case("b") + first = first + 2 + base = 2 + case default + return + end select + end if + + minus = match(lexer, token%first, char_kind%minus) + + do it = first, token%last + ch = peek(lexer, it) + if ("A" <= ch .and. ch <= "Z") ch = achar(iachar(ch) - iachar("A") + iachar("a")) + tmp = scan(num(:abs(base)), ch) - 1 + if (tmp < 0) cycle + val = val * base + merge(-tmp, tmp, minus) + end do +end subroutine extract_integer + +!> Extract floating point value of token +subroutine extract_float(lexer, token, val) + ! Not useable since unsupported with GFortran on some platforms (MacOS/ppc) + ! use, intrinsic :: ieee_arithmetic, only : ieee_value, ieee_quite_nan, & + ! & ieee_positive_inf, ieee_negative_inf + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract floating point value from + type(toml_token), intent(in) :: token + !> Floating point value of token + real(tfr), intent(out) :: val + + integer :: first, it, ic + character(len=token%last - token%first + 1) :: buffer + character(1, tfc) :: ch + + if (token%kind /= token_kind%float) return + + first = token%first + + if (any(peek(lexer, first) == ["+", "-"])) first = first + 1 + + if (match(lexer, first, "n")) then + ! val = ieee_value(val, ieee_quite_nan) + buffer = "NaN" + read(buffer, *, iostat=ic) val + return + end if + + if (match(lexer, first, "i")) then + ! val = ieee_value(val, ieee_positive_inf) + buffer = "Inf" + read(buffer, *, iostat=ic) val + if (match(lexer, token%first, char_kind%minus)) val = -val + return + end if + +! ival = 0 +! idot = 0 +! +! do it = first, token%last +! ch = peek(lexer, it) +! if (any(ch == [".", "e", "E"])) exit +! tmp = scan(num(:base), ch) - 1 +! if (tmp < 0) cycle +! ival = ival * base + tmp +! end do +! first = it +! +! if (ch == ".") then +! idot = 0 +! do it = first, token%last +! ch = peek(lexer, it) +! if (any(ch == ["e", "E"])) exit +! tmp = scan(num(:base), ch) - 1 +! if (tmp < 0) cycle +! idot = idot + 1 +! ival = ival * base + tmp +! end do +! first = it +! end if +! +! expo = 0 +! if (any(ch == ["e", "E"])) then +! first = first + 1 +! do it = first, token%last +! ch = peek(lexer, it) +! tmp = scan(num(:base), ch) - 1 +! if (tmp < 0) cycle +! expo = expo * base + tmp +! end do +! if (match(lexer, first, char_kind%minus)) expo = -expo +! end if +! expo = expo - idot +! val = ival * 10.0_tfr ** expo ! FIXME +! +! if (match(lexer, token%first, char_kind%minus)) val = -val + + ic = 0 + do it = token%first, token%last + ch = peek(lexer, it) + if (ch == "_") cycle + ic = ic + 1 + buffer(ic:ic) = ch + end do + + read(buffer(:ic), *, iostat=it) val +end subroutine extract_float + +!> Extract boolean value of token +subroutine extract_bool(lexer, token, val) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract boolean value from + type(toml_token), intent(in) :: token + !> Boolean value of token + logical, intent(out) :: val + + if (token%kind /= token_kind%bool) return + + val = peek(lexer, token%first) == "t" +end subroutine extract_bool + +!> Extract datetime value of token +subroutine extract_datetime(lexer, token, val) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Token to extract datetime value from + type(toml_token), intent(in) :: token + !> Datetime value of token + type(toml_datetime), intent(out) :: val + + if (token%kind /= token_kind%datetime) return + + val = toml_datetime(lexer%chunk(token%first:token%last)) +end subroutine extract_datetime + +!> Push a new scope onto the lexer stack and record the token +pure subroutine push_back(lexer, scope, token) + type(toml_lexer), intent(inout) :: lexer + integer, intent(in) :: scope + integer, intent(in) :: token + + lexer%top = lexer%top + 1 + if (lexer%top > size(lexer%stack)) call resize(lexer%stack) + lexer%stack(lexer%top) = stack_item(scope, token) +end subroutine push_back + +!> Pop a scope from the lexer stack in case the topmost scope matches the requested scope +subroutine pop(lexer, scope) + type(toml_lexer), intent(inout) :: lexer + integer, intent(in) :: scope + + if (lexer%top > 0) then + if (lexer%stack(lexer%top)%scope == scope) lexer%top = lexer%top - 1 + end if +end subroutine pop + +!> Peek at the topmost scope on the lexer stack +pure function view_scope(lexer) result(scope) + type(toml_lexer), intent(in) :: lexer + integer :: scope + + if (lexer%top > 0) then + scope = lexer%stack(lexer%top)%scope + else + scope = lexer_scope%table + end if +end function view_scope + +!> Reallocate list of scopes +pure subroutine resize_scope(var, n) + !> Instance of the array to be resized + type(stack_item), allocatable, intent(inout) :: var(:) + !> Dimension of the final array size + integer, intent(in), optional :: n + + type(stack_item), allocatable :: tmp(:) + integer :: this_size, new_size + integer, parameter :: initial_size = 8 + + if (allocated(var)) then + this_size = size(var, 1) + call move_alloc(var, tmp) + else + this_size = initial_size + end if + + if (present(n)) then + new_size = n + else + new_size = this_size + this_size/2 + 1 + end if + + allocate(var(new_size)) + + if (allocated(tmp)) then + this_size = min(size(tmp, 1), size(var, 1)) + var(:this_size) = tmp(:this_size) + deallocate(tmp) + end if + +end subroutine resize_scope + +!> Extract information about the source +subroutine get_info(lexer, meta, output) + !> Instance of the lexer + class(toml_lexer), intent(in) :: lexer + !> Query about the source + character(*, tfc), intent(in) :: meta + !> Metadata about the source + character(:, tfc), allocatable, intent(out) :: output + + select case(meta) + case("source") + output = lexer%chunk // TOML_NEWLINE + case("filename") + if (allocated(lexer%filename)) output = lexer%filename + end select +end subroutine get_info + +function hex_to_int(hex) result(val) + character(*, tfc), intent(in) :: hex + integer(tfi) :: val + integer :: i + character(1, tfc) :: ch + character(*, tfc), parameter :: hex_digits = "0123456789abcdef" + + val = 0_tfi + do i = 1, len(hex) + ch = hex(i:i) + if ("A" <= ch .and. ch <= "Z") ch = achar(iachar(ch) - iachar("A") + iachar("a")) + val = val * 16 + max(index(hex_digits, ch) - 1, 0) + end do +end function hex_to_int + +function verify_ucs(escape) result(valid) + character(*, tfc), intent(in) :: escape + logical :: valid + integer(tfi) :: code + + code = hex_to_int(escape) + + valid = code > 0 .and. code < int(z"7FFFFFFF", tfi) & + & .and. (code < int(z"d800", tfi) .or. code > int(z"dfff", tfi)) & + & .and. (code < int(z"fffe", tfi) .or. code > int(z"ffff", tfi)) +end function verify_ucs + +function convert_ucs(escape) result(str) + character(*, tfc), intent(in) :: escape + character(:, tfc), allocatable :: str + integer(tfi) :: code + + code = hex_to_int(escape) + + select case(code) + case(int(z"00000000", tfi):int(z"0000007f", tfi)) + str = achar(code, kind=tfc) + case(int(z"00000080", tfi):int(z"000007ff", tfi)) + str = & + achar(ior(int(z"c0", tfi), ishft(code, -6)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + case(int(z"00000800", tfi):int(z"0000ffff", tfi)) + str = & + achar(ior(int(z"e0", tfi), ishft(code, -12)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -6), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + case(int(z"00010000", tfi):int(z"001fffff", tfi)) + str = & + achar(ior(int(z"f0", tfi), ishft(code, -18)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -12), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -6), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + case(int(z"00200000", tfi):int(z"03ffffff", tfi)) + str = & + achar(ior(int(z"f8", tfi), ishft(code, -24)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -18), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -12), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -6), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + case(int(z"04000000", tfi):int(z"7fffffff", tfi)) + str = & + achar(ior(int(z"fc", tfi), ishft(code, -30)), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -24), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -18), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -12), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(ishft(code, -6), int(z"3f", tfi))), kind=tfc) // & + achar(ior(int(z"80", tfi), iand(code, int(z"3f", tfi))), kind=tfc) + end select +end function convert_ucs + +end module tomlf_de_lexer + +!>>>>> build/dependencies/toml-f/src/tomlf/type/array.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of the TOML array data type. +module tomlf_type_array + use tomlf_error, only : toml_stat + use tomlf_type_value, only : toml_value, toml_visitor + use tomlf_structure, only : toml_list_structure, new_list_structure + implicit none + private + + public :: toml_array, new_array, new, initialized, len + + !> TOML array + type, extends(toml_value) :: toml_array + + !> Is an inline array rather than an array of tables + logical :: inline = .true. + + !> Storage unit for TOML values of this array + class(toml_list_structure), allocatable, private :: list + + contains + + !> Get the TOML value at a given index + procedure :: get + + !> Append value to array + procedure :: push_back + + !> Remove the first element from the array + procedure :: shift + + !> Remove the last element from the array + procedure :: pop + + !> Release allocation hold by TOML array + procedure :: destroy + + end type toml_array + + !> Create standard constructor + interface toml_array + module procedure :: new_array_func + end interface toml_array + + !> Overloaded constructor for TOML values + interface new + module procedure :: new_array + end interface + + !> Overload len function + interface len + module procedure :: get_len + end interface + + !> Check whether data structure is initialized properly + interface initialized + module procedure :: array_initialized + end interface initialized + +contains + +!> Constructor to create a new TOML array and allocate the internal storage +subroutine new_array(self) + + !> Instance of the TOML array + type(toml_array), intent(out) :: self + + call new_list_structure(self%list) + +end subroutine new_array + +!> Default constructor for TOML array type +function new_array_func() result(self) + + !> Instance of the TOML array + type(toml_array) :: self + + call new_array(self) + +end function new_array_func + +!> Check whether data structure is initialized properly +pure function array_initialized(self) result(okay) + + !> Instance of the TOML array + type(toml_array), intent(in) :: self + + !> Data structure is initialized + logical :: okay + + okay = allocated(self%list) +end function array_initialized + +!> Get number of TOML values in the array +pure function get_len(self) result(length) + + !> Instance of the TOML array + class(toml_array), intent(in) :: self + + !> Current length of the array + integer :: length + + length = self%list%get_len() + +end function get_len + +!> Get the TOML value at the respective index +subroutine get(self, idx, ptr) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + !> Index to the TOML value + integer, intent(in) :: idx + + !> Pointer to the TOML value + class(toml_value), pointer, intent(out) :: ptr + + call self%list%get(idx, ptr) + +end subroutine get + +!> Push back a TOML value to the array +subroutine push_back(self, val, stat) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + !> TOML value to append to array + class(toml_value), allocatable, intent(inout) :: val + + !> Status of operation + integer, intent(out) :: stat + + if (allocated(val%key)) then + stat = toml_stat%fatal + return + end if + + call self%list%push_back(val) + + stat = toml_stat%success + +end subroutine push_back + +!> Remove the first element from the data structure +subroutine shift(self, val) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + call self%list%shift(val) + +end subroutine shift + +!> Remove the last element from the data structure +subroutine pop(self, val) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + !> TOML value to be retrieved + class(toml_value), allocatable, intent(out) :: val + + call self%list%pop(val) + +end subroutine pop + +!> Deconstructor to cleanup allocations (optional) +subroutine destroy(self) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: self + + if (allocated(self%key)) then + deallocate(self%key) + end if + + if (allocated(self%list)) then + call self%list%destroy + deallocate(self%list) + end if + +end subroutine destroy + +end module tomlf_type_array + +!>>>>> build/dependencies/toml-f/src/tomlf/type/table.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of the TOML table data type. +!> +!> Every TOML document contains at least one (root) table which holds key-value +!> pairs, arrays and other tables. +module tomlf_type_table + use tomlf_constants, only : tfc + use tomlf_error, only : toml_stat + use tomlf_type_value, only : toml_value, toml_visitor, toml_key + use tomlf_structure, only : toml_map_structure, new_map_structure + implicit none + private + + public :: toml_table, new_table, new, initialized + + !> TOML table + type, extends(toml_value) :: toml_table + + !> Table was implictly created + logical :: implicit = .false. + + !> Is an inline table and is therefore non-extendable + logical :: inline = .false. + + !> Storage unit for TOML values of this table + class(toml_map_structure), allocatable, private :: map + + contains + + !> Get the TOML value associated with the respective key + procedure :: get + + !> Get list of all keys in this table + procedure :: get_keys + + !> Check if key is already present in this table instance + procedure :: has_key + + !> Append value to table (checks automatically for key) + procedure :: push_back + + !> Remove TOML value at a given key and return it + procedure :: pop + + !> Delete TOML value at a given key + procedure :: delete + + !> Release allocation hold by TOML table + procedure :: destroy + + end type toml_table + + !> Create standard constructor + interface toml_table + module procedure :: new_table_func + end interface toml_table + + !> Overloaded constructor for TOML values + interface new + module procedure :: new_table + end interface + + !> Check whether data structure is initialized properly + interface initialized + module procedure :: table_initialized + end interface initialized + +contains + +!> Constructor to create a new TOML table and allocate the internal storage +subroutine new_table(self) + + !> Instance of the TOML table + type(toml_table), intent(out) :: self + + call new_map_structure(self%map) + +end subroutine new_table + +!> Default constructor for TOML table type +function new_table_func() result(self) + + !> Instance of the TOML table + type(toml_table) :: self + + call new_table(self) + +end function new_table_func + +!> Check whether data structure is initialized properly +pure function table_initialized(self) result(okay) + + !> Instance of the TOML table + type(toml_table), intent(in) :: self + + !> Data structure is initialized + logical :: okay + + okay = allocated(self%map) +end function table_initialized + +!> Get the TOML value associated with the respective key +subroutine get(self, key, ptr) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the TOML value + class(toml_value), pointer, intent(out) :: ptr + + call self%map%get(key, ptr) + +end subroutine get + +!> Get list of all keys in this table +subroutine get_keys(self, list) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> List of all keys + type(toml_key), allocatable, intent(out) :: list(:) + + call self%map%get_keys(list) + +end subroutine get_keys + +!> Check if a key is present in the table +function has_key(self, key) result(found) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> TOML value is present in table + logical :: found + + class(toml_value), pointer :: ptr + + call self%map%get(key, ptr) + + found = associated(ptr) + +end function has_key + +!> Push back a TOML value to the table +subroutine push_back(self, val, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> TOML value to append to table + class(toml_value), allocatable, intent(inout) :: val + + !> Status of operation + integer, intent(out) :: stat + + class(toml_value), pointer :: ptr + + if (.not.allocated(val)) then + stat = merge(self%origin, toml_stat%fatal, self%origin > 0) + return + end if + + if (.not.allocated(val%key)) then + stat = merge(val%origin, toml_stat%fatal, val%origin > 0) + return + end if + + call self%get(val%key, ptr) + if (associated(ptr)) then + stat = merge(ptr%origin, toml_stat%duplicate_key, ptr%origin > 0) + return + end if + + call self%map%push_back(val) + + stat = toml_stat%success + +end subroutine push_back + +!> Remove TOML value at a given key and return it +subroutine pop(self, key, val) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + !> Removed TOML value to return + class(toml_value), allocatable, intent(out) :: val + + call self%map%pop(key, val) + +end subroutine pop + +!> Delete TOML value at a given key +subroutine delete(self, key) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + !> Key to the TOML value + character(kind=tfc, len=*), intent(in) :: key + + call self%map%delete(key) + +end subroutine delete + +!> Deconstructor to cleanup allocations (optional) +subroutine destroy(self) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: self + + if (allocated(self%key)) then + deallocate(self%key) + end if + + if (allocated(self%map)) then + call self%map%destroy + deallocate(self%map) + end if + +end subroutine destroy + +end module tomlf_type_table + +!>>>>> build/dependencies/toml-f/src/tomlf/type.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Collection of the central datatypes to define TOML data structures +!> +!> All TOML data types should inherit from an abstract value allowing to generate +!> a generic interface to deal with all more specialized TOML data types, while +!> the abstract value is interesting for developing algorithms in TOML-Fortran, +!> the user of TOML-Fortran will usually only care about TOML tables and possibly +!> arrays. +!> +!> The TOML types defined here should implement the TOML data structures (mostly) +!> without taking the actual implementation of the data structures into account. +!> This is done by providing a bare minimum interface using type bound procedures +!> to minimize the interdependencies between the datatypes. +!> +!> To make the data types extendable a visitor pattern allows access to the TOML +!> data types and can be used to implement further algorithms. +module tomlf_type + use tomlf_constants, only : tfc + use tomlf_error, only : toml_stat + use tomlf_type_array, only : toml_array, new_array, new, initialized, len + use tomlf_type_keyval, only : toml_keyval, new_keyval, new + use tomlf_type_table, only : toml_table, new_table, new, initialized + use tomlf_type_value, only : toml_value, toml_visitor, toml_key + implicit none + private + + public :: toml_value, toml_visitor, toml_table, toml_array, toml_keyval + public :: toml_key + public :: new, new_table, new_array, new_keyval, initialized, len + public :: add_table, add_array, add_keyval + public :: is_array_of_tables + public :: cast_to_table, cast_to_array, cast_to_keyval + + !> Interface to build new tables + interface add_table + module procedure :: add_table_to_table + module procedure :: add_table_to_table_key + module procedure :: add_table_to_array + end interface add_table + + !> Interface to build new arrays + interface add_array + module procedure :: add_array_to_table + module procedure :: add_array_to_table_key + module procedure :: add_array_to_array + end interface add_array + + !> Interface to build new key-value pairs + interface add_keyval + module procedure :: add_keyval_to_table + module procedure :: add_keyval_to_table_key + module procedure :: add_keyval_to_array + end interface add_keyval + +contains + +!> Create a new TOML table inside an existing table +subroutine add_table_to_table(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new table + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the newly created table + type(toml_table), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_table_(val) + val%key = key + call table%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call table%get(key, tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_table) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_table_to_table + +!> Create a new TOML table inside an existing table +subroutine add_table_to_table_key(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new table + type(toml_key), intent(in) :: key + + !> Pointer to the newly created table + type(toml_table), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + call add_table(table, key%key, ptr, stat) + if (associated(ptr)) ptr%origin = key%origin +end subroutine add_table_to_table_key + +!> Create a new TOML array inside an existing table +subroutine add_array_to_table(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new array + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the newly created array + type(toml_array), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_array_(val) + val%key = key + call table%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call table%get(key, tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_array) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_array_to_table + +!> Create a new TOML array inside an existing table +subroutine add_array_to_table_key(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new array + type(toml_key), intent(in) :: key + + !> Pointer to the newly created array + type(toml_array), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + call add_array(table, key%key, ptr, stat) + if (associated(ptr)) ptr%origin = key%origin +end subroutine add_array_to_table_key + +!> Create a new key-value pair inside an existing table +subroutine add_keyval_to_table(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new key-value pair + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to the newly created key-value pair + type(toml_keyval), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_keyval_(val) + val%key = key + call table%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call table%get(key, tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_keyval) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_keyval_to_table + +!> Create a new key-value pair inside an existing table +subroutine add_keyval_to_table_key(table, key, ptr, stat) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key for the new key-value pair + type(toml_key), intent(in) :: key + + !> Pointer to the newly created key-value pair + type(toml_keyval), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + call add_keyval(table, key%key, ptr, stat) + if (associated(ptr)) ptr%origin = key%origin +end subroutine add_keyval_to_table_key + +!> Create a new TOML table inside an existing array +subroutine add_table_to_array(array, ptr, stat) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Pointer to the newly created table + type(toml_table), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_table_(val) + call array%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call array%get(len(array), tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_table) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_table_to_array + +!> Create a new TOML array inside an existing array +subroutine add_array_to_array(array, ptr, stat) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Pointer to the newly created array + type(toml_array), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + allocate(toml_array :: val) + call new_array_(val) + call array%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call array%get(len(array), tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_array) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_array_to_array + +!> Create a new key-value pair inside an existing array +subroutine add_keyval_to_array(array, ptr, stat) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Pointer to the newly created key-value pair + type(toml_keyval), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), allocatable :: val + class(toml_value), pointer :: tmp + integer :: istat + + nullify(ptr) + call new_keyval_(val) + call array%push_back(val, istat) + + if (allocated(val)) then + call val%destroy + if (present(stat)) stat = toml_stat%fatal + return + end if + + if (istat == toml_stat%success) then + call array%get(len(array), tmp) + if (.not.associated(tmp)) then + if (present(stat)) stat = toml_stat%fatal + return + end if + + select type(tmp) + type is(toml_keyval) + ptr => tmp + class default + istat = toml_stat%fatal + end select + end if + + if (present(stat)) stat = istat + +end subroutine add_keyval_to_array + +!> Wrapped constructor to create a new TOML table on an abstract TOML value +subroutine new_table_(self) + + !> Newly created TOML table + class(toml_value), allocatable, intent(out) :: self + + type(toml_table), allocatable :: val + + allocate(val) + call new_table(val) + call move_alloc(val, self) + +end subroutine new_table_ + +!> Wrapped constructor to create a new TOML array on an abstract TOML value +subroutine new_array_(self) + + !> Newly created TOML array + class(toml_value), allocatable, intent(out) :: self + + type(toml_array), allocatable :: val + + allocate(val) + call new_array(val) + call move_alloc(val, self) + +end subroutine new_array_ + +!> Wrapped constructor to create a new TOML array on an abstract TOML value +subroutine new_keyval_(self) + + !> Newly created key-value pair + class(toml_value), allocatable, intent(out) :: self + + type(toml_keyval), allocatable :: val + + allocate(val) + call new_keyval(val) + call move_alloc(val, self) + +end subroutine new_keyval_ + +!> Determine if array contains only tables +function is_array_of_tables(array) result(only_tables) + + !> TOML value to visit + class(toml_array), intent(inout) :: array + + !> Array contains only tables + logical :: only_tables + + class(toml_value), pointer :: ptr + integer :: i, n + + n = len(array) + only_tables = n > 0 + + do i = 1, n + call array%get(i, ptr) + select type(ptr) + type is(toml_table) + cycle + class default + only_tables = .false. + exit + end select + end do + +end function is_array_of_tables + +!> Cast an abstract TOML value to a TOML array +function cast_to_array(ptr) result(array) + !> TOML value to be casted + class(toml_value), intent(in), target :: ptr + !> TOML array view, nullified if the value is not an array + type(toml_array), pointer :: array + + nullify(array) + select type(ptr) + type is(toml_array) + array => ptr + end select +end function cast_to_array + +!> Cast an abstract TOML value to a TOML table +function cast_to_table(ptr) result(table) + !> TOML value to be casted + class(toml_value), intent(in), target :: ptr + !> TOML table view, nullified if the value is not a table + type(toml_table), pointer :: table + + nullify(table) + select type(ptr) + type is(toml_table) + table => ptr + end select +end function cast_to_table + +!> Cast an abstract TOML value to a TOML key-value pair +function cast_to_keyval(ptr) result(kval) + !> TOML value to be casted + class(toml_value), intent(in), target :: ptr + !> TOML key-value view, nullified if the value is not a table + type(toml_keyval), pointer :: kval + + nullify(kval) + select type(ptr) + type is(toml_keyval) + kval => ptr + end select +end function cast_to_keyval + +end module tomlf_type + +!>>>>> build/dependencies/toml-f/src/tomlf/ser.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> TOML serializer implementation +module tomlf_ser + use tomlf_constants, only : tfc, tfi, tfr, tfout, toml_type + use tomlf_datetime, only : toml_datetime, to_string + use tomlf_error, only : toml_error, toml_stat, make_error + use tomlf_type, only : toml_value, toml_visitor, toml_key, toml_table, & + & toml_array, toml_keyval, is_array_of_tables, len + use tomlf_utils, only : to_string, toml_escape_string + implicit none + private + + public :: toml_serializer, new_serializer, new + public :: toml_dump, toml_dumps, toml_serialize + + interface toml_dumps + module procedure :: toml_dump_to_string + end interface toml_dumps + + interface toml_dump + module procedure :: toml_dump_to_file + module procedure :: toml_dump_to_unit + end interface toml_dump + + !> Configuration for JSON serializer + type :: toml_ser_config + + !> Indentation + character(len=:), allocatable :: indent + + end type toml_ser_config + + !> TOML serializer to produduce a TOML document from a datastructure + type, extends(toml_visitor) :: toml_serializer + private + + !> Output string + character(:), allocatable :: output + + !> Configuration for serializer + type(toml_ser_config) :: config = toml_ser_config() + + !> Special mode for printing array of tables + logical, private :: array_of_tables = .false. + + !> Special mode for printing inline arrays + logical, private :: inline_array = .false. + + !> Top of the key stack + integer, private :: top = 0 + + !> Key stack to create table headers + type(toml_key), allocatable, private :: stack(:) + + contains + + !> Visit a TOML value + procedure :: visit + + end type toml_serializer + + !> Create standard constructor + interface toml_serializer + module procedure :: new_serializer_func + end interface toml_serializer + + !> Overloaded constructor for TOML serializers + interface new + module procedure :: new_serializer + end interface + + !> Initial size of the key path stack + integer, parameter :: initial_size = 8 + +contains + +!> Serialize a JSON value to a string and return it. +!> +!> In case of an error this function will invoke an error stop. +function toml_serialize(val, config) result(string) + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + !> Serialized JSON value + character(len=:), allocatable :: string + + type(toml_error), allocatable :: error + + call toml_dumps(val, string, error, config=config) + if (allocated(error)) then + print '(a)', "Error: " // error%message + error stop 1 + end if +end function toml_serialize + +!> Create a string representing the JSON value +subroutine toml_dump_to_string(val, string, error, config) + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> Formatted unit to write to + character(:), allocatable, intent(out) :: string + + !> Error handling + type(toml_error), allocatable, intent(out) :: error + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + type(toml_serializer) :: ser + + ser = toml_serializer(config=config) + call val%accept(ser) + string = ser%output +end subroutine toml_dump_to_string + +!> Write string representation of JSON value to a connected formatted unit +subroutine toml_dump_to_unit(val, io, error, config) + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> Formatted unit to write to + integer, intent(in) :: io + + !> Error handling + type(toml_error), allocatable, intent(out) :: error + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + character(len=:), allocatable :: string + character(512) :: msg + integer :: stat + + call toml_dumps(val, string, error, config=config) + if (allocated(error)) return + write(io, '(a)', iostat=stat, iomsg=msg) string + if (stat /= 0) then + call make_error(error, trim(msg)) + return + end if +end subroutine toml_dump_to_unit + +!> Write string representation of JSON value to a file +subroutine toml_dump_to_file(val, filename, error, config) + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> File name to write to + character(*), intent(in) :: filename + + !> Error handling + type(toml_error), allocatable, intent(out) :: error + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + integer :: io + integer :: stat + character(512) :: msg + + open(file=filename, newunit=io, iostat=stat, iomsg=msg) + if (stat /= 0) then + call make_error(error, trim(msg)) + return + end if + call toml_dump(val, io, error, config=config) + close(unit=io, iostat=stat, iomsg=msg) + if (.not.allocated(error) .and. stat /= 0) then + call make_error(error, trim(msg)) + end if +end subroutine toml_dump_to_file + +!> Constructor to create new serializer instance +subroutine new_serializer(self, config) + + !> Instance of the TOML serializer + type(toml_serializer), intent(out) :: self + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + self%output = "" + if (present(config)) self%config = config +end subroutine new_serializer + +!> Default constructor for TOML serializer +function new_serializer_func(config) result(self) + + !> Configuration for serializer + type(toml_ser_config), intent(in), optional :: config + + !> Instance of the TOML serializer + type(toml_serializer) :: self + + call new_serializer(self, config) +end function new_serializer_func + +!> Visit a TOML value +recursive subroutine visit(self, val) + + !> Instance of the TOML serializer + class(toml_serializer), intent(inout) :: self + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + select type(val) + class is(toml_keyval) + call visit_keyval(self, val) + class is(toml_array) + call visit_array(self, val) + class is(toml_table) + call visit_table(self, val) + end select + +end subroutine visit + +!> Visit a TOML key-value pair +subroutine visit_keyval(visitor, keyval) + + !> Instance of the TOML serializer + class(toml_serializer), intent(inout) :: visitor + + !> TOML value to visit + type(toml_keyval), intent(inout) :: keyval + + character(kind=tfc, len=:), allocatable :: key, str + type(toml_datetime), pointer :: dval + character(:, tfc), pointer :: sval + integer(tfi), pointer :: ival + real(tfr), pointer :: rval + logical, pointer :: lval + + call keyval%get_key(key) + + select case(keyval%get_type()) + case(toml_type%string) + call keyval%get(sval) + call toml_escape_string(sval, str) + case(toml_type%int) + call keyval%get(ival) + str = to_string(ival) + case(toml_type%float) + call keyval%get(rval) + str = to_string(rval) + case(toml_type%boolean) + call keyval%get(lval) + if (lval) then + str = "true" + else + str = "false" + end if + case(toml_type%datetime) + call keyval%get(dval) + str = to_string(dval) + end select + + if (visitor%inline_array) then + visitor%output = visitor%output // " " + end if + visitor%output = visitor%output // key // " = " // str + if (.not.visitor%inline_array) then + visitor%output = visitor%output // new_line('a') + end if + +end subroutine visit_keyval + +!> Visit a TOML array +recursive subroutine visit_array(visitor, array) + + !> Instance of the TOML serializer + class(toml_serializer), intent(inout) :: visitor + + !> TOML value to visit + type(toml_array), intent(inout) :: array + + class(toml_value), pointer :: ptr + character(kind=tfc, len=:), allocatable :: key, str + type(toml_datetime), pointer :: dval + character(:, tfc), pointer :: sval + integer(tfi), pointer :: ival + real(tfr), pointer :: rval + logical, pointer :: lval + integer :: i, n + + if (visitor%inline_array) visitor%output = visitor%output // " [" + n = len(array) + do i = 1, n + call array%get(i, ptr) + select type(ptr) + class is(toml_keyval) + + select case(ptr%get_type()) + case(toml_type%string) + call ptr%get(sval) + call toml_escape_string(sval, str) + case(toml_type%int) + call ptr%get(ival) + str = to_string(ival) + case(toml_type%float) + call ptr%get(rval) + str = to_string(rval) + case(toml_type%boolean) + call ptr%get(lval) + if (lval) then + str = "true" + else + str = "false" + end if + case(toml_type%datetime) + call ptr%get(dval) + str = to_string(dval) + end select + + visitor%output = visitor%output // " " // str + if (i /= n) visitor%output = visitor%output // "," + class is(toml_array) + call ptr%accept(visitor) + if (i /= n) visitor%output = visitor%output // "," + class is(toml_table) + if (visitor%inline_array) then + visitor%output = visitor%output // " {" + call ptr%accept(visitor) + visitor%output = visitor%output // " }" + if (i /= n) visitor%output = visitor%output // "," + else + visitor%array_of_tables = .true. + if (size(visitor%stack, 1) <= visitor%top) call resize(visitor%stack) + visitor%top = visitor%top + 1 + call array%get_key(key) + visitor%stack(visitor%top)%key = key + call ptr%accept(visitor) + deallocate(visitor%stack(visitor%top)%key) + visitor%top = visitor%top - 1 + end if + end select + end do + if (visitor%inline_array) visitor%output = visitor%output // " ]" + +end subroutine visit_array + +!> Visit a TOML table +recursive subroutine visit_table(visitor, table) + + !> Instance of the TOML serializer + class(toml_serializer), intent(inout) :: visitor + + !> TOML table to visit + type(toml_table), intent(inout) :: table + + class(toml_value), pointer :: ptr + type(toml_key), allocatable :: list(:) + logical, allocatable :: defer(:) + character(kind=tfc, len=:), allocatable :: key + integer :: i, n + + call table%get_keys(list) + + n = size(list, 1) + allocate(defer(n)) + + if (.not.allocated(visitor%stack)) then + call resize(visitor%stack) + else + if (.not.(visitor%inline_array .or. table%implicit)) then + visitor%output = visitor%output // "[" + if (visitor%array_of_tables) visitor%output = visitor%output // "[" + do i = 1, visitor%top-1 + visitor%output = visitor%output // visitor%stack(i)%key // "." + end do + visitor%output = visitor%output // visitor%stack(visitor%top)%key + visitor%output = visitor%output // "]" + if (visitor%array_of_tables) visitor%output = visitor%output // "]" + visitor%output = visitor%output // new_line('a') + visitor%array_of_tables = .false. + end if + end if + + do i = 1, n + defer(i) = .false. + call table%get(list(i)%key, ptr) + select type(ptr) + class is(toml_keyval) + call ptr%accept(visitor) + if (visitor%inline_array) then + if (i /= n) visitor%output = visitor%output // "," + end if + class is(toml_array) + if (visitor%inline_array) then + call ptr%get_key(key) + visitor%output = visitor%output // " " // key // " =" + call ptr%accept(visitor) + if (i /= n) visitor%output = visitor%output // "," + else + if (is_array_of_tables(ptr)) then + ! Array of tables open a new section + ! -> cannot serialize them before all key-value pairs are done + defer(i) = .true. + else + visitor%inline_array = .true. + call ptr%get_key(key) + visitor%output = visitor%output // key // " =" + call ptr%accept(visitor) + visitor%inline_array = .false. + visitor%output = visitor%output // new_line('a') + end if + end if + class is(toml_table) + ! Subtables open a new section + ! -> cannot serialize them before all key-value pairs are done + defer(i) = .true. + end select + end do + + do i = 1, n + if (defer(i)) then + call table%get(list(i)%key, ptr) + select type(ptr) + class is(toml_keyval) + call ptr%accept(visitor) + if (visitor%inline_array) then + if (i /= n) visitor%output = visitor%output // "," + end if + class is(toml_array) + if (visitor%inline_array) then + call ptr%get_key(key) + visitor%output = visitor%output // " " // key // " =" + call ptr%accept(visitor) + if (i /= n) visitor%output = visitor%output // "," + else + if (is_array_of_tables(ptr)) then + call ptr%accept(visitor) + else + visitor%inline_array = .true. + call ptr%get_key(key) + visitor%output = visitor%output // key // " =" + call ptr%accept(visitor) + visitor%inline_array = .false. + visitor%output = visitor%output // new_line('a') + end if + end if + class is(toml_table) + if (size(visitor%stack, 1) <= visitor%top) call resize(visitor%stack) + visitor%top = visitor%top + 1 + call ptr%get_key(key) + visitor%stack(visitor%top)%key = key + call ptr%accept(visitor) + deallocate(visitor%stack(visitor%top)%key) + visitor%top = visitor%top - 1 + end select + end if + end do + + if (.not.visitor%inline_array .and. visitor%top == 0) then + deallocate(visitor%stack) + end if + +end subroutine visit_table + +!> Change size of the stack +subroutine resize(stack, n) + + !> Stack of keys to be resized + type(toml_key), allocatable, intent(inout) :: stack(:) + + !> New size of the stack + integer, intent(in), optional :: n + + type(toml_key), allocatable :: tmp(:) + integer :: m + + if (present(n)) then + m = n + else + if (allocated(stack)) then + m = size(stack) + m = m + m/2 + 1 + else + m = initial_size + end if + end if + + if (allocated(stack)) then + call move_alloc(stack, tmp) + allocate(stack(m)) + + m = min(size(tmp), m) + stack(:m) = tmp(:m) + + deallocate(tmp) + else + allocate(stack(m)) + end if + +end subroutine resize + +end module tomlf_ser + +!>>>>> build/dependencies/toml-f/src/tomlf/build/keyval.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Functions to build a TOML values +!> +!> The build module defines an interface to work with TOML values instead +!> of accessing the raw value directly. Both setter and getter routines defined +!> here are rarely needed in any user context, but serve as a basic building +!> block to define uniform access methods for TOML tables and arrays. +module tomlf_build_keyval + use tomlf_constants, only : tfc, tfi, tfr, tf_i1, tf_i2, tf_i4, tf_i8, & + & tf_sp, tf_dp, TOML_NEWLINE + use tomlf_datetime, only : toml_datetime + use tomlf_error, only : toml_stat + use tomlf_type, only : toml_value, toml_table, toml_array, toml_keyval, & + & new_table, new_array, new_keyval, add_table, add_array, add_keyval, len + use tomlf_utils, only : toml_escape_string, to_string + implicit none + private + + public :: get_value, set_value + + !> Setter functions to manipulate TOML values + interface set_value + module procedure :: set_value_float_sp + module procedure :: set_value_float_dp + module procedure :: set_value_integer_i1 + module procedure :: set_value_integer_i2 + module procedure :: set_value_integer_i4 + module procedure :: set_value_integer_i8 + module procedure :: set_value_bool + module procedure :: set_value_datetime + module procedure :: set_value_string + end interface set_value + + !> Getter functions to manipulate TOML values + interface get_value + module procedure :: get_value_float_sp + module procedure :: get_value_float_dp + module procedure :: get_value_integer_i1 + module procedure :: get_value_integer_i2 + module procedure :: get_value_integer_i4 + module procedure :: get_value_integer_i8 + module procedure :: get_value_bool + module procedure :: get_value_datetime + module procedure :: get_value_string + end interface get_value + + !> Length for the static character variables + integer, parameter :: buffersize = 128 + +contains + +!> Retrieve TOML value as single precision float (might lose accuracy) +subroutine get_value_float_sp(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Real value + real(tf_sp), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + real(tfr), pointer :: dummy + integer(tfi), pointer :: idummy + + call self%get(dummy) + if (associated(dummy)) then + val = real(dummy, tf_sp) + info = toml_stat%success + else + call self%get(idummy) + if (associated(idummy)) then + val = real(idummy, tf_sp) + if (nint(val, tfi) == idummy) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_float_sp + +!> Retrieve TOML value as double precision float +subroutine get_value_float_dp(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Real value + real(tf_dp), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + real(tfr), pointer :: dummy + integer(tfi), pointer :: idummy + + call self%get(dummy) + if (associated(dummy)) then + val = real(dummy, tf_dp) + info = toml_stat%success + else + call self%get(idummy) + if (associated(idummy)) then + val = real(idummy, tf_dp) + if (nint(val, tfi) == idummy) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_float_dp + +!> Retrieve TOML value as one byte integer (might loose precision) +subroutine get_value_integer_i1(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + integer(tfi), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = int(dummy, tf_i1) + if (dummy <= huge(val) .and. dummy >= -huge(val)-1) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_integer_i1 + +!> Retrieve TOML value as two byte integer (might loose precision) +subroutine get_value_integer_i2(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + integer(tfi), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = int(dummy, tf_i2) + if (dummy <= huge(val) .and. dummy >= -huge(val)-1) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_integer_i2 + +!> Retrieve TOML value as four byte integer (might loose precision) +subroutine get_value_integer_i4(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + integer(tfi), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = int(dummy, tf_i4) + if (dummy <= huge(val) .and. dummy >= -huge(val)-1) then + info = toml_stat%success + else + info = toml_stat%conversion_error + end if + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_integer_i4 + +!> Retrieve TOML value as eight byte integer +subroutine get_value_integer_i8(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + integer(tfi), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = int(dummy, tf_i8) + info = toml_stat%success + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_integer_i8 + +!> Retrieve TOML value as logical +subroutine get_value_bool(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Boolean value + logical, intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + logical, pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = dummy + info = toml_stat%success + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_bool + +!> Retrieve TOML value as datetime +subroutine get_value_datetime(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> Datetime value + type(toml_datetime), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + type(toml_datetime), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = dummy + info = toml_stat%success + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_datetime + +!> Retrieve TOML value as deferred-length character +subroutine get_value_string(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(in) :: self + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: info + character(:, tfc), pointer :: dummy + + call self%get(dummy) + if (associated(dummy)) then + val = dummy + info = toml_stat%success + else + info = toml_stat%type_mismatch + end if + + if (present(stat)) stat = info + if (present(origin)) origin = self%origin_value +end subroutine get_value_string + +!> Set TOML value to single precision float +subroutine set_value_float_sp(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Real value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(real(val, tfr)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_float_sp + +!> Set TOML value to double precision float +subroutine set_value_float_dp(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Real value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(real(val, tfr)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_float_dp + +!> Set TOML value to one byte integer +subroutine set_value_integer_i1(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(int(val, tfi)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_integer_i1 + +!> Set TOML value to two byte integer +subroutine set_value_integer_i2(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(int(val, tfi)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_integer_i2 + +!> Set TOML value to four byte integer +subroutine set_value_integer_i4(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(int(val, tfi)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_integer_i4 + +!> Set TOML value to eight byte integer +subroutine set_value_integer_i8(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(int(val, tfi)) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_integer_i8 + +!> Set TOML value to logical +subroutine set_value_bool(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(val) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_bool + +!> Set TOML value to datetime +subroutine set_value_datetime(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(val) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_datetime + +!> Set TOML value to deferred-length character +subroutine set_value_string(self, val, stat, origin) + + !> Instance of the key-value pair + class(toml_keyval), intent(inout) :: self + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call self%set(val) + if (present(stat)) stat = toml_stat%success + + self%origin_value = 0 + if (present(origin)) origin = self%origin +end subroutine set_value_string + +end module tomlf_build_keyval + +!>>>>> build/dependencies/toml-f/src/tomlf/build/merge.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Merge TOML data structures, the merge policy can be adjusted. +!> +!> Note that the context information cannot be preserved. +module tomlf_build_merge + use tomlf_constants, only : tfc + use tomlf_type, only : toml_table, toml_array, toml_keyval, toml_value, & + & toml_key, cast_to_keyval, len + implicit none + private + + public :: merge_table, merge_array, merge_policy, toml_merge_config + + !> Possible merge policies + type :: enum_policy + + !> Overwrite existing values + integer :: overwrite = 1 + + !> Preserve existing values + integer :: preserve = 2 + + !> Append to existing values + integer :: append = 3 + end type enum_policy + + !> Actual enumerator for merging data structures + type(enum_policy), parameter :: merge_policy = enum_policy() + + !> Configuration for merging data structures + type :: toml_merge_config + + !> Policy for merging tables + integer :: table = merge_policy%append + + !> Policy for merging arrays + integer :: array = merge_policy%preserve + + !> Policy for merging values + integer :: keyval = merge_policy%preserve + end type toml_merge_config + + !> Constructor for merge configuration + interface toml_merge_config + module procedure :: new_merge_config + end interface toml_merge_config + +contains + +!> Create a new merge configuration +pure function new_merge_config(table, array, keyval) result(config) + + !> Policy for merging tables + character(*), intent(in), optional :: table + + !> Policy for merging arrays + character(*), intent(in), optional :: array + + !> Policy for merging values + character(*), intent(in), optional :: keyval + + !> Merge policy + type(toml_merge_config) :: config + + if (present(table)) call set_enum(config%table, table) + if (present(array)) call set_enum(config%array, array) + if (present(keyval)) call set_enum(config%keyval, keyval) + +contains + + pure subroutine set_enum(enum, str) + character(*), intent(in) :: str + integer, intent(inout) :: enum + + select case(str) + case("append") + enum = merge_policy%append + case("overwrite") + enum = merge_policy%overwrite + case("preserve") + enum = merge_policy%preserve + end select + end subroutine set_enum + +end function new_merge_config + +!> Merge TOML tables by appending their values +recursive subroutine merge_table(lhs, rhs, config) + + !> Instance of table to merge into + class(toml_table), intent(inout) :: lhs + + !> Instance of table to be merged + class(toml_table), intent(inout) :: rhs + + !> Merge policy + type(toml_merge_config), intent(in), optional :: config + + type(toml_merge_config) :: policy + type(toml_key), allocatable :: list(:) + class(toml_value), pointer :: ptr1, ptr2 + class(toml_keyval), pointer :: kv + class(toml_value), allocatable :: tmp + logical :: has_key + integer :: i, n, stat + + policy = toml_merge_config() + if (present(config)) policy = config + + call rhs%get_keys(list) + n = size(list, 1) + + do i = 1, n + if (allocated(tmp)) deallocate(tmp) + call rhs%get(list(i)%key, ptr1) + has_key = lhs%has_key(list(i)%key) + select type(ptr1) + class is(toml_keyval) + if (has_key .and. policy%keyval == merge_policy%overwrite) then + call lhs%delete(list(i)%key) + has_key = .false. + end if + if (.not.has_key) then + allocate(tmp, source=ptr1) + kv => cast_to_keyval(tmp) + kv%origin_value = 0 + kv%origin = 0 + call lhs%push_back(tmp, stat) + end if + + class is(toml_array) + if (has_key .and. policy%array == merge_policy%overwrite) then + call lhs%delete(list(i)%key) + has_key = .false. + end if + if (has_key .and. policy%array == merge_policy%append) then + call lhs%get(list(i)%key, ptr2) + select type(ptr2) + class is(toml_array) + call merge_array(ptr2, ptr1) + end select + end if + if (.not.has_key) then + allocate(tmp, source=ptr1) + tmp%origin = 0 + call lhs%push_back(tmp, stat) + end if + + class is(toml_table) + if (has_key .and. policy%table == merge_policy%overwrite) then + call lhs%delete(list(i)%key) + has_key = .false. + end if + if (has_key .and. policy%table == merge_policy%append) then + call lhs%get(list(i)%key, ptr2) + select type(ptr2) + class is(toml_table) + call merge_table(ptr2, ptr1, policy) + end select + end if + if (.not.has_key) then + allocate(tmp, source=ptr1) + tmp%origin = 0 + call lhs%push_back(tmp, stat) + end if + end select + end do + +end subroutine merge_table + +!> Append values from one TOML array to another +recursive subroutine merge_array(lhs, rhs) + + !> Instance of array to merge into + class(toml_array), intent(inout) :: lhs + + !> Instance of array to be merged + class(toml_array), intent(inout) :: rhs + + class(toml_value), pointer :: ptr + class(toml_value), allocatable :: tmp + integer :: n, i, stat + + n = len(rhs) + + do i = 1, n + call rhs%get(i, ptr) + if (allocated(tmp)) deallocate(tmp) + allocate(tmp, source=ptr) + call lhs%push_back(tmp, stat) + end do + +end subroutine merge_array + +end module tomlf_build_merge + +!>>>>> build/dependencies/toml-f/src/tomlf/de/parser.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a parser for transforming a token stream to TOML datastructures. +module tomlf_de_parser + use tomlf_constants, only : tfc, tfr, tfi, TOML_NEWLINE + use tomlf_datetime, only : toml_datetime + use tomlf_de_context, only : toml_context + use tomlf_de_abc, only : toml_lexer => abstract_lexer + use tomlf_de_token, only : toml_token, token_kind, stringify + use tomlf_diagnostic, only : render, toml_diagnostic, toml_label, toml_level + use tomlf_terminal, only : toml_terminal + use tomlf_error, only : toml_error, toml_stat + use tomlf_type, only : toml_table, toml_array, toml_keyval, toml_value, toml_key, & + & add_table, add_array, add_keyval, cast_to_table, cast_to_array, len + implicit none + private + + public :: toml_parser, toml_parser_config, parse + + !> Configuration of the TOML parser + type :: toml_parser_config + !> Use colorful output for diagnostics + type(toml_terminal) :: color = toml_terminal() + !> Record all tokens + integer :: context_detail = 0 + end type toml_parser_config + + interface toml_parser_config + module procedure :: new_parser_config + end interface toml_parser_config + + !> TOML parser + type :: toml_parser + !> Current token + type(toml_token) :: token + !> Table containing the document root + type(toml_table), allocatable :: root + !> Pointer to the currently processed table + type(toml_table), pointer :: current + !> Diagnostic produced while parsing + type(toml_diagnostic), allocatable :: diagnostic + !> Context for producing diagnostics + type(toml_context) :: context + !> Configuration of the parser + type(toml_parser_config) :: config + end type toml_parser + +contains + +!> Create a new instance of the TOML parser +subroutine new_parser(parser, config) + !> Instance of the parser + type(toml_parser), intent(out), target :: parser + !> Configuration of the parser + type(toml_parser_config), intent(in), optional :: config + + parser%token = toml_token(token_kind%newline, 0, 0) + parser%root = toml_table() + parser%current => parser%root + parser%config = toml_parser_config() + if (present(config)) parser%config = config +end subroutine new_parser + +!> Create new configuration for the TOML parser +pure function new_parser_config(color, context_detail) result(config) + !> Configuration of the parser + type(toml_parser_config) :: config + !> Color support for diagnostics + logical, intent(in), optional :: color + !> Record all tokens + integer, intent(in), optional :: context_detail + + if (present(color)) config%color = toml_terminal(color) + if (present(context_detail)) config%context_detail = context_detail +end function new_parser_config + +!> Parse TOML document and return root table +subroutine parse(lexer, table, config, context, error) + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> TOML data structure + type(toml_table), allocatable, intent(out) :: table + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handler + type(toml_error), allocatable, intent(out), optional :: error + + type(toml_parser) :: parser + + call new_parser(parser, config) + call parse_root(parser, lexer) + + if (present(error) .and. allocated(parser%diagnostic)) then + call make_error(error, parser%diagnostic, lexer, parser%config%color) + end if + if (allocated(parser%diagnostic)) return + + call move_alloc(parser%root, table) + + if (present(context)) then + context = parser%context + call lexer%get_info("filename", context%filename) + call lexer%get_info("source", context%source) + end if +end subroutine parse + +!> Parse the root table +subroutine parse_root(parser, lexer) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + + do while(.not.allocated(parser%diagnostic) .and. parser%token%kind /= token_kind%eof) + select case(parser%token%kind) + case(token_kind%newline, token_kind%whitespace, token_kind%comment) + call next_token(parser, lexer) + + case(token_kind%keypath, token_kind%string, token_kind%literal) + call parse_keyval(parser, lexer, parser%current) + + case(token_kind%lbracket) + call parse_table_header(parser, lexer) + + case default + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid syntax", & + & "unexpected "//stringify(parser%token)) + end select + end do +end subroutine parse_root + +!> Parse a table or array of tables header +subroutine parse_table_header(parser, lexer) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + + type(toml_array), pointer :: array + type(toml_table), pointer :: table + class(toml_value), pointer :: ptr + type(toml_key) :: key + logical :: array_of_tables + + integer, parameter :: initial_size = 8 + integer :: top + type(toml_key), allocatable :: stack(:) + type(toml_token), allocatable :: leading_whitespace, trailing_whitespace + + call consume(parser, lexer, token_kind%lbracket) + if (allocated(parser%diagnostic)) return + + if (parser%token%kind == token_kind%whitespace) then + leading_whitespace = parser%token + call next_token(parser, lexer) + end if + + array_of_tables = parser%token%kind == token_kind%lbracket + + if (array_of_tables) then + call next_token(parser, lexer) + if (parser%token%kind == token_kind%whitespace) then + call next_token(parser, lexer) + end if + end if + + call fill_stack(lexer, parser, top, stack) + if (allocated(parser%diagnostic)) return + + key = stack(top) + top = top - 1 + + call walk_stack(parser, top, stack) + + if (array_of_tables) then + call parser%current%get(key%key, ptr) + if (associated(ptr)) then + array => cast_to_array(ptr) + if (.not.associated(array)) then + call duplicate_key_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(ptr%origin), & + & "Key '"//key%key//"' already exists") + return + end if + if (array%inline) then + call semantic_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(array%origin), & + & "Array of tables cannot extend inline array", & + & "extended here", & + & "defined as inline") + return + end if + else + call add_array(parser%current, key, array) + array%inline = .false. + end if + call add_table(array, table) + else + call parser%current%get(key%key, ptr) + if (associated(ptr)) then + table => cast_to_table(ptr) + if (associated(table)) then + if (.not.table%implicit) nullify(table) + end if + + if (.not.associated(table)) then + call duplicate_key_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(ptr%origin), & + & "Key '"//key%key//"' already exists") + return + end if + else + call add_table(parser%current, key, table) + end if + end if + + parser%current => table + + call consume(parser, lexer, token_kind%rbracket) + if (allocated(parser%diagnostic)) return + + if (array_of_tables) then + if (parser%token%kind == token_kind%whitespace) then + trailing_whitespace = parser%token + call next_token(parser, lexer) + end if + call consume(parser, lexer, token_kind%rbracket) + if (allocated(parser%diagnostic)) return + end if + + if (array_of_tables .and. allocated(leading_whitespace)) then + call syntax_error(parser%diagnostic, lexer, leading_whitespace, & + & "Malformatted array of table header encountered", & + & "whitespace not allowed in header") + return + end if + + if (array_of_tables .and. allocated(trailing_whitespace)) then + call syntax_error(parser%diagnostic, lexer, trailing_whitespace, & + & "Malformatted array of table header encountered", & + & "whitespace not allowed in header") + return + end if + + do while(parser%token%kind == token_kind%whitespace) + call next_token(parser, lexer) + end do + + if (parser%token%kind == token_kind%comment) then + call next_token(parser, lexer) + end if + + if (all(parser%token%kind /= [token_kind%newline, token_kind%eof])) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Unexpected "//stringify(parser%token)//" after table header", & + & "expected newline") + end if + +contains + + !> Fill the stack with tokens + subroutine fill_stack(lexer, parser, top, stack) + class(toml_lexer), intent(inout) :: lexer + type(toml_parser), intent(inout) :: parser + !> Depth of the table key stack + integer, intent(out) :: top + !> Stack of all keys in the table header + type(toml_key), allocatable, intent(out) :: stack(:) + + top = 0 + allocate(stack(initial_size)) + + do + if (top >= size(stack)) then + call resize(stack) + end if + + if (all(parser%token%kind /= [token_kind%string, token_kind%literal, & + & token_kind%keypath])) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Missing key for table header", & + & "unexpected "//stringify(parser%token)) + return + end if + + top = top + 1 + call extract_key(parser, lexer, stack(top)) + + call next_token(parser, lexer) + if (parser%token%kind == token_kind%whitespace) & + & call next_token(parser, lexer) + + if (parser%token%kind == token_kind%rbracket) exit + + call consume(parser, lexer, token_kind%dot) + if (allocated(parser%diagnostic)) return + if (parser%token%kind == token_kind%whitespace) & + & call next_token(parser, lexer) + end do + + if (top <= 0) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Empty table header", & + & "expected table header") + end if + + end subroutine fill_stack + + !> Walk the key stack to fetch the correct table, create implicit tables as necessary + subroutine walk_stack(parser, top, stack) + type(toml_parser), intent(inout), target :: parser + !> Depth of the table key stack + integer, intent(in) :: top + !> Stack of all keys in the table header + type(toml_key), intent(in), target :: stack(:) + + type(toml_table), pointer :: table, tmp_tbl + type(toml_array), pointer :: array + type(toml_key), pointer :: key + class(toml_value), pointer :: ptr + integer :: it + + table => parser%root + + do it = 1, top + key => stack(it) + + if (.not.table%has_key(key%key)) then + call add_table(table, key, tmp_tbl) + if (associated(tmp_tbl)) then + tmp_tbl%implicit = .true. + end if + end if + call table%get(key%key, ptr) + + table => cast_to_table(ptr) + if (.not.associated(table)) then + array => cast_to_array(ptr) + if (associated(array)) then + call array%get(len(array), ptr) + table => cast_to_table(ptr) + end if + if (.not.associated(table)) then + call duplicate_key_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(ptr%origin), & + & "Key '"//key%key//"' already exists") + return + end if + end if + + if (table%inline) then + call semantic_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(table%origin), & + & "Inline table '"//key%key//"' cannot be used as a key", & + & "inline table cannot be extended", & + & "defined as inline first") + end if + end do + + parser%current => table + end subroutine walk_stack + + !> Change size of the stack + subroutine resize(stack, n) + !> Stack of keys to be resized + type(toml_key), allocatable, intent(inout) :: stack(:) + !> New size of the stack + integer, intent(in), optional :: n + + type(toml_key), allocatable :: tmp(:) + integer :: m + + if (present(n)) then + m = n + else + if (allocated(stack)) then + m = size(stack) + m = m + m/2 + 1 + else + m = initial_size + end if + end if + + if (allocated(stack)) then + call move_alloc(stack, tmp) + allocate(stack(m)) + + m = min(size(tmp), m) + stack(:m) = tmp(:m) + + deallocate(tmp) + else + allocate(stack(m)) + end if + end subroutine resize + +end subroutine parse_table_header + +!> Parse key value pairs in a table body +recursive subroutine parse_keyval(parser, lexer, table) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current table + type(toml_table), intent(inout) :: table + + class(toml_value), pointer :: ptr + type(toml_keyval), pointer :: vptr + type(toml_array), pointer :: aptr + type(toml_table), pointer :: tptr + type(toml_key) :: key + + call extract_key(parser, lexer, key) + call next_token(parser, lexer) + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + if (parser%token%kind == token_kind%dot) then + call get_table(table, key, tptr) + if (tptr%inline) then + call semantic_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(tptr%origin), & + & "Cannot add keys to inline tables", & + & "inline table cannot be extended", & + & "defined as inline first") + return + end if + + call next_token(parser, lexer) + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + if (any(parser%token%kind == [token_kind%keypath, token_kind%string, & + & token_kind%literal])) then + call parse_keyval(parser, lexer, tptr) + else + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid syntax", & + & "expected key") + end if + return + end if + + call consume(parser, lexer, token_kind%equal) + if (allocated(parser%diagnostic)) return + + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + call table%get(key%key, ptr) + if (associated(ptr)) then + call duplicate_key_error(parser%diagnostic, lexer, & + & parser%context%token(key%origin), & + & parser%context%token(ptr%origin), & + & "Key '"//key%key//"' already exists") + return + end if + + select case(parser%token%kind) + case default + call add_keyval(table, key, vptr) + call parse_value(parser, lexer, vptr) + + case(token_kind%nil) + call next_token(parser, lexer) + + case(token_kind%lbracket) + call add_array(table, key, aptr) + call parse_inline_array(parser, lexer, aptr) + + case(token_kind%lbrace) + call add_table(table, key, tptr) + call parse_inline_table(parser, lexer, tptr) + + end select + if (allocated(parser%diagnostic)) return + + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + if (parser%token%kind == token_kind%comment) & + call next_token(parser, lexer) +end subroutine parse_keyval + +recursive subroutine parse_inline_array(parser, lexer, array) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current array + type(toml_array), intent(inout) :: array + + type(toml_keyval), pointer :: vptr + type(toml_array), pointer :: aptr + type(toml_table), pointer :: tptr + integer, parameter :: skip_tokens(*) = & + [token_kind%whitespace, token_kind%comment, token_kind%newline] + + array%inline = .true. + call consume(parser, lexer, token_kind%lbracket) + + inline_array: do while(.not.allocated(parser%diagnostic)) + do while(any(parser%token%kind == skip_tokens)) + call next_token(parser, lexer) + end do + + select case(parser%token%kind) + case(token_kind%rbracket) + exit inline_array + + case default + call add_keyval(array, vptr) + call parse_value(parser, lexer, vptr) + + case(token_kind%nil) + call next_token(parser, lexer) + + case(token_kind%lbracket) + call add_array(array, aptr) + call parse_inline_array(parser, lexer, aptr) + + case(token_kind%lbrace) + call add_table(array, tptr) + call parse_inline_table(parser, lexer, tptr) + + end select + if (allocated(parser%diagnostic)) exit inline_array + + do while(any(parser%token%kind == skip_tokens)) + call next_token(parser, lexer) + end do + + if (parser%token%kind == token_kind%comma) then + call next_token(parser, lexer) + cycle inline_array + end if + exit inline_array + end do inline_array + if (allocated(parser%diagnostic)) return + + call consume(parser, lexer, token_kind%rbracket) +end subroutine parse_inline_array + +recursive subroutine parse_inline_table(parser, lexer, table) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current table + type(toml_table), intent(inout) :: table + + table%inline = .true. + call consume(parser, lexer, token_kind%lbrace) + + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + if (parser%token%kind == token_kind%rbrace) then + call next_token(parser, lexer) + return + end if + + inline_table: do while(.not.allocated(parser%diagnostic)) + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + select case(parser%token%kind) + case default + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid character in inline table", & + & "unexpected "//stringify(parser%token)) + + case(token_kind%keypath, token_kind%string, token_kind%literal) + call parse_keyval(parser, lexer, table) + + end select + if (allocated(parser%diagnostic)) exit inline_table + + if (parser%token%kind == token_kind%whitespace) & + call next_token(parser, lexer) + + if (parser%token%kind == token_kind%comma) then + call next_token(parser, lexer) + cycle inline_table + end if + if (parser%token%kind == token_kind%rbrace) exit inline_table + end do inline_table + if (allocated(parser%diagnostic)) return + + call consume(parser, lexer, token_kind%rbrace) +end subroutine parse_inline_table + +subroutine parse_value(parser, lexer, kval) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Current key value pair + type(toml_keyval), intent(inout) :: kval + + select case(parser%token%kind) + case default + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid expression for value", & + & "unexpected "//stringify(parser%token)) + + case(token_kind%unclosed) + ! Handle runaway expressions separately + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Inline expression contains unclosed or runaway group", & + & "unclosed inline expression") + + case(token_kind%string, token_kind%mstring, token_kind%literal, token_kind%mliteral, & + & token_kind%int, token_kind%float, token_kind%bool, token_kind%datetime) + call extract_value(parser, lexer, kval) + + call next_token(parser, lexer) + end select +end subroutine parse_value + +!> Check whether the current token is the expected one and advance the lexer +subroutine consume(parser, lexer, kind) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Expected token kind + integer, intent(in) :: kind + + if (parser%token%kind /= kind) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid syntax in this context", & + & "expected "//stringify(toml_token(kind))) + return + end if + + call next_token(parser, lexer) +end subroutine consume + +!> Create diagnostic for invalid syntax +subroutine syntax_error(diagnostic, lexer, token, message, label) + !> Diagnostic for the syntax error + type(toml_diagnostic), allocatable, intent(out) :: diagnostic + !> Instance of the lexer providing the context + class(toml_lexer), intent(inout) :: lexer + !> Token that caused the error + type(toml_token), intent(in) :: token + !> Message for the error + character(len=*), intent(in) :: message + !> Label for the token + character(len=*), intent(in) :: label + + character(:, tfc), allocatable :: filename + + call lexer%get_info("filename", filename) + + allocate(diagnostic) + diagnostic = toml_diagnostic( & + & toml_level%error, & + & message, & + & filename, & + & [toml_label(toml_level%error, token%first, token%last, label, .true.)]) +end subroutine syntax_error + +!> Create diagnostic for incorrect semantics +subroutine semantic_error(diagnostic, lexer, token1, token2, message, label1, label2) + !> Diagnostic for the duplicate key error + type(toml_diagnostic), allocatable, intent(out) :: diagnostic + !> Instance of the lexer providing the context + class(toml_lexer), intent(inout) :: lexer + !> Token identifying the duplicate key + type(toml_token), intent(in) :: token1 + !> Token identifying the original key + type(toml_token), intent(in) :: token2 + !> Message for the error + character(len=*), intent(in) :: message + !> Label for the first token + character(len=*), intent(in) :: label1 + !> Label for the second token + character(len=*), intent(in) :: label2 + + character(:, tfc), allocatable :: filename + + call lexer%get_info("filename", filename) + + allocate(diagnostic) + diagnostic = toml_diagnostic( & + & toml_level%error, & + & message, & + & filename, & + & [toml_label(toml_level%error, token1%first, token1%last, label1, .true.), & + & toml_label(toml_level%info, token2%first, token2%last, label2, .false.)]) +end subroutine semantic_error + +!> Create a diagnostic for a duplicate key entry +subroutine duplicate_key_error(diagnostic, lexer, token1, token2, message) + !> Diagnostic for the duplicate key error + type(toml_diagnostic), allocatable, intent(out) :: diagnostic + !> Instance of the lexer providing the context + class(toml_lexer), intent(inout) :: lexer + !> Token identifying the duplicate key + type(toml_token), intent(in) :: token1 + !> Token identifying the original key + type(toml_token), intent(in) :: token2 + !> Message for the error + character(len=*), intent(in) :: message + + call semantic_error(diagnostic, lexer, token1, token2, & + & message, "key already used", "first defined here") +end subroutine duplicate_key_error + +!> Create an error from a diagnostic +subroutine make_error(error, diagnostic, lexer, color) + !> Error to be created + type(toml_error), allocatable, intent(out) :: error + !> Diagnostic to be used + type(toml_diagnostic), intent(in) :: diagnostic + !> Instance of the lexer providing the context + class(toml_lexer), intent(in) :: lexer + !> Use colorful error messages + type(toml_terminal), intent(in) :: color + + character(len=:), allocatable :: str + + allocate(error) + call lexer%get_info("source", str) + error%message = render(diagnostic, str, color) + error%stat = toml_stat%fatal +end subroutine make_error + +!> Wrapper around the lexer to retrieve the next token. +!> Allows to record the tokens for keys and values in the parser context +subroutine next_token(parser, lexer) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + + call lexer%next(parser%token) + + select case(parser%token%kind) + case(token_kind%keypath, token_kind%string, token_kind%literal, token_kind%int, & + & token_kind%float, token_kind%bool, token_kind%datetime) + call parser%context%push_back(parser%token) + case(token_kind%newline, token_kind%dot, token_kind%comma, token_kind%equal, & + & token_kind%lbrace, token_kind%rbrace, token_kind%lbracket, token_kind%rbracket) + if (parser%config%context_detail > 0) & + call parser%context%push_back(parser%token) + case default + if (parser%config%context_detail > 1) & + call parser%context%push_back(parser%token) + end select +end subroutine next_token + +!> Extract key from token +subroutine extract_key(parser, lexer, key) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Key to be extracted + type(toml_key), intent(out) :: key + + call lexer%extract(parser%token, key%key) + key%origin = parser%context%top + if (scan(key%key, TOML_NEWLINE) > 0) then + call syntax_error(parser%diagnostic, lexer, parser%token, & + & "Invalid character in key", & + & "key cannot contain newline") + return + end if +end subroutine extract_key + +!> Extract value from token +subroutine extract_value(parser, lexer, kval) + !> Instance of the parser + class(toml_parser), intent(inout) :: parser + !> Instance of the lexer + class(toml_lexer), intent(inout) :: lexer + !> Value to be extracted + type(toml_keyval), intent(inout) :: kval + + character(:, tfc), allocatable :: sval + real(tfr) :: rval + integer(tfi) :: ival + logical :: bval + type(toml_datetime) :: dval + + kval%origin_value = parser%context%top + + select case(parser%token%kind) + case(token_kind%string, token_kind%literal, token_kind%mstring, token_kind%mliteral) + call lexer%extract_string(parser%token, sval) + call kval%set(sval) + + case(token_kind%int) + call lexer%extract_integer(parser%token, ival) + call kval%set(ival) + + case(token_kind%float) + call lexer%extract_float(parser%token, rval) + call kval%set(rval) + + case(token_kind%bool) + call lexer%extract_bool(parser%token, bval) + call kval%set(bval) + + case(token_kind%datetime) + call lexer%extract_datetime(parser%token, dval) + call kval%set(dval) + end select +end subroutine extract_value + +!> Try to retrieve TOML table with key or create it +subroutine get_table(table, key, ptr, stat) + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + !> Key for the new table + type(toml_key), intent(in) :: key + !> Pointer to the newly created table + type(toml_table), pointer, intent(out) :: ptr + !> Status of operation + integer, intent(out), optional :: stat + + class(toml_value), pointer :: tmp + + nullify(ptr) + call table%get(key%key, tmp) + + if (associated(tmp)) then + ptr => cast_to_table(tmp) + if (present(stat)) stat = merge(toml_stat%success, toml_stat%fatal, associated(ptr)) + else + call add_table(table, key, ptr, stat) + end if +end subroutine get_table + +end module tomlf_de_parser + +!>>>>> build/dependencies/jonquil/src/jonquil/ser.f90 + +! This file is part of jonquil. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Implementation of a serializer for TOML values to JSON. +module jonquil_ser + use tomlf_constants + use tomlf_datetime + use tomlf_type, only : toml_value, toml_visitor, toml_key, toml_table, & + & toml_array, toml_keyval, is_array_of_tables, len + use tomlf_error, only : toml_error, toml_stat, make_error + use tomlf_utils, only : to_string + implicit none + private + + public :: json_serializer, json_ser_config + public :: json_dumps, json_dump, json_serialize + + interface json_dumps + module procedure :: json_dump_to_string + end interface json_dumps + + interface json_dump + module procedure :: json_dump_to_file + module procedure :: json_dump_to_unit + end interface json_dump + + !> Configuration for JSON serializer + type :: json_ser_config + + !> Write literal NaN + logical :: literal_nan = .false. + + !> Write literal Inf + logical :: literal_inf = .false. + + !> Write literal datetime + logical :: literal_datetime = .false. + + !> Indentation + character(len=:), allocatable :: indent + + end type json_ser_config + + !> Serializer to produduce a JSON document from a TOML datastructure + type, extends(toml_visitor) :: json_serializer + + !> Output string + character(len=:), allocatable :: output + + !> Configuration for serializer + type(json_ser_config) :: config = json_ser_config() + + !> Current depth in the tree + integer :: depth = 0 + + contains + + !> Visit a TOML value + procedure :: visit + + end type json_serializer + +contains + +!> Serialize a JSON value to a string and return it. +!> +!> In case of an error this function will invoke an error stop. +function json_serialize(val, config) result(string) + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> Configuration for serializer + type(json_ser_config), intent(in), optional :: config + + !> Serialized JSON value + character(len=:), allocatable :: string + + type(toml_error), allocatable :: error + + call json_dumps(val, string, error, config=config) + if (allocated(error)) then + error stop error%message + end if +end function json_serialize + +!> Create a string representing the JSON value +subroutine json_dump_to_string(val, string, error, config) + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> Formatted unit to write to + character(:), allocatable, intent(out) :: string + + !> Error handling + type(toml_error), allocatable, intent(out) :: error + + !> Configuration for serializer + type(json_ser_config), intent(in), optional :: config + + type(json_serializer) :: ser + + ser = json_serializer() + if (present(config)) ser%config = config + call val%accept(ser) + string = ser%output +end subroutine json_dump_to_string + +!> Write string representation of JSON value to a connected formatted unit +subroutine json_dump_to_unit(val, io, error, config) + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> Formatted unit to write to + integer, intent(in) :: io + + !> Error handling + type(toml_error), allocatable, intent(out) :: error + + !> Configuration for serializer + type(json_ser_config), intent(in), optional :: config + + character(len=:), allocatable :: string + character(512) :: msg + integer :: stat + + call json_dumps(val, string, error, config=config) + if (allocated(error)) return + write(io, '(a)', iostat=stat, iomsg=msg) string + if (stat /= 0) then + call make_error(error, trim(msg)) + return + end if +end subroutine json_dump_to_unit + +!> Write string representation of JSON value to a file +subroutine json_dump_to_file(val, filename, error, config) + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + !> File name to write to + character(*), intent(in) :: filename + + !> Error handling + type(toml_error), allocatable, intent(out) :: error + + !> Configuration for serializer + type(json_ser_config), intent(in), optional :: config + + integer :: io + integer :: stat + character(512) :: msg + + open(file=filename, newunit=io, iostat=stat, iomsg=msg) + if (stat /= 0) then + call make_error(error, trim(msg)) + return + end if + call json_dump(val, io, error, config=config) + close(unit=io, iostat=stat, iomsg=msg) + if (.not.allocated(error) .and. stat /= 0) then + call make_error(error, trim(msg)) + end if +end subroutine json_dump_to_file + +!> Visit a TOML value +subroutine visit(self, val) + + !> Instance of the JSON serializer + class(json_serializer), intent(inout) :: self + + !> TOML value to visit + class(toml_value), intent(inout) :: val + + if (.not.allocated(self%output)) self%output = "" + + select type(val) + class is(toml_keyval) + call visit_keyval(self, val) + class is(toml_array) + call visit_array(self, val) + class is(toml_table) + call visit_table(self, val) + end select + +end subroutine visit + +!> Visit a TOML key-value pair +subroutine visit_keyval(visitor, keyval) + + !> Instance of the JSON serializer + class(json_serializer), intent(inout) :: visitor + + !> TOML value to visit + type(toml_keyval), intent(inout) :: keyval + + character(kind=tfc, len=:), allocatable :: str, key + character(kind=tfc, len=:), pointer :: sdummy + type(toml_datetime), pointer :: ts + integer(tfi), pointer :: idummy + real(tfr), pointer :: fdummy + logical, pointer :: ldummy + + call indent(visitor) + + if (allocated(keyval%key)) then + call escape_string(keyval%key, key) + visitor%output = visitor%output // """" // key // """: " + end if + + select case(keyval%get_type()) + case default + visitor%output = visitor%output // "null" + + case(toml_type%string) + call keyval%get(sdummy) + call escape_string(sdummy, str) + visitor%output = visitor%output // """" // str // """" + + case(toml_type%boolean) + call keyval%get(ldummy) + if (ldummy) then + visitor%output = visitor%output // "true" + else + visitor%output = visitor%output // "false" + end if + + case(toml_type%int) + call keyval%get(idummy) + visitor%output = visitor%output // to_string(idummy) + + case(toml_type%float) + call keyval%get(fdummy) + if (fdummy > huge(fdummy)) then + if (visitor%config%literal_inf) then + visitor%output = visitor%output // "+inf" + else + visitor%output = visitor%output // """+inf""" + end if + else if (fdummy < -huge(fdummy)) then + if (visitor%config%literal_inf) then + visitor%output = visitor%output // "-inf" + else + visitor%output = visitor%output // """-inf""" + end if + else if (fdummy /= fdummy) then + if (visitor%config%literal_nan) then + visitor%output = visitor%output // "nan" + else + visitor%output = visitor%output // """nan""" + end if + else + visitor%output = visitor%output // to_string(fdummy) + end if + + case(toml_type%datetime) + call keyval%get(ts) + if (visitor%config%literal_datetime) then + visitor%output = visitor%output // to_string(ts) + else + visitor%output = visitor%output // """" // to_string(ts) // """" + end if + + end select + +end subroutine visit_keyval + +!> Visit a TOML array +subroutine visit_array(visitor, array) + + !> Instance of the JSON serializer + class(json_serializer), intent(inout) :: visitor + + !> TOML value to visit + type(toml_array), intent(inout) :: array + + class(toml_value), pointer :: ptr + character(kind=tfc, len=:), allocatable :: key + integer :: i, n + + call indent(visitor) + + if (allocated(array%key)) then + call escape_string(array%key, key) + visitor%output = visitor%output // """" // key // """: " + end if + + visitor%output = visitor%output // "[" + visitor%depth = visitor%depth + 1 + n = len(array) + do i = 1, n + call array%get(i, ptr) + call ptr%accept(visitor) + if (i /= n) visitor%output = visitor%output // "," + end do + visitor%depth = visitor%depth - 1 + call indent(visitor) + visitor%output = visitor%output // "]" + +end subroutine visit_array + +!> Visit a TOML table +subroutine visit_table(visitor, table) + + !> Instance of the JSON serializer + class(json_serializer), intent(inout) :: visitor + + !> TOML table to visit + type(toml_table), intent(inout) :: table + + class(toml_value), pointer :: ptr + type(toml_key), allocatable :: list(:) + character(kind=tfc, len=:), allocatable :: key + integer :: i, n + + call indent(visitor) + + if (allocated(table%key)) then + call escape_string(table%key, key) + visitor%output = visitor%output // """" // key // """: " + end if + + visitor%output = visitor%output // "{" + visitor%depth = visitor%depth + 1 + + call table%get_keys(list) + + n = size(list, 1) + do i = 1, n + call table%get(list(i)%key, ptr) + call ptr%accept(visitor) + if (i /= n) visitor%output = visitor%output // "," + end do + + visitor%depth = visitor%depth - 1 + call indent(visitor) + if (visitor%depth == 0) then + if (allocated(visitor%config%indent)) visitor%output = visitor%output // new_line('a') + visitor%output = visitor%output // "}" // new_line('a') + else + visitor%output = visitor%output // "}" + endif + +end subroutine visit_table + +!> Produce indentations for emitted JSON documents +subroutine indent(self) + + !> Instance of the JSON serializer + class(json_serializer), intent(inout) :: self + + integer :: i + + ! PGI internal compiler error in NVHPC 20.7 and 20.9 with + ! write(self%unit, '(/, a)', advance='no') repeat(self%config%indent, self%depth) + ! causes: NVFORTRAN-F-0000-Internal compiler error. Errors in Lowering 16 + if (allocated(self%config%indent) .and. self%depth > 0) then + self%output = self%output // new_line('a') // repeat(self%config%indent, self%depth) + end if + +end subroutine indent + +!> Transform a TOML raw value to a JSON compatible escaped string +subroutine escape_string(raw, escaped) + + !> Raw value of TOML value + character(len=*), intent(in) :: raw + + !> JSON compatible escaped string + character(len=:), allocatable, intent(out) :: escaped + + integer :: i + + escaped = '' + do i = 1, len(raw) + select case(raw(i:i)) + case default; escaped = escaped // raw(i:i) + case('\'); escaped = escaped // '\\' + case('"'); escaped = escaped // '\"' + case(TOML_NEWLINE); escaped = escaped // '\n' + case(TOML_FORMFEED); escaped = escaped // '\f' + case(TOML_CARRIAGE_RETURN); escaped = escaped // '\r' + case(TOML_TABULATOR); escaped = escaped // '\t' + case(TOML_BACKSPACE); escaped = escaped // '\b' + end select + end do + +end subroutine escape_string + +end module jonquil_ser + +!>>>>> build/dependencies/toml-f/src/tomlf/de.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Proxy module for providing loading and deserialization of TOML data structures +module tomlf_de + use tomlf_constants, only : tfc, TOML_NEWLINE + use tomlf_de_context, only : toml_context + use tomlf_de_lexer, only : toml_lexer, new_lexer_from_string, new_lexer_from_unit, & + & new_lexer_from_file + use tomlf_de_parser, only : parse, toml_parser_config + use tomlf_diagnostic, only : toml_level + use tomlf_error, only : toml_error + use tomlf_type, only : toml_table + implicit none + private + + public :: toml_parse + public :: toml_load, toml_loads + public :: toml_context, toml_parser_config, toml_level + + !> Parse a TOML document. + !> + !> This interface is deprecated in favor of [[toml_load]] and [[toml_loads]] + interface toml_parse + module procedure :: toml_parse_unit + module procedure :: toml_parse_string + end interface toml_parse + + !> Load a TOML data structure from the provided source + interface toml_load + module procedure :: toml_load_file + module procedure :: toml_load_unit + end interface toml_load + + !> Load a TOML data structure from a string + interface toml_loads + module procedure :: toml_load_string + end interface toml_loads + +contains + +!> Parse a TOML input from a given IO unit. +!> +!> @note This procedure is deprectated +subroutine toml_parse_unit(table, unit, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + !> Unit to read from + integer, intent(in) :: unit + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + call toml_load(table, unit, error=error) +end subroutine toml_parse_unit + +!> Wrapper to parse a TOML string. +!> +!> @note This procedure is deprectated +subroutine toml_parse_string(table, string, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + !> String containing TOML document + character(len=*), intent(in), target :: string + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + call toml_loads(table, string, error=error) +end subroutine toml_parse_string + +!> Load TOML data structure from file +subroutine toml_load_file(table, filename, config, context, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + character(*, tfc), intent(in) :: filename + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + type(toml_lexer) :: lexer + type(toml_error), allocatable :: error_ + + call new_lexer_from_file(lexer, filename, error_) + if (.not.allocated(error_)) then + call parse(lexer, table, config, context, error) + else + if (present(error)) call move_alloc(error_, error) + end if +end subroutine toml_load_file + +!> Load TOML data structure from unit +subroutine toml_load_unit(table, io, config, context, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + !> Unit to read from + integer, intent(in) :: io + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + type(toml_lexer) :: lexer + type(toml_error), allocatable :: error_ + + call new_lexer_from_unit(lexer, io, error_) + if (.not.allocated(error_)) then + call parse(lexer, table, config, context, error) + else + if (present(error)) call move_alloc(error_, error) + end if +end subroutine toml_load_unit + +!> Load TOML data structure from string +subroutine toml_load_string(table, string, config, context, error) + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(out) :: table + !> String containing TOML document + character(*, tfc), intent(in) :: string + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + type(toml_lexer) :: lexer + + call new_lexer_from_string(lexer, string) + call parse(lexer, table, config, context, error) +end subroutine toml_load_string + +end module tomlf_de + +!>>>>> build/dependencies/toml-f/src/tomlf/build/array.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Functions to build TOML arrays. +!> +!> This build module defines a high level interface to work with TOML arrays +!> and construct them in a convenient way. +!> +!> The access to the array elements happens by position in the array, the indexing +!> is one based, following the language convention of Fortran. All functions +!> will only allow access of elements within the bounds of the array, specifying +!> indices out-of-bounds should be save, as it only sets the status of operation. +!> The getter functions allow access to other tables and arrays as well as +!> convenient wrappers to retrieve value data +!> +!> The setter functions are somewhat weaker compared to the setter functions +!> available for TOML tables. To limit the potential havoc this routines can +!> cause they can only access the array within its bounds. Setting a value to +!> another value will overwrite it, while setting a value to a table or an array +!> will fail, for safety reasons. +!> +!> To (re)build an array appending to it is the best choice, tables and arrays +!> should always be create by using the corresponding `add_table` and `add_array` +!> function. While this can become cumbersome for values, the setter routines +!> allow out-of-bound access to for the next element in an array and will indeed +!> just append a new value to it. +module tomlf_build_array + use tomlf_build_keyval, only : get_value, set_value + use tomlf_constants, only : tfc, tfi, tfr, tf_i1, tf_i2, tf_i4, tf_i8, & + & tf_sp, tf_dp + use tomlf_datetime, only : toml_datetime + use tomlf_error, only : toml_stat + use tomlf_type, only : toml_value, toml_table, toml_array, toml_keyval, & + & new_table, new_array, new_keyval, add_table, add_array, add_keyval, & + & cast_to_table, cast_to_array, cast_to_keyval, initialized, len + implicit none + private + + public :: get_value, set_value + + !> Setter functions to manipulate TOML arrays + interface set_value + module procedure :: set_elem_value_string + module procedure :: set_elem_value_float_sp + module procedure :: set_elem_value_float_dp + module procedure :: set_elem_value_int_i1 + module procedure :: set_elem_value_int_i2 + module procedure :: set_elem_value_int_i4 + module procedure :: set_elem_value_int_i8 + module procedure :: set_elem_value_bool + module procedure :: set_elem_value_datetime + module procedure :: set_array_value_float_sp + module procedure :: set_array_value_float_dp + module procedure :: set_array_value_int_i1 + module procedure :: set_array_value_int_i2 + module procedure :: set_array_value_int_i4 + module procedure :: set_array_value_int_i8 + module procedure :: set_array_value_bool + module procedure :: set_array_value_datetime + end interface set_value + + !> Getter functions to manipulate TOML arrays + interface get_value + module procedure :: get_elem_table + module procedure :: get_elem_array + module procedure :: get_elem_keyval + module procedure :: get_elem_value_string + module procedure :: get_elem_value_float_sp + module procedure :: get_elem_value_float_dp + module procedure :: get_elem_value_int_i1 + module procedure :: get_elem_value_int_i2 + module procedure :: get_elem_value_int_i4 + module procedure :: get_elem_value_int_i8 + module procedure :: get_elem_value_bool + module procedure :: get_elem_value_datetime + module procedure :: get_array_value_float_sp + module procedure :: get_array_value_float_dp + module procedure :: get_array_value_int_i1 + module procedure :: get_array_value_int_i2 + module procedure :: get_array_value_int_i4 + module procedure :: get_array_value_int_i8 + module procedure :: get_array_value_bool + module procedure :: get_array_value_datetime + end interface get_value + +contains + +subroutine get_elem_table(array, pos, ptr, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + + if (.not.initialized(array)) call new_array(array) + + nullify(ptr) + + call array%get(pos, tmp) + + if (associated(tmp)) then + ptr => cast_to_table(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = array%origin + end if + +end subroutine get_elem_table + +subroutine get_elem_array(array, pos, ptr, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Pointer to child array + type(toml_array), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + + if (.not.initialized(array)) call new_array(array) + + nullify(ptr) + + call array%get(pos, tmp) + + if (associated(tmp)) then + ptr => cast_to_array(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = array%origin + end if + +end subroutine get_elem_array + +subroutine get_elem_keyval(array, pos, ptr, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Pointer to child value + type(toml_keyval), pointer, intent(out) :: ptr + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + + if (.not.initialized(array)) call new_array(array) + + nullify(ptr) + + call array%get(pos, tmp) + + if (associated(tmp)) then + ptr => cast_to_keyval(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = array%origin + end if + +end subroutine get_elem_keyval + +!> Retrieve TOML value as deferred-length character +subroutine get_elem_value_string(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_string + +!> Retrieve TOML value as single precision floating point number +subroutine get_elem_value_float_sp(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Floating point value + real(tf_sp), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_float_sp + +!> Retrieve TOML value as double precision floating point number +subroutine get_elem_value_float_dp(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Floating point value + real(tf_dp), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_float_dp + +!> Retrieve TOML value as integer value +subroutine get_elem_value_int_i1(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_int_i1 + +!> Retrieve TOML value as integer value +subroutine get_elem_value_int_i2(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_int_i2 + +!> Retrieve TOML value as integer value +subroutine get_elem_value_int_i4(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_int_i4 + +!> Retrieve TOML value as integer value +subroutine get_elem_value_int_i8(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_int_i8 + +!> Retrieve TOML value as boolean +subroutine get_elem_value_bool(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + logical, intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_bool + +!> Retrieve TOML value as datetime +subroutine get_elem_value_datetime(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + type(toml_datetime), intent(out) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (associated(ptr)) then + call get_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine get_elem_value_datetime + +!> Retrieve TOML value as deferred-length character +subroutine set_elem_value_string(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_string + +!> Retrieve TOML value as single precision floating point number +subroutine set_elem_value_float_sp(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Floating point value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_float_sp + +!> Retrieve TOML value as double precision floating point number +subroutine set_elem_value_float_dp(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Floating point value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_float_dp + +!> Retrieve TOML value as integer value +subroutine set_elem_value_int_i1(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_int_i1 + +!> Retrieve TOML value as integer value +subroutine set_elem_value_int_i2(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_int_i2 + +!> Retrieve TOML value as integer value +subroutine set_elem_value_int_i4(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_int_i4 + +!> Retrieve TOML value as integer value +subroutine set_elem_value_int_i8(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_int_i8 + +!> Retrieve TOML value as boolean value +subroutine set_elem_value_bool(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_bool + +!> Retrieve TOML value as datetime value +subroutine set_elem_value_datetime(array, pos, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Position in the array + integer, intent(in) :: pos + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(array, pos, ptr, stat, origin) + + if (.not.associated(ptr)) then + if (pos == len(array) + 1) then + call add_keyval(array, ptr, stat) + end if + end if + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) stat = toml_stat%fatal + end if + +end subroutine set_elem_value_datetime + +!> Retrieve TOML value as single precision floating point number +subroutine get_array_value_float_sp(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Floating point value + real(tf_sp), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_float_sp + +!> Retrieve TOML value as double precision floating point number +subroutine get_array_value_float_dp(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Floating point value + real(tf_dp), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_float_dp + +!> Retrieve TOML value as integer value +subroutine get_array_value_int_i1(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i1), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_int_i1 + +!> Retrieve TOML value as integer value +subroutine get_array_value_int_i2(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i2), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_int_i2 + +!> Retrieve TOML value as integer value +subroutine get_array_value_int_i4(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i4), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_int_i4 + +!> Retrieve TOML value as integer value +subroutine get_array_value_int_i8(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i8), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_int_i8 + +!> Retrieve TOML value as boolean +subroutine get_array_value_bool(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + logical, allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_bool + +!> Retrieve TOML value as datetime +subroutine get_array_value_datetime(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + type(toml_datetime), allocatable, intent(out) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it, info + + info = 0 + allocate(val(len(array))) + do it = 1, size(val) + call get_value(array, it, val(it), info, origin) + if (info /= 0) exit + end do + if (info /= 0) deallocate(val) + if (present(stat)) stat = info + if (present(origin) .and. info == 0) origin = array%origin + +end subroutine get_array_value_datetime + +!> Retrieve TOML value as single precision floating point number +subroutine set_array_value_float_sp(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Floating point value + real(tf_sp), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_float_sp + +!> Retrieve TOML value as double precision floating point number +subroutine set_array_value_float_dp(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Floating point value + real(tf_dp), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_float_dp + +!> Retrieve TOML value as integer value +subroutine set_array_value_int_i1(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i1), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_int_i1 + +!> Retrieve TOML value as integer value +subroutine set_array_value_int_i2(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i2), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_int_i2 + +!> Retrieve TOML value as integer value +subroutine set_array_value_int_i4(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i4), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_int_i4 + +!> Retrieve TOML value as integer value +subroutine set_array_value_int_i8(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Integer value + integer(tf_i8), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_int_i8 + +!> Retrieve TOML value as boolean value +subroutine set_array_value_bool(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Boolean value + logical, intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_bool + +!> Retrieve TOML value as datetime value +subroutine set_array_value_datetime(array, val, stat, origin) + + !> Instance of the TOML array + class(toml_array), intent(inout) :: array + + !> Datetime value + type(toml_datetime), intent(in) :: val(:) + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + class(toml_value), allocatable :: ptr + + do while(len(array) > size(val)) + call array%pop(ptr) + end do + + do it = 1, size(val) + call set_value(array, it, val(it), stat, origin) + end do + if (present(origin)) origin = array%origin + +end subroutine set_array_value_datetime + +end module tomlf_build_array + +!>>>>> build/dependencies/toml-f/src/tomlf/build/table.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Functions to build TOML tables +!> +!> The build module defines a high level interface to work with TOML tables +!> and construct them in a convenient way. +!> +!> The getter functions allow to both retrieve and set values, to easily +!> support default values when reading from a TOML data structure. +!> Using the getter function with a default value specified will request +!> the respective setter function to add it to the table if it was not +!> found in the first place. +!> +!> This allows to build a TOML table using only the getter functions, which +!> represents the finally read values for the applications. +!> +!> Note that neither setter nor getter functions can overwrite existing +!> TOML values for safety reasons, request the deletion on the respective +!> key from the TOML table and than set it. The deletion of a subtable or +!> array will recursively destroy the contained data nodes. +module tomlf_build_table + use tomlf_build_keyval, only : get_value, set_value + use tomlf_constants, only : tfc, tfi, tfr, tf_i1, tf_i2, tf_i4, tf_i8, & + & tf_sp, tf_dp + use tomlf_datetime, only : toml_datetime + use tomlf_error, only : toml_stat + use tomlf_type, only : toml_value, toml_table, toml_array, toml_keyval, & + & new_table, new_array, new_keyval, add_table, add_array, add_keyval, & + & toml_key, cast_to_table, cast_to_array, cast_to_keyval, initialized, & + & len + implicit none + private + + public :: get_value, set_value + + !> Setter functions to manipulate TOML tables + interface set_value + module procedure :: set_child_value_float_sp + module procedure :: set_child_value_float_dp + module procedure :: set_child_value_integer_i1 + module procedure :: set_child_value_integer_i2 + module procedure :: set_child_value_integer_i4 + module procedure :: set_child_value_integer_i8 + module procedure :: set_child_value_bool + module procedure :: set_child_value_datetime + module procedure :: set_child_value_string + module procedure :: set_key_value_float_sp + module procedure :: set_key_value_float_dp + module procedure :: set_key_value_integer_i1 + module procedure :: set_key_value_integer_i2 + module procedure :: set_key_value_integer_i4 + module procedure :: set_key_value_integer_i8 + module procedure :: set_key_value_bool + module procedure :: set_key_value_datetime + module procedure :: set_key_value_string + end interface set_value + + !> Getter functions to manipulate TOML tables + interface get_value + module procedure :: get_child_table + module procedure :: get_child_array + module procedure :: get_child_keyval + module procedure :: get_child_value_float_sp + module procedure :: get_child_value_float_dp + module procedure :: get_child_value_integer_i1 + module procedure :: get_child_value_integer_i2 + module procedure :: get_child_value_integer_i4 + module procedure :: get_child_value_integer_i8 + module procedure :: get_child_value_bool + module procedure :: get_child_value_datetime + module procedure :: get_child_value_string + module procedure :: get_key_table + module procedure :: get_key_array + module procedure :: get_key_keyval + module procedure :: get_key_value_float_sp + module procedure :: get_key_value_float_dp + module procedure :: get_key_value_integer_i1 + module procedure :: get_key_value_integer_i2 + module procedure :: get_key_value_integer_i4 + module procedure :: get_key_value_integer_i8 + module procedure :: get_key_value_bool + module procedure :: get_key_value_datetime + module procedure :: get_key_value_string + end interface get_value + +contains + +subroutine get_key_table(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, ptr, requested, stat, origin) + +end subroutine get_key_table + +subroutine get_key_array(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Pointer to child array + type(toml_array), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, ptr, requested, stat, origin) + +end subroutine get_key_array + +subroutine get_key_keyval(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Pointer to child value + type(toml_keyval), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, ptr, requested, stat, origin) + +end subroutine get_key_keyval + +!> Retrieve TOML value as single precision float (might lose accuracy) +subroutine get_key_value_float_sp(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Real value + real(tf_sp), intent(out) :: val + + !> Default real value + real(tf_sp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_float_sp + +!> Retrieve TOML value as double precision float +subroutine get_key_value_float_dp(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Real value + real(tf_dp), intent(out) :: val + + !> Default real value + real(tf_dp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_float_dp + +!> Retrieve TOML value as one byte integer (might loose precision) +subroutine get_key_value_integer_i1(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Default integer value + integer(tf_i1), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_integer_i1 + +!> Retrieve TOML value as two byte integer (might loose precision) +subroutine get_key_value_integer_i2(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Default integer value + integer(tf_i2), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_integer_i2 + +!> Retrieve TOML value as four byte integer (might loose precision) +subroutine get_key_value_integer_i4(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Default integer value + integer(tf_i4), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_integer_i4 + +!> Retrieve TOML value as eight byte integer +subroutine get_key_value_integer_i8(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Default integer value + integer(tf_i8), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_integer_i8 + +!> Retrieve TOML value as logical +subroutine get_key_value_bool(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Boolean value + logical, intent(out) :: val + + !> Default boolean value + logical, intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_bool + +!> Retrieve TOML value as datetime +subroutine get_key_value_datetime(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Datetime value + type(toml_datetime), intent(out) :: val + + !> Default datetime value + type(toml_datetime), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_datetime + +!> Retrieve TOML value as deferred-length character +subroutine get_key_value_string(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Default string value + character(kind=tfc, len=*), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call get_value(table, key%key, val, default, stat, origin) + +end subroutine get_key_value_string + +!> Set TOML value to single precision float +subroutine set_key_value_float_sp(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Real value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_float_sp + +!> Set TOML value to double precision float +subroutine set_key_value_float_dp(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Real value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_float_dp + +!> Set TOML value to one byte integer +subroutine set_key_value_integer_i1(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_integer_i1 + +!> Set TOML value to two byte integer +subroutine set_key_value_integer_i2(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_integer_i2 + +!> Set TOML value to four byte integer +subroutine set_key_value_integer_i4(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_integer_i4 + +!> Set TOML value to eight byte integer +subroutine set_key_value_integer_i8(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_integer_i8 + +!> Set TOML value to logical +subroutine set_key_value_bool(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_bool + +!> Set TOML value to datetime +subroutine set_key_value_datetime(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_datetime + +!> Set TOML value to deferred-length character +subroutine set_key_value_string(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + type(toml_key), intent(in) :: key + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + call set_value(table, key%key, val, stat, origin) + +end subroutine set_key_value_string + +subroutine get_child_table(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + logical :: is_requested + + if (.not.initialized(table)) call new_table(table) + + if (present(requested)) then + is_requested = requested + else + is_requested = .true. + end if + + nullify(ptr) + + call table%get(key, tmp) + + if (associated(tmp)) then + ptr => cast_to_table(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (is_requested) then + call add_table(table, key, ptr, stat) + else + if (present(stat)) stat = toml_stat%success + end if + if (present(origin)) origin = table%origin + end if + +end subroutine get_child_table + +subroutine get_child_array(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to child array + type(toml_array), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + logical :: is_requested + + if (.not.initialized(table)) call new_table(table) + + if (present(requested)) then + is_requested = requested + else + is_requested = .true. + end if + + nullify(ptr) + + call table%get(key, tmp) + + if (associated(tmp)) then + ptr => cast_to_array(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (is_requested) then + call add_array(table, key, ptr, stat) + else + if (present(stat)) stat = toml_stat%success + end if + if (present(origin)) origin = table%origin + end if + +end subroutine get_child_array + +subroutine get_child_keyval(table, key, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Pointer to child value + type(toml_keyval), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + class(toml_value), pointer :: tmp + logical :: is_requested + + if (.not.initialized(table)) call new_table(table) + + if (present(requested)) then + is_requested = requested + else + is_requested = .true. + end if + + nullify(ptr) + + call table%get(key, tmp) + + if (associated(tmp)) then + ptr => cast_to_keyval(tmp) + if (present(stat)) then + if (associated(ptr)) then + stat = toml_stat%success + else + stat = toml_stat%type_mismatch + end if + end if + if (present(origin)) origin = tmp%origin + else + if (is_requested) then + call add_keyval(table, key, ptr, stat) + else + if (present(stat)) stat = toml_stat%success + end if + if (present(origin)) origin = table%origin + end if + +end subroutine get_child_keyval + +!> Retrieve TOML value as single precision float (might lose accuracy) +subroutine get_child_value_float_sp(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Real value + real(tf_sp), intent(out) :: val + + !> Default real value + real(tf_sp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_float_sp + +!> Retrieve TOML value as double precision float +subroutine get_child_value_float_dp(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Real value + real(tf_dp), intent(out) :: val + + !> Default real value + real(tf_dp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_float_dp + +!> Retrieve TOML value as one byte integer (might loose precision) +subroutine get_child_value_integer_i1(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Default integer value + integer(tf_i1), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_integer_i1 + +!> Retrieve TOML value as two byte integer (might loose precision) +subroutine get_child_value_integer_i2(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Default integer value + integer(tf_i2), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_integer_i2 + +!> Retrieve TOML value as four byte integer (might loose precision) +subroutine get_child_value_integer_i4(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Default integer value + integer(tf_i4), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_integer_i4 + +!> Retrieve TOML value as eight byte integer +subroutine get_child_value_integer_i8(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Default integer value + integer(tf_i8), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_integer_i8 + +!> Retrieve TOML value as logical +subroutine get_child_value_bool(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Boolean value + logical, intent(out) :: val + + !> Default boolean value + logical, intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_bool + +!> Retrieve TOML value as datetime +subroutine get_child_value_datetime(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Datetime value + type(toml_datetime), intent(out) :: val + + !> Default datetime value + type(toml_datetime), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_datetime + +!> Retrieve TOML value as deferred-length character +subroutine get_child_value_string(table, key, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Default string value + character(kind=tfc, len=*), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, present(default), stat, origin) + + if (associated(ptr)) then + if (allocated(ptr%val)) then + call get_value(ptr, val, stat, origin) + else + if (present(default)) then + call set_value(ptr, default) + call get_value(ptr, val, stat=stat) + else + if (present(stat)) stat = toml_stat%fatal + end if + end if + else if (.not.present(default)) then + if (present(stat)) stat = merge(toml_stat%missing_key, stat, stat == toml_stat%success) + end if + +end subroutine get_child_value_string + +!> Set TOML value to single precision float +subroutine set_child_value_float_sp(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Real value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_float_sp + +!> Set TOML value to double precision float +subroutine set_child_value_float_dp(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Real value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_float_dp + +!> Set TOML value to one byte integer +subroutine set_child_value_integer_i1(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_integer_i1 + +!> Set TOML value to two byte integer +subroutine set_child_value_integer_i2(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_integer_i2 + +!> Set TOML value to four byte integer +subroutine set_child_value_integer_i4(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_integer_i4 + +!> Set TOML value to eight byte integer +subroutine set_child_value_integer_i8(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_integer_i8 + +!> Set TOML value to logical +subroutine set_child_value_bool(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_bool + +!> Set TOML value to datetime +subroutine set_child_value_datetime(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_datetime + +!> Set TOML value to deferred-length character +subroutine set_child_value_string(table, key, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Key in this TOML table + character(kind=tfc, len=*), intent(in) :: key + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_keyval), pointer :: ptr + + call get_value(table, key, ptr, .true., stat, origin) + + if (associated(ptr)) then + call set_value(ptr, val, stat, origin) + else + if (present(stat)) then + if (stat == toml_stat%success) stat = toml_stat%fatal + end if + end if + +end subroutine set_child_value_string + +end module tomlf_build_table + +!>>>>> build/dependencies/toml-f/src/tomlf/build/path.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Support for retrieving and setting values using a key path. +module tomlf_build_path + use tomlf_build_table, only : get_value, set_value + use tomlf_constants, only : tfc, tfi, tfr, tf_i1, tf_i2, tf_i4, tf_i8, & + & tf_sp, tf_dp + use tomlf_datetime, only : toml_datetime + use tomlf_error, only : toml_stat + use tomlf_type, only : toml_table, toml_array, toml_keyval, toml_key + implicit none + private + + public :: toml_path, get_value, set_value + + !> Setter functions to manipulate TOML tables + interface set_value + module procedure :: set_path_value_float_sp + module procedure :: set_path_value_float_dp + module procedure :: set_path_value_integer_i1 + module procedure :: set_path_value_integer_i2 + module procedure :: set_path_value_integer_i4 + module procedure :: set_path_value_integer_i8 + module procedure :: set_path_value_bool + module procedure :: set_path_value_datetime + module procedure :: set_path_value_string + end interface set_value + + !> Getter functions to manipulate TOML tables + interface get_value + module procedure :: get_path_table + module procedure :: get_path_array + module procedure :: get_path_keyval + module procedure :: get_path_value_float_sp + module procedure :: get_path_value_float_dp + module procedure :: get_path_value_integer_i1 + module procedure :: get_path_value_integer_i2 + module procedure :: get_path_value_integer_i4 + module procedure :: get_path_value_integer_i8 + module procedure :: get_path_value_bool + module procedure :: get_path_value_datetime + module procedure :: get_path_value_string + end interface get_value + + !> Wrapper for storing key paths + type :: toml_path + !> Path components + type(toml_key), allocatable :: path(:) + end type toml_path + + !> Convenience constructors for building key paths from strings instead of keys + interface toml_path + module procedure :: new_path2 + module procedure :: new_path3 + module procedure :: new_path4 + end interface toml_path + +contains + +!> Create a new path with two components +pure function new_path2(key1, key2) result(path) + + !> First key to retrieve + character(*), intent(in) :: key1 + + !> Second key to retrieve + character(*), intent(in) :: key2 + + !> New path + type(toml_path) :: path + + allocate(path%path(2)) + path%path(:) = [toml_key(key1), toml_key(key2)] +end function new_path2 + +!> Create a new path with three components +pure function new_path3(key1, key2, key3) result(path) + + !> First key to retrieve + character(*, tfc), intent(in) :: key1 + + !> Second key to retrieve + character(*, tfc), intent(in) :: key2 + + !> Third key to retrieve + character(*, tfc), intent(in) :: key3 + + !> New path + type(toml_path) :: path + + allocate(path%path(3)) + path%path(:) = [toml_key(key1), toml_key(key2), toml_key(key3)] +end function new_path3 + +!> Create a new path with three components +pure function new_path4(key1, key2, key3, key4) result(path) + + !> First key to retrieve + character(*, tfc), intent(in) :: key1 + + !> Second key to retrieve + character(*, tfc), intent(in) :: key2 + + !> Third key to retrieve + character(*, tfc), intent(in) :: key3 + + !> Forth key to retrieve + character(*, tfc), intent(in) :: key4 + + !> New path + type(toml_path) :: path + + allocate(path%path(4)) + path%path(:) = [toml_key(key1), toml_key(key2), toml_key(key3), toml_key(key4)] +end function new_path4 + +subroutine get_path_table(table, path, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout), target :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + logical :: is_requested + + is_requested = .true. + if (present(requested)) is_requested = requested + + nullify(ptr) + call walk_path(table, path, child, is_requested, stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), ptr, is_requested, stat, origin) + else + if (.not.is_requested .and. present(stat)) stat = toml_stat%success + end if +end subroutine get_path_table + +subroutine get_path_array(table, path, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Pointer to child array + type(toml_array), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + logical :: is_requested + + is_requested = .true. + if (present(requested)) is_requested = requested + + nullify(ptr) + call walk_path(table, path, child, is_requested, stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), ptr, is_requested, stat, origin) + else + if (.not.is_requested .and. present(stat)) stat = toml_stat%success + end if +end subroutine get_path_array + +subroutine get_path_keyval(table, path, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Pointer to child value + type(toml_keyval), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + logical :: is_requested + + is_requested = .true. + if (present(requested)) is_requested = requested + + nullify(ptr) + call walk_path(table, path, child, is_requested, stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), ptr, is_requested, stat, origin) + else + if (.not.is_requested .and. present(stat)) stat = toml_stat%success + end if +end subroutine get_path_keyval + +!> Retrieve TOML value as single precision float (might lose accuracy) +subroutine get_path_value_float_sp(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Real value + real(tf_sp), intent(out) :: val + + !> Default real value + real(tf_sp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_float_sp + +!> Retrieve TOML value as double precision float +subroutine get_path_value_float_dp(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Real value + real(tf_dp), intent(out) :: val + + !> Default real value + real(tf_dp), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_float_dp + +!> Retrieve TOML value as one byte integer (might loose precision) +subroutine get_path_value_integer_i1(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i1), intent(out) :: val + + !> Default integer value + integer(tf_i1), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_integer_i1 + +!> Retrieve TOML value as two byte integer (might loose precision) +subroutine get_path_value_integer_i2(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i2), intent(out) :: val + + !> Default integer value + integer(tf_i2), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_integer_i2 + +!> Retrieve TOML value as four byte integer (might loose precision) +subroutine get_path_value_integer_i4(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i4), intent(out) :: val + + !> Default integer value + integer(tf_i4), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_integer_i4 + +!> Retrieve TOML value as eight byte integer +subroutine get_path_value_integer_i8(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i8), intent(out) :: val + + !> Default integer value + integer(tf_i8), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_integer_i8 + +!> Retrieve TOML value as logical +subroutine get_path_value_bool(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Boolean value + logical, intent(out) :: val + + !> Default boolean value + logical, intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_bool + +!> Retrieve TOML value as datetime +subroutine get_path_value_datetime(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Datetime value + type(toml_datetime), intent(out) :: val + + !> Default datetime value + type(toml_datetime), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_datetime + +!> Retrieve TOML value as deferred-length character +subroutine get_path_value_string(table, path, val, default, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> String value + character(kind=tfc, len=:), allocatable, intent(out) :: val + + !> Default string value + character(kind=tfc, len=*), intent(in), optional :: default + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, present(default), stat, origin) + if (associated(child)) then + call get_value(child, path%path(size(path%path)), val, default, stat, origin) + end if +end subroutine get_path_value_string + +!> Set TOML value to single precision float +subroutine set_path_value_float_sp(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Real value + real(tf_sp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_float_sp + +!> Set TOML value to double precision float +subroutine set_path_value_float_dp(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Real value + real(tf_dp), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_float_dp + +!> Set TOML value to one byte integer +subroutine set_path_value_integer_i1(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i1), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_integer_i1 + +!> Set TOML value to two byte integer +subroutine set_path_value_integer_i2(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i2), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_integer_i2 + +!> Set TOML value to four byte integer +subroutine set_path_value_integer_i4(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i4), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_integer_i4 + +!> Set TOML value to eight byte integer +subroutine set_path_value_integer_i8(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Integer value + integer(tf_i8), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_integer_i8 + +!> Set TOML value to logical +subroutine set_path_value_bool(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Boolean value + logical, intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_bool + +!> Set TOML value to datetime +subroutine set_path_value_datetime(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Datetime value + type(toml_datetime), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_datetime + +!> Set TOML value to deferred-length character +subroutine set_path_value_string(table, path, val, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout) :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> String value + character(kind=tfc, len=*), intent(in) :: val + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + type(toml_table), pointer :: child + + call walk_path(table, path, child, .true., stat, origin) + if (associated(child)) then + call set_value(child, path%path(size(path%path)), val, stat, origin) + end if +end subroutine set_path_value_string + +subroutine walk_path(table, path, ptr, requested, stat, origin) + + !> Instance of the TOML table + class(toml_table), intent(inout), target :: table + + !> Path in this TOML table + type(toml_path), intent(in) :: path + + !> Pointer to child table + type(toml_table), pointer, intent(out) :: ptr + + !> Child value must be present + logical, intent(in), optional :: requested + + !> Status of operation + integer, intent(out), optional :: stat + + !> Origin in the data structure + integer, intent(out), optional :: origin + + integer :: it + type(toml_table), pointer :: current, next + + nullify(ptr) + if (.not.allocated(path%path)) then + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = table%origin + return + end if + + current => table + do it = 1, size(path%path) - 1 + call get_value(current, path%path(it)%key, next, requested, stat, origin) + if (.not.associated(next)) then + if (present(stat)) stat = toml_stat%fatal + if (present(origin)) origin = current%origin + return + end if + current => next + end do + ptr => current +end subroutine walk_path + +end module tomlf_build_path + +!>>>>> build/dependencies/toml-f/src/tomlf/build.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Functions to build a TOML data structures +!> +!> The build module defines a high level interface to work with TOML data structures +!> and construct them in a convenient way. +module tomlf_build + use tomlf_build_array, only : get_value, set_value + use tomlf_build_keyval, only : get_value, set_value + use tomlf_build_merge, only : merge_table, merge_array, merge_policy, toml_merge_config + use tomlf_build_path, only : get_value, set_value, toml_path + use tomlf_build_table, only : get_value, set_value + implicit none + private + + public :: get_value, set_value + public :: merge_table, merge_array, merge_policy, toml_merge_config + public :: toml_path + +end module tomlf_build + +!>>>>> build/dependencies/toml-f/src/tomlf.f90 + +! This file is part of toml-f. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Minimal public API for TOML-Fortran +module tomlf + use tomlf_build, only : get_value, set_value, toml_path + use tomlf_datetime, only : toml_datetime, to_string + use tomlf_de, only : toml_parse, toml_load, toml_loads, & + & toml_context, toml_parser_config, toml_level + use tomlf_error, only : toml_error, toml_stat + use tomlf_ser, only : toml_serializer, toml_serialize, toml_dump, toml_dumps + use tomlf_terminal, only : toml_terminal + use tomlf_type, only : toml_table, toml_array, toml_keyval, toml_key, toml_value, & + & is_array_of_tables, new_table, add_table, add_array, add_keyval, len + use tomlf_utils_sort, only : sort + use tomlf_version, only : tomlf_version_string, tomlf_version_compact, & + & get_tomlf_version + implicit none + public + +end module tomlf + +!>>>>> build/dependencies/jonquil/src/jonquil/parser.f90 + +! This file is part of jonquil. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +module jonquil_parser + use tomlf_constants, only : tfc, tfi, tfr, toml_type + use tomlf_datetime, only : toml_datetime + use tomlf_de_context, only : toml_context + use jonquil_lexer, only : json_lexer, new_lexer_from_string, new_lexer_from_unit, & + & new_lexer_from_file + use tomlf_de_parser, only : parse, toml_parser_config + use tomlf_diagnostic, only : toml_level + use tomlf_build, only : get_value + use tomlf_error, only : toml_error + use tomlf_type, only : toml_table, toml_value, cast_to_table, & + & toml_visitor, toml_array, toml_keyval, toml_key, len + implicit none + private + + public :: json_load, json_loads + + !> Load a TOML data structure from the provided source + interface json_load + module procedure :: json_load_file + module procedure :: json_load_unit + end interface json_load + + !> Load a TOML data structure from a string + interface json_loads + module procedure :: json_load_string + end interface json_loads + + !> Implement pruning of annotated values as visitor + type, extends(toml_visitor) :: json_prune + contains + !> Traverse the AST and prune all annotated values + procedure :: visit + end type json_prune + +contains + +!> Load TOML data structure from file +subroutine json_load_file(object, filename, config, context, error) + !> Instance of the TOML data structure, not allocated in case of error + class(toml_value), allocatable, intent(out) :: object + !> Name of the file to load + character(*, tfc), intent(in) :: filename + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + type(json_lexer) :: lexer + type(toml_error), allocatable :: error_ + type(toml_table), allocatable :: table + + call new_lexer_from_file(lexer, filename, error_) + if (.not.allocated(error_)) then + call parse(lexer, table, config, context, error) + if (allocated(table)) call prune(object, table) + else + if (present(error)) call move_alloc(error_, error) + end if +end subroutine json_load_file + +!> Load TOML data structure from unit +subroutine json_load_unit(object, io, config, context, error) + !> Instance of the TOML data structure, not allocated in case of error + class(toml_value), allocatable, intent(out) :: object + !> Unit to read from + integer, intent(in) :: io + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + type(json_lexer) :: lexer + type(toml_error), allocatable :: error_ + type(toml_table), allocatable :: table + + call new_lexer_from_unit(lexer, io, error_) + if (.not.allocated(error_)) then + call parse(lexer, table, config, context, error) + if (allocated(table)) call prune(object, table) + else + if (present(error)) call move_alloc(error_, error) + end if +end subroutine json_load_unit + +!> Load TOML data structure from string +subroutine json_load_string(object, string, config, context, error) + !> Instance of the TOML data structure, not allocated in case of error + class(toml_value), allocatable, intent(out) :: object + !> String containing TOML document + character(*, tfc), intent(in) :: string + !> Configuration for the parser + type(toml_parser_config), intent(in), optional :: config + !> Context tracking the origin of the data structure to allow rich reports + type(toml_context), intent(out), optional :: context + !> Error handling, provides detailed diagnostic in case of error + type(toml_error), allocatable, intent(out), optional :: error + + type(json_lexer) :: lexer + type(toml_table), allocatable :: table + + call new_lexer_from_string(lexer, string) + call parse(lexer, table, config, context, error) + if (allocated(table)) call prune(object, table) +end subroutine json_load_string + +!> Prune the artificial root table inserted by the lexer +subroutine prune(object, table) + !> Instance of the TOML data structure, not allocated in case of error + class(toml_value), allocatable, intent(inout) :: object + !> Instance of the TOML data structure, not allocated in case of error + type(toml_table), allocatable, intent(inout) :: table + + type(json_prune) :: pruner + + call table%pop("_", object) + + if (allocated(object)) call object%accept(pruner) +end subroutine prune + +!> Visit a TOML value +subroutine visit(self, val) + !> Instance of the JSON pruner + class(json_prune), intent(inout) :: self + !> TOML value to visit + class(toml_value), intent(inout) :: val + + select type(val) + class is(toml_array) + call visit_array(self, val) + class is(toml_table) + call visit_table(self, val) + end select +end subroutine visit + +!> Visit a TOML array +subroutine visit_array(visitor, array) + !> Instance of the JSON pruner + class(json_prune), intent(inout) :: visitor + !> TOML value to visit + type(toml_array), intent(inout) :: array + + class(toml_value), allocatable :: val, tmp + character(kind=tfc, len=:), allocatable :: str + type(toml_key), allocatable :: vt(:) + integer :: i, n, stat + + n = len(array) + do i = 1, n + call array%shift(val) + select type(val) + class default + call val%accept(visitor) + class is(toml_table) + call val%get_keys(vt) + if (val%has_key("type") .and. val%has_key("value") .and. size(vt)==2) then + call get_value(val, "type", str) + call prune_value(tmp, val, str) + call val%destroy + call tmp%accept(visitor) + call array%push_back(tmp, stat) + cycle + else + call val%accept(visitor) + end if + end select + call array%push_back(val, stat) + end do +end subroutine visit_array + +!> Visit a TOML table +subroutine visit_table(visitor, table) + !> Instance of the JSON pruner + class(json_prune), intent(inout) :: visitor + !> TOML table to visit + type(toml_table), intent(inout) :: table + + class(toml_value), pointer :: ptr + class(toml_value), allocatable :: val + character(kind=tfc, len=:), allocatable :: str + type(toml_key), allocatable :: list(:), vt(:) + integer :: i, n, stat + + call table%get_keys(list) + n = size(list, 1) + + do i = 1, n + call table%get(list(i)%key, ptr) + select type(ptr) + class default + call ptr%accept(visitor) + class is(toml_table) + call ptr%get_keys(vt) + if (ptr%has_key("type") .and. ptr%has_key("value") .and. size(vt)==2) then + call get_value(ptr, "type", str) + call prune_value(val, ptr, str) + call val%accept(visitor) + call table%delete(list(i)%key) + call table%push_back(val, stat) + else + call ptr%accept(visitor) + end if + end select + end do +end subroutine visit_table + +subroutine prune_value(val, table, str) + !> Actual TOML value + class(toml_value), allocatable, intent(out) :: val + !> TOML table to prune + type(toml_table), intent(inout) :: table + !> Value kind + character(kind=tfc, len=*), intent(in) :: str + + class(toml_value), pointer :: ptr + character(:, tfc), pointer :: sval + character(kind=tfc, len=:), allocatable :: tmp + integer :: stat + type(toml_datetime) :: dval + integer(tfi) :: ival + real(tfr) :: fval + + call table%get("value", ptr) + allocate(val, source=ptr) + if (allocated(table%key)) then + val%key = table%key + else + deallocate(val%key) + end if + + select type(val) + class is(toml_keyval) + call val%get(sval) + select case(str) + case("date", "time", "datetime", "date-local", "time-local", "datetime-local") + dval = toml_datetime(sval) + call val%set(dval) + case("bool") + call val%set(sval == "true") + case("integer") + read(sval, *, iostat=stat) ival + if (stat == 0) then + call val%set(ival) + end if + case("float") + read(sval, *, iostat=stat) fval + if (stat == 0) then + call val%set(fval) + end if + end select + end select +end subroutine prune_value + +end module jonquil_parser + +!>>>>> build/dependencies/jonquil/src/jonquil.f90 + +! This file is part of jonquil. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Minimal public API for Jonquil +module jonquil + use tomlf, only : get_value, set_value, json_path => toml_path, & + & json_context => toml_context, json_parser_config => toml_parser_config, & + & json_level => toml_level, json_error => toml_error, json_stat => toml_stat, & + & json_terminal => toml_terminal, json_object => toml_table, json_array => toml_array, & + & json_keyval => toml_keyval, json_key => toml_key, json_value => toml_value, & + & new_object => new_table, add_object => add_table, add_array, add_keyval, sort, len + use tomlf_type, only : cast_to_object => cast_to_table, cast_to_array, cast_to_keyval + use tomlf_version, only : tomlf_version_string, tomlf_version_compact, get_tomlf_version + use jonquil_version, only : jonquil_version_string, jonquil_version_compact, & + & get_jonquil_version + use jonquil_parser, only : json_load, json_loads + use jonquil_ser, only : json_serializer, json_serialize, json_dump, json_dumps, & + & json_ser_config + implicit none + public + +end module jonquil + +!>>>>> ././src/fpm/downloader.f90 + +module fpm_downloader + use fpm_error, only: error_t, fatal_error + use fpm_filesystem, only: which, run + use fpm_versioning, only: version_t + use jonquil, only: json_object, json_value, json_error, json_load, cast_to_object + use fpm_strings, only: string_t + + implicit none + private + + public :: downloader_t + + !> This type could be entirely avoided but it is quite practical because it can be mocked for testing. + type downloader_t + contains + procedure, nopass :: get_pkg_data, get_file, upload_form, unpack + end type + +contains + + !> Perform an http get request, save output to file, and parse json. + subroutine get_pkg_data(url, version, tmp_pkg_file, json, error) + character(*), intent(in) :: url + type(version_t), allocatable, intent(in) :: version + character(*), intent(in) :: tmp_pkg_file + type(json_object), intent(out) :: json + type(error_t), allocatable, intent(out) :: error + + class(json_value), allocatable :: j_value + type(json_object), pointer :: ptr + type(json_error), allocatable :: j_error + + if (allocated(version)) then + ! Request specific version. + call get_file(url//'/'//version%s(), tmp_pkg_file, error) + else + ! Request latest version. + call get_file(url, tmp_pkg_file, error) + end if + if (allocated(error)) return + + call json_load(j_value, tmp_pkg_file, error=j_error) + if (allocated(j_error)) then + allocate (error); call move_alloc(j_error%message, error%message); call json%destroy(); return + end if + + ptr => cast_to_object(j_value) + if (.not. associated(ptr)) then + call fatal_error(error, "Error parsing JSON from '"//url//"'."); return + end if + + json = ptr + end + + !> Download a file from a url using either curl or wget. + subroutine get_file(url, tmp_pkg_file, error) + character(*), intent(in) :: url + character(*), intent(in) :: tmp_pkg_file + type(error_t), allocatable, intent(out) :: error + + integer :: stat + + if (which('curl') /= '') then + print *, "Downloading '"//url//"' -> '"//tmp_pkg_file//"'" + call execute_command_line('curl '//url//' -s -o '//tmp_pkg_file, exitstat=stat) + else if (which('wget') /= '') then + print *, "Downloading '"//url//"' -> '"//tmp_pkg_file//"'" + call execute_command_line('wget '//url//' -q -O '//tmp_pkg_file, exitstat=stat) + else + call fatal_error(error, "Neither 'curl' nor 'wget' installed."); return + end if + + if (stat /= 0) then + call fatal_error(error, "Error downloading package from '"//url//"'."); return + end if + end + + !> Perform an http post request with form data. + subroutine upload_form(endpoint, form_data, verbose, error) + !> Endpoint to upload to. + character(len=*), intent(in) :: endpoint + !> Form data to upload. + type(string_t), intent(in) :: form_data(:) + !> Print additional information if true. + logical, intent(in) :: verbose + !> Error handling. + type(error_t), allocatable, intent(out) :: error + + integer :: stat, i + character(len=:), allocatable :: form_data_str + + form_data_str = '' + do i = 1, size(form_data) + form_data_str = form_data_str//"-F '"//form_data(i)%s//"' " + end do + + if (which('curl') /= '') then + print *, 'Uploading package ...' + call run('curl -X POST -H "Content-Type: multipart/form-data" '// & + & form_data_str//endpoint, exitstat=stat, echo=verbose) + else + call fatal_error(error, "'curl' not installed."); return + end if + + if (stat /= 0) then + call fatal_error(error, "Error uploading package to registry."); return + end if + end + + !> Unpack a tarball to a destination. + subroutine unpack(tmp_pkg_file, destination, error) + !> Path to tarball. + character(*), intent(in) :: tmp_pkg_file + !> Destination to unpack to. + character(*), intent(in) :: destination + !> Error handling. + type(error_t), allocatable, intent(out) :: error + + integer :: stat + + if (which('tar') == '') then + call fatal_error(error, "'tar' not installed."); return + end if + + print *, "Unpacking '"//tmp_pkg_file//"' to '"//destination//"' ..." + call execute_command_line('tar -zxf '//tmp_pkg_file//' -C '//destination, exitstat=stat) + + if (stat /= 0) then + call fatal_error(error, "Error unpacking '"//tmp_pkg_file//"'."); return + end if + end +end + +!>>>>> ././src/fpm/toml.f90 + +!># Interface to TOML processing library +!> +!> This module acts as a proxy to the `toml-f` public Fortran API and allows +!> to selectively expose components from the library to `fpm`. +!> The interaction with `toml-f` data types outside of this module should be +!> limited to tables, arrays and key-lists, most of the necessary interactions +!> are implemented in the building interface with the `get_value` and `set_value` +!> procedures. +!> +!> This module allows to implement features necessary for `fpm`, which are +!> not yet available in upstream `toml-f`. +!> +!> For more details on the library used see the +!> [TOML-Fortran](https://toml-f.github.io/toml-f) developer pages. +module fpm_toml + use fpm_error, only: error_t, fatal_error, file_not_found_error + use fpm_strings, only: string_t, str_ends_with, lower + use tomlf, only: toml_table, toml_array, toml_key, toml_stat, get_value, & + & set_value, toml_parse, toml_error, new_table, add_table, add_array, & + & toml_serialize, len, toml_load, toml_value + use tomlf_de_parser, only: parse + use jonquil, only: json_serialize, json_error, json_value, json_object, json_load, & + cast_to_object + use iso_fortran_env, only: int64 + implicit none + private + + public :: read_package_file, toml_table, toml_array, toml_key, toml_stat, & + get_value, set_value, get_list, new_table, add_table, add_array, len, & + toml_error, toml_serialize, toml_load, check_keys, set_list, set_string, & + name_is_json, has_list + + !> An abstract interface for any fpm class that should be fully serializable to/from TOML/JSON + type, abstract, public :: serializable_t + + contains + + !> Dump to TOML table, unit, file + procedure(to_toml), deferred :: dump_to_toml + procedure, non_overridable, private :: dump_to_file + procedure, non_overridable, private :: dump_to_unit + generic :: dump => dump_to_toml, dump_to_file, dump_to_unit + + !> Load from TOML table, unit, file + procedure(from_toml), deferred :: load_from_toml + procedure, non_overridable, private :: load_from_file + procedure, non_overridable, private :: load_from_unit + generic :: load => load_from_toml, load_from_file, load_from_unit + + !> Serializable entities need a way to check that they're equal + procedure(is_equal), deferred :: serializable_is_same + generic :: operator(==) => serializable_is_same + + !> Test load/write roundtrip + procedure, non_overridable :: test_serialization + + end type serializable_t + + !> add_table: fpm interface + interface add_table + module procedure add_table_fpm + end interface add_table + + !> set_value: fpm interface + interface set_value + module procedure set_logical + module procedure set_integer + module procedure set_integer_64 + end interface set_value + + interface set_string + module procedure set_character + module procedure set_string_type + end interface set_string + + !> get_value: fpm interface + interface get_value + module procedure get_logical + module procedure get_integer + module procedure get_integer_64 + end interface get_value + + abstract interface + + !> Write object to TOML datastructure + subroutine to_toml(self, table, error) + import serializable_t,toml_table,error_t + implicit none + + !> Instance of the serializable object + class(serializable_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + end subroutine to_toml + + !> Read dependency tree from TOML data structure + subroutine from_toml(self, table, error) + import serializable_t,toml_table,error_t + implicit none + + !> Instance of the serializable object + class(serializable_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + end subroutine from_toml + + !> Compare two serializable objects + logical function is_equal(this,that) + import serializable_t + class(serializable_t), intent(in) :: this,that + end function is_equal + + end interface + +contains + + !> Test serialization of a serializable object + subroutine test_serialization(self, message, error) + class(serializable_t), intent(inout) :: self + character(len=*), intent(in) :: message + type(error_t), allocatable, intent(out) :: error + + integer :: iunit, ii + class(serializable_t), allocatable :: copy + character(len=4), parameter :: formats(2) = ['TOML','JSON'] + + all_formats: do ii = 1, 2 + + open(newunit=iunit,form='formatted',action='readwrite',status='scratch') + + !> Dump to scratch file + call self%dump(iunit, error, json=ii==2) + if (allocated(error)) then + error%message = formats(ii)//': '//error%message + return + endif + + !> Load from scratch file + rewind(iunit) + allocate(copy,mold=self) + call copy%load(iunit,error, json=ii==2) + if (allocated(error)) then + error%message = formats(ii)//': '//error%message + return + endif + close(iunit) + + !> Check same + if (.not.(self==copy)) then + call fatal_error(error,'serializable object failed '//formats(ii)//& + ' write/reread test: '//trim(message)) + return + end if + deallocate(copy) + + end do all_formats + + end subroutine test_serialization + + !> Write serializable object to a formatted Fortran unit + subroutine dump_to_unit(self, unit, error, json) + !> Instance of the dependency tree + class(serializable_t), intent(inout) :: self + !> Formatted unit + integer, intent(in) :: unit + !> Error handling + type(error_t), allocatable, intent(out) :: error + !> Optional JSON format requested? + logical, optional, intent(in) :: json + + type(toml_table) :: table + logical :: is_json + + is_json = .false.; if (present(json)) is_json = json + + table = toml_table() + call self%dump(table, error) + + if (is_json) then + +! !> Deactivate JSON serialization for now +! call fatal_error(error, 'JSON serialization option is not yet available') +! return + + write (unit, '(a)') json_serialize(table) + else + write (unit, '(a)') toml_serialize(table) + end if + + call table%destroy() + + end subroutine dump_to_unit + + !> Write serializable object to file + subroutine dump_to_file(self, file, error, json) + !> Instance of the dependency tree + class(serializable_t), intent(inout) :: self + !> File name + character(len=*), intent(in) :: file + !> Error handling + type(error_t), allocatable, intent(out) :: error + !> Optional JSON format + logical, optional, intent(in) :: json + + integer :: unit + + open (file=file, newunit=unit) + call self%dump(unit, error, json) + close (unit) + if (allocated(error)) return + + end subroutine dump_to_file + + !> Read dependency tree from file + subroutine load_from_file(self, file, error, json) + !> Instance of the dependency tree + class(serializable_t), intent(inout) :: self + !> File name + character(len=*), intent(in) :: file + !> Error handling + type(error_t), allocatable, intent(out) :: error + !> Optional JSON format + logical, optional, intent(in) :: json + + integer :: unit + logical :: exist + + inquire (file=file, exist=exist) + if (.not. exist) return + + open (file=file, newunit=unit) + call self%load(unit, error, json) + close (unit) + end subroutine load_from_file + + !> Read dependency tree from file + subroutine load_from_unit(self, unit, error, json) + !> Instance of the dependency tree + class(serializable_t), intent(inout) :: self + !> File name + integer, intent(in) :: unit + !> Error handling + type(error_t), allocatable, intent(out) :: error + !> Optional JSON format + logical, optional, intent(in) :: json + + type(toml_error), allocatable :: local_error + type(toml_table), allocatable :: table + type(toml_table), pointer :: jtable + class(toml_value), allocatable :: object + logical :: is_json + + is_json = .false.; if (present(json)) is_json = json + + if (is_json) then + + !> init JSON interpreter + call json_load(object, unit, error=local_error) + if (allocated(local_error)) then + allocate (error) + call move_alloc(local_error%message, error%message) + return + end if + + jtable => cast_to_object(object) + if (.not.associated(jtable)) then + call fatal_error(error,'cannot initialize JSON table ') + return + end if + + !> Read object from TOML table + call self%load(jtable, error) + + else + + !> use default TOML parser + call toml_load(table, unit, error=local_error) + + if (allocated(local_error)) then + allocate (error) + call move_alloc(local_error%message, error%message) + return + end if + + !> Read object from TOML table + call self%load(table, error) + + endif + + if (allocated(error)) return + + end subroutine load_from_unit + + !> Process the configuration file to a TOML data structure + subroutine read_package_file(table, manifest, error) + + !> TOML data structure + type(toml_table), allocatable, intent(out) :: table + + !> Name of the package configuration file + character(len=*), intent(in) :: manifest + + !> Error status of the operation + type(error_t), allocatable, intent(out) :: error + + type(toml_error), allocatable :: parse_error + integer :: unit + logical :: exist + + inquire (file=manifest, exist=exist) + + if (.not. exist) then + call file_not_found_error(error, manifest) + return + end if + + open(file=manifest, newunit=unit) + call toml_load(table, unit, error=parse_error) + close(unit) + + if (allocated(parse_error)) then + allocate (error) + call move_alloc(parse_error%message, error%message) + return + end if + + end subroutine read_package_file + + !> Check if an instance of the TOML data structure contains a list + logical function has_list(table, key) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Key to read from + character(len=*), intent(in) :: key + + type(toml_array), pointer :: children + + has_list = .false. + + if (.not.table%has_key(key)) return + + call get_value(table, key, children, requested=.false.) + + ! There is an allocated list + has_list = associated(children) + + end function has_list + + subroutine get_list(table, key, list, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Key to read from + character(len=*), intent(in) :: key + + !> List of strings to read + type(string_t), allocatable, intent(out) :: list(:) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: stat, ilist, nlist + type(toml_array), pointer :: children + character(len=:), allocatable :: str + + if (.not.table%has_key(key)) return + + call get_value(table, key, children, requested=.false.) + if (associated(children)) then + nlist = len(children) + allocate (list(nlist)) + do ilist = 1, nlist + call get_value(children, ilist, str, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Entry in "//key//" field cannot be read") + exit + end if + call move_alloc(str, list(ilist)%s) + end do + if (allocated(error)) return + else + call get_value(table, key, str, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Entry in "//key//" field cannot be read") + return + end if + if (allocated(str)) then + allocate (list(1)) + call move_alloc(str, list(1)%s) + end if + end if + + end subroutine get_list + + ! Set string array + subroutine set_list(table, key, list, error) + + !> Instance of the string array + type(string_t), allocatable, intent(in) :: list(:) + + !> Key to save to + character(len=*), intent(in) :: key + + !> Instance of the toml table + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + integer :: stat, ilist + type(toml_array), pointer :: children + character(len=:), allocatable :: str + + !> Set no key if array is not present + if (.not.allocated(list)) return + + !> Check the key is not empty + if (len_trim(key)<=0) then + call fatal_error(error, 'key is empty dumping string array to TOML table') + return + end if + + if (size(list)/=1) then ! includes empty list case + + !> String array + call add_array(table, key, children, stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Cannot set array table in "//key//" field") + return + end if + + do ilist = 1, size(list) + call set_value(children, ilist, list(ilist)%s, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Cannot store array entry in "//key//" field") + return + end if + end do + + else + + ! Single value: set string + call set_value(table, key, list(1)%s, stat=stat) + + if (stat /= toml_stat%success) & + call fatal_error(error, "Cannot store entry in "//key//" field") + + return + end if + + end subroutine set_list + + !> Function wrapper to set a character(len=:), allocatable variable to a toml table + subroutine set_character(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> List of keys to check. + character(len=*), intent(in) :: key + + !> The character variable + character(len=*), optional, intent(in) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + !> Check the key is not empty + if (len_trim(key)<=0) then + call fatal_error(error, 'key is empty setting character string to TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + if (present(var)) then + call set_value(table, key, var, ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot set character key <'//key//'> in TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + endif + + end subroutine set_character + + !> Function wrapper to set a logical variable to a toml table, returning an fpm error + subroutine set_logical(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + logical, intent(in) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + call set_value(table, key, var, stat=ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot set logical key <'//key//'> in TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine set_logical + + !> Function wrapper to set a default integer variable to a toml table, returning an fpm error + subroutine set_integer(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + integer, intent(in) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + call set_value(table, key, var, stat=ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot set integer key <'//key//'> in TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine set_integer + + !> Function wrapper to set a default integer variable to a toml table, returning an fpm error + subroutine set_integer_64(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + integer(int64), intent(in) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + call set_value(table, key, var, stat=ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot set integer(int64) key <'//key//'> in TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine set_integer_64 + + !> Function wrapper to set a character(len=:), allocatable variable to a toml table + subroutine set_string_type(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> List of keys to check. + character(len=*), intent(in) :: key + + !> The character variable + type(string_t), intent(in) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + call set_character(table, key, var%s, error, whereAt) + + end subroutine set_string_type + + !> Function wrapper to add a toml table and return an fpm error + subroutine add_table_fpm(table, key, ptr, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Table key + character(len=*), intent(in) :: key + + !> The character variable + type(toml_table), pointer, intent(out) :: ptr + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + !> Nullify pointer + nullify(ptr) + + call add_table(table, key, ptr, ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot add <'//key//'> table in TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine add_table_fpm + + !> Function wrapper to get a logical variable from a toml table, returning an fpm error + subroutine get_logical(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + logical, intent(inout) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + call get_value(table, key, var, stat=ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot get logical key <'//key//'> from TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine get_logical + + !> Function wrapper to get a default integer variable from a toml table, returning an fpm error + subroutine get_integer(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + integer, intent(inout) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + call get_value(table, key, var, stat=ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot get integer key <'//key//'> from TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine get_integer + + !> Function wrapper to get a integer(int64) variable from a toml table, returning an fpm error + subroutine get_integer_64(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + integer(int64), intent(inout) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + call get_value(table, key, var, stat=ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot get integer(int64) key <'//key//'> from TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine get_integer_64 + + !> Check if table contains only keys that are part of the list. If a key is + !> found that is not part of the list, an error is allocated. + subroutine check_keys(table, valid_keys, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> List of keys to check. + character(len=*), intent(in) :: valid_keys(:) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: keys(:) + type(toml_table), pointer :: child + character(:), allocatable :: name, value, valid_keys_string + integer :: ikey, ivalid + + call table%get_key(name) + call table%get_keys(keys) + + do ikey = 1, size(keys) + if (.not. any(keys(ikey)%key == valid_keys)) then + ! Generate error message + valid_keys_string = new_line('a')//new_line('a') + do ivalid = 1, size(valid_keys) + valid_keys_string = valid_keys_string//trim(valid_keys(ivalid))//new_line('a') + end do + allocate (error) + error%message = "Key '"//keys(ikey)%key//"' not allowed in the '"// & + & name//"' table."//new_line('a')//new_line('a')//'Valid keys: '//valid_keys_string + return + end if + + ! Check if value can be mapped or else (wrong type) show error message with the error location. + ! Right now, it can only be mapped to a string or to a child node, but this can be extended in the future. + call get_value(table, keys(ikey)%key, value) + if (.not. allocated(value)) then + + ! If value is not a string, check if it is a child node + call get_value(table, keys(ikey)%key, child) + + if (.not.associated(child)) then + allocate (error) + error%message = "'"//name//"' has an invalid '"//keys(ikey)%key//"' entry." + return + endif + end if + end do + + end subroutine check_keys + + !> Choose between JSON or TOML based on a file name + logical function name_is_json(filename) + character(*), intent(in) :: filename + + character(*), parameter :: json_identifier = ".json" + + name_is_json = .false. + + if (len_trim(filename)>>>> ././src/fpm_settings.f90 + +!> Manages global settings which are defined in the global config file. +module fpm_settings + use fpm_filesystem, only: exists, join_path, get_local_prefix, is_absolute_path, mkdir + use fpm_environment, only: os_is_unix + use fpm_error, only: error_t, fatal_error + use fpm_toml, only: toml_table, toml_error, toml_stat, get_value, toml_load, check_keys + use fpm_os, only: get_current_directory, change_directory, get_absolute_path, convert_to_absolute_path + + implicit none + private + public :: fpm_global_settings, get_global_settings, get_registry_settings, official_registry_base_url + + character(*), parameter :: official_registry_base_url = 'https://fpm-registry.vercel.app' + character(*), parameter :: default_config_file_name = 'config.toml' + + type :: fpm_global_settings + !> Path to the global config file excluding the file name. + character(len=:), allocatable :: path_to_config_folder + !> Name of the global config file. The default is `config.toml`. + character(len=:), allocatable :: config_file_name + !> Registry configs. + type(fpm_registry_settings), allocatable :: registry_settings + contains + procedure :: has_custom_location, full_path, path_to_config_folder_or_empty + end type + + type :: fpm_registry_settings + !> The path to the local registry. If allocated, the local registry + !> will be used instead of the remote registry and replaces the + !> local cache. + character(len=:), allocatable :: path + !> The URL to the remote registry. Can be used to get packages + !> from the official or a custom registry. + character(len=:), allocatable :: url + !> The path to the cache folder. If not specified, the default cache + !> folders are `~/.local/share/fpm/dependencies` on Unix and + !> `%APPDATA%\local\fpm\dependencies` on Windows. + !> Cannot be used together with `path`. + character(len=:), allocatable :: cache_path + end type + +contains + !> Obtain global settings from the global config file. + subroutine get_global_settings(global_settings, error) + !> Global settings to be obtained. + type(fpm_global_settings), intent(inout) :: global_settings + !> Error reading config file. + type(error_t), allocatable, intent(out) :: error + !> TOML table to be filled with global config settings. + type(toml_table), allocatable :: table + !> Error parsing to TOML table. + type(toml_error), allocatable :: parse_error + + type(toml_table), pointer :: registry_table + integer :: stat + + ! Use custom path to the config file if it was specified. + if (global_settings%has_custom_location()) then + ! Throw error if folder doesn't exist. + if (.not. exists(global_settings%path_to_config_folder)) then + call fatal_error(error, "Folder not found: '"//global_settings%path_to_config_folder//"'."); return + end if + + ! Throw error if the file doesn't exist. + if (.not. exists(global_settings%full_path())) then + call fatal_error(error, "File not found: '"//global_settings%full_path()//"'."); return + end if + + ! Make sure that the path to the global config file is absolute. + call convert_to_absolute_path(global_settings%path_to_config_folder, error) + if (allocated(error)) return + else + ! Use default path if it wasn't specified. + if (os_is_unix()) then + global_settings%path_to_config_folder = join_path(get_local_prefix(), 'share', 'fpm') + else + global_settings%path_to_config_folder = join_path(get_local_prefix(), 'fpm') + end if + + ! Use default file name. + global_settings%config_file_name = default_config_file_name + + ! Apply default registry settings and return if config file doesn't exist. + if (.not. exists(global_settings%full_path())) then + call use_default_registry_settings(global_settings); return + end if + end if + + ! Load into TOML table. + call toml_load(table, global_settings%full_path(), error=parse_error) + + if (allocated(parse_error)) then + allocate (error); call move_alloc(parse_error%message, error%message); return + end if + + call get_value(table, 'registry', registry_table, requested=.false., stat=stat) + + if (stat /= toml_stat%success) then + call fatal_error(error, "Error reading registry from config file '"// & + & global_settings%full_path()//"'."); return + end if + + ! A registry table was found. + if (associated(registry_table)) then + call get_registry_settings(registry_table, global_settings, error) + else + call use_default_registry_settings(global_settings) + end if + end + + !> Default registry settings are typically applied if the config file doesn't exist or no registry table was found in + !> the global config file. + subroutine use_default_registry_settings(global_settings) + type(fpm_global_settings), intent(inout) :: global_settings + + if (.not. allocated(global_settings%registry_settings)) allocate (global_settings%registry_settings) + global_settings%registry_settings%url = official_registry_base_url + global_settings%registry_settings%cache_path = join_path(global_settings%path_to_config_folder_or_empty(), & + & 'dependencies') + end + + !> Read registry settings from the global config file. + subroutine get_registry_settings(table, global_settings, error) + !> The [registry] subtable from the global config file. + type(toml_table), target, intent(inout) :: table + !> The global settings which can be filled with the registry settings. + type(fpm_global_settings), intent(inout) :: global_settings + !> Error handling. + type(error_t), allocatable, intent(out) :: error + + character(:), allocatable :: path, url, cache_path + integer :: stat + + !> List of valid keys for the dependency table. + character(*), dimension(*), parameter :: valid_keys = [character(10) :: & + & 'path', & + & 'url', & + & 'cache_path' & + & ] + + call check_keys(table, valid_keys, error) + if (allocated(error)) return + + allocate (global_settings%registry_settings) + + if (table%has_key('path')) then + call get_value(table, 'path', path, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Error reading registry path: '"//path//"'."); return + end if + end if + + if (allocated(path)) then + if (is_absolute_path(path)) then + global_settings%registry_settings%path = path + else + ! Get canonical, absolute path on both Unix and Windows. + call get_absolute_path(join_path(global_settings%path_to_config_folder_or_empty(), path), & + & global_settings%registry_settings%path, error) + if (allocated(error)) return + + ! Check if the path to the registry exists. + if (.not. exists(global_settings%registry_settings%path)) then + call fatal_error(error, "Directory '"//global_settings%registry_settings%path// & + & "' doesn't exist."); return + end if + end if + end if + + if (table%has_key('url')) then + call get_value(table, 'url', url, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Error reading registry url: '"//url//"'."); return + end if + end if + + if (allocated(url)) then + ! Throw error when both path and url were provided. + if (allocated(path)) then + call fatal_error(error, 'Do not provide both path and url to the registry.'); return + end if + global_settings%registry_settings%url = url + else if (.not. allocated(path)) then + global_settings%registry_settings%url = official_registry_base_url + end if + + if (table%has_key('cache_path')) then + call get_value(table, 'cache_path', cache_path, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Error reading path to registry cache: '"//cache_path//"'."); return + end if + end if + + if (allocated(cache_path)) then + ! Throw error when both path and cache_path were provided. + if (allocated(path)) then + call fatal_error(error, "Do not provide both 'path' and 'cache_path'."); return + end if + + if (is_absolute_path(cache_path)) then + if (.not. exists(cache_path)) call mkdir(cache_path) + global_settings%registry_settings%cache_path = cache_path + else + cache_path = join_path(global_settings%path_to_config_folder_or_empty(), cache_path) + if (.not. exists(cache_path)) call mkdir(cache_path) + ! Get canonical, absolute path on both Unix and Windows. + call get_absolute_path(cache_path, global_settings%registry_settings%cache_path, error) + if (allocated(error)) return + end if + else if (.not. allocated(path)) then + global_settings%registry_settings%cache_path = & + join_path(global_settings%path_to_config_folder_or_empty(), 'dependencies') + end if + end + + !> True if the global config file is not at the default location. + elemental logical function has_custom_location(self) + class(fpm_global_settings), intent(in) :: self + + has_custom_location = allocated(self%path_to_config_folder) .and. allocated(self%config_file_name) + if (.not. has_custom_location) return + has_custom_location = len_trim(self%path_to_config_folder) > 0 .and. len_trim(self%config_file_name) > 0 + end + + !> The full path to the global config file. + function full_path(self) result(result) + class(fpm_global_settings), intent(in) :: self + character(len=:), allocatable :: result + + result = join_path(self%path_to_config_folder_or_empty(), self%config_file_name) + end + + !> The path to the global config directory. + pure function path_to_config_folder_or_empty(self) + class(fpm_global_settings), intent(in) :: self + character(len=:), allocatable :: path_to_config_folder_or_empty + + if (allocated(self%path_to_config_folder)) then + path_to_config_folder_or_empty = self%path_to_config_folder + else + path_to_config_folder_or_empty = "" + end if + end +end + +!>>>>> ././src/fpm/git.f90 + +!> Implementation for interacting with git repositories. +module fpm_git + use fpm_error, only: error_t, fatal_error + use fpm_filesystem, only : get_temp_filename, getline, join_path, execute_and_read_output, run + use fpm_toml, only: serializable_t, toml_table, get_value, set_value, toml_stat, set_string + implicit none + + public :: git_target_t, git_target_default, git_target_branch, git_target_tag, git_target_revision, git_revision, & + & git_archive, git_matches_manifest, operator(==), compressed_package_name + + !> Name of the compressed package that is generated temporarily. + character(len=*), parameter :: compressed_package_name = 'compressed_package' + + !> Possible git target + type :: enum_descriptor + + !> Default target + integer :: default = 200 + + !> Branch in git repository + integer :: branch = 201 + + !> Tag in git repository + integer :: tag = 202 + + !> Commit hash + integer :: revision = 203 + + !> Invalid descriptor + integer :: error = -999 + + end type enum_descriptor + + !> Actual enumerator for descriptors + type(enum_descriptor), parameter :: git_descriptor = enum_descriptor() + + !> Description of an git target + type, extends(serializable_t) :: git_target_t + + !> Kind of the git target + integer :: descriptor = git_descriptor%default + + !> Target URL of the git repository + character(len=:), allocatable :: url + + !> Additional descriptor of the git object + character(len=:), allocatable :: object + + contains + + !> Fetch and checkout in local directory + procedure :: checkout + + !> Show information on instance + procedure :: info + + !> Serialization interface + procedure :: serializable_is_same => git_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + + end type git_target_t + + !> Common output format for writing to the command line + character(len=*), parameter :: out_fmt = '("#", *(1x, g0))' + +contains + + !> Default target + function git_target_default(url) result(self) + + !> Target URL of the git repository + character(len=*), intent(in) :: url + + !> New git target + type(git_target_t) :: self + + self%descriptor = git_descriptor%default + self%url = url + + end function git_target_default + + !> Target a branch in the git repository + function git_target_branch(url, branch) result(self) + + !> Target URL of the git repository + character(len=*), intent(in) :: url + + !> Name of the branch of interest + character(len=*), intent(in) :: branch + + !> New git target + type(git_target_t) :: self + + self%descriptor = git_descriptor%branch + self%url = url + self%object = branch + + end function git_target_branch + + !> Target a specific git revision + function git_target_revision(url, sha1) result(self) + + !> Target URL of the git repository + character(len=*), intent(in) :: url + + !> Commit hash of interest + character(len=*), intent(in) :: sha1 + + !> New git target + type(git_target_t) :: self + + self%descriptor = git_descriptor%revision + self%url = url + self%object = sha1 + + end function git_target_revision + + !> Target a git tag + function git_target_tag(url, tag) result(self) + + !> Target URL of the git repository + character(len=*), intent(in) :: url + + !> Tag name of interest + character(len=*), intent(in) :: tag + + !> New git target + type(git_target_t) :: self + + self%descriptor = git_descriptor%tag + self%url = url + self%object = tag + + end function git_target_tag + + !> Check that two git targets are equal + logical function git_is_same(this,that) + class(git_target_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + git_is_same = .false. + + select type (other=>that) + type is (git_target_t) + + if (.not.(this%descriptor==other%descriptor)) return + if (.not.(this%url==other%url)) return + if (.not.(this%object==other%object)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + git_is_same = .true. + + end function git_is_same + + !> Check that a cached dependency matches a manifest request + logical function git_matches_manifest(cached,manifest,verbosity,iunit) + + !> Two input git targets + type(git_target_t), intent(in) :: cached,manifest + + integer, intent(in) :: verbosity,iunit + + git_matches_manifest = cached%url == manifest%url + if (.not.git_matches_manifest) then + if (verbosity>1) write(iunit,out_fmt) "GIT URL has changed: ",cached%url," vs. ", manifest%url + return + endif + + !> The manifest dependency only contains partial information (what's requested), + !> while the cached dependency always stores a commit hash because it's built + !> after the repo is available (saved as git_descriptor%revision==revision). + !> So, comparing against the descriptor is not reliable + git_matches_manifest = allocated(cached%object) .eqv. allocated(manifest%object) + if (git_matches_manifest .and. allocated(cached%object)) & + git_matches_manifest = cached%object == manifest%object + if (.not.git_matches_manifest) then + if (verbosity>1) write(iunit,out_fmt) "GIT OBJECT has changed: ",cached%object," vs. ", manifest%object + end if + + end function git_matches_manifest + + subroutine checkout(self, local_path, error) + + !> Instance of the git target + class(git_target_t), intent(in) :: self + + !> Local path to checkout in + character(*), intent(in) :: local_path + + !> Error + type(error_t), allocatable, intent(out) :: error + + integer :: stat + character(len=:), allocatable :: object, workdir + + if (allocated(self%object)) then + object = self%object + else + object = 'HEAD' + end if + workdir = "--work-tree="//local_path//" --git-dir="//join_path(local_path, ".git") + + call execute_command_line("git init "//local_path, exitstat=stat) + + if (stat /= 0) then + call fatal_error(error,'Error while initiating git repository for remote dependency') + return + end if + + call execute_command_line("git "//workdir//" fetch --depth=1 "// & + self%url//" "//object, exitstat=stat) + + if (stat /= 0) then + call fatal_error(error,'Error while fetching git repository for remote dependency') + return + end if + + call execute_command_line("git "//workdir//" checkout -qf FETCH_HEAD", exitstat=stat) + + if (stat /= 0) then + call fatal_error(error,'Error while checking out git repository for remote dependency') + return + end if + + end subroutine checkout + + subroutine git_revision(local_path, object, error) + + !> Local path to checkout in + character(*), intent(in) :: local_path + + !> Git object reference + character(len=:), allocatable, intent(out) :: object + + !> Error + type(error_t), allocatable, intent(out) :: error + + integer :: stat, unit, istart, iend + character(len=:), allocatable :: temp_file, line, iomsg, workdir + character(len=*), parameter :: hexdigits = '0123456789abcdef' + + workdir = "--work-tree="//local_path//" --git-dir="//join_path(local_path, ".git") + allocate(temp_file, source=get_temp_filename()) + line = "git "//workdir//" log -n 1 > "//temp_file + call execute_command_line(line, exitstat=stat) + + if (stat /= 0) then + call fatal_error(error, "Error while retrieving commit information") + return + end if + + open(file=temp_file, newunit=unit) + call getline(unit, line, stat, iomsg) + + if (stat /= 0) then + call fatal_error(error, iomsg) + return + end if + close(unit, status="delete") + + ! Tokenize: + ! commit 0123456789abcdef (HEAD, ...) + istart = scan(line, ' ') + 1 + iend = verify(line(istart:), hexdigits) + istart - 1 + if (iend < istart) iend = len(line) + object = line(istart:iend) + + end subroutine git_revision + + !> Show information on git target + subroutine info(self, unit, verbosity) + + !> Instance of the git target + class(git_target_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Git target" + if (allocated(self%url)) then + write(unit, fmt) "- URL", self%url + end if + if (allocated(self%object)) then + select case(self%descriptor) + case default + write(unit, fmt) "- object", self%object + case(git_descriptor%tag) + write(unit, fmt) "- tag", self%object + case(git_descriptor%branch) + write(unit, fmt) "- branch", self%object + case(git_descriptor%revision) + write(unit, fmt) "- sha1", self%object + end select + end if + + end subroutine info + + !> Dump dependency to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(git_target_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr + + call set_string(table, "descriptor", descriptor_name(self%descriptor), error, 'git_target_t') + if (allocated(error)) return + call set_string(table, "url", self%url, error, 'git_target_t') + if (allocated(error)) return + call set_string(table, "object", self%object, error, 'git_target_t') + if (allocated(error)) return + + end subroutine dump_to_toml + + !> Read dependency from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(git_target_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + character(len=:), allocatable :: descriptor_name + + call get_value(table, "descriptor", descriptor_name) + self%descriptor = parse_descriptor(descriptor_name) + + if (self%descriptor==git_descriptor%error) then + call fatal_error(error,"invalid descriptor ID <"//descriptor_name//"> in TOML entry") + return + end if + + !> Target URL of the git repository + call get_value(table, "url", self%url) + + !> Additional descriptor of the git object + call get_value(table,"object", self%object) + + end subroutine load_from_toml + + !> Parse git descriptor identifier from a string + pure integer function parse_descriptor(name) + character(len=*), intent(in) :: name + + select case (name) + case ("default"); parse_descriptor = git_descriptor%default + case ("branch"); parse_descriptor = git_descriptor%branch + case ("tag"); parse_descriptor = git_descriptor%tag + case ("revision"); parse_descriptor = git_descriptor%revision + case default; parse_descriptor = git_descriptor%error + end select + + end function parse_descriptor + + !> Code git descriptor to a string + pure function descriptor_name(descriptor) result(name) + integer, intent(in) :: descriptor + character(len=:), allocatable :: name + + select case (descriptor) + case (git_descriptor%default); name = "default" + case (git_descriptor%branch); name = "branch" + case (git_descriptor%tag); name = "tag" + case (git_descriptor%revision); name = "revision" + case default; name = "ERROR" + end select + + end function descriptor_name + + !> Archive a folder using `git archive`. + subroutine git_archive(source, destination, ref, additional_files, verbose, error) + !> Directory to archive. + character(*), intent(in) :: source + !> Destination of the archive. + character(*), intent(in) :: destination + !> (Symbolic) Reference to be archived. + character(*), intent(in) :: ref + !> (Optional) list of additional untracked files to be added to the archive. + character(*), optional, intent(in) :: additional_files(:) + !> Print additional information if true. + logical, intent(in) :: verbose + !> Error handling. + type(error_t), allocatable, intent(out) :: error + + integer :: stat,i + character(len=:), allocatable :: cmd_output, archive_format, add_files + + call execute_and_read_output('git archive -l', cmd_output, error, verbose) + if (allocated(error)) return + + if (index(cmd_output, 'tar.gz') /= 0) then + archive_format = 'tar.gz' + else + call fatal_error(error, "Cannot find a suitable archive format for 'git archive'."); return + end if + + allocate(character(len=0) :: add_files) + if (present(additional_files)) then + do i=1,size(additional_files) + add_files = trim(add_files)//' --add-file='//adjustl(additional_files(i)) + end do + endif + + call run('git archive '//ref//' & + & --format='//archive_format// & + & add_files//' & + & -o '//destination, & + & echo=verbose, & + & exitstat=stat) + + if (stat /= 0) then + call fatal_error(error, "Error packing '"//source//"'."); return + end if + end + +end module fpm_git + +!>>>>> ././src/fpm/manifest/build.f90 + +!> Implementation of the build configuration data. +!> +!> A build table can currently have the following fields +!> +!>```toml +!>[build] +!>auto-executables = bool +!>auto-examples = bool +!>auto-tests = bool +!>link = ["lib"] +!>``` +module fpm_manifest_build + use fpm_error, only : error_t, syntax_error, fatal_error + use fpm_strings, only : string_t, len_trim, is_valid_module_prefix, operator(==) + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list, serializable_t, & + set_value, set_string, set_list + implicit none + private + + public :: build_config_t, new_build_config + + !> Configuration data for build + type, extends(serializable_t) :: build_config_t + + !> Automatic discovery of executables + logical :: auto_executables = .true. + + !> Automatic discovery of examples + logical :: auto_examples = .true. + + !> Automatic discovery of tests + logical :: auto_tests = .true. + + !> Enforcing of package module names + logical :: module_naming = .false. + type(string_t) :: module_prefix + + !> Libraries to link against + type(string_t), allocatable :: link(:) + + !> External modules to use + type(string_t), allocatable :: external_modules(:) + + contains + + !> Print information on this instance + procedure :: info + + !> Serialization interface + procedure :: serializable_is_same => build_conf_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + + end type build_config_t + + character(*), parameter, private :: class_name = 'build_config_t' + +contains + + !> Construct a new build configuration from a TOML data structure + subroutine new_build_config(self, table, package_name, error) + + !> Instance of the build configuration + type(build_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Package name + character(len=*), intent(in) :: package_name + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: stat + + call check(table, package_name, error) + if (allocated(error)) return + + call get_value(table, "auto-executables", self%auto_executables, .true., stat=stat) + + if (stat /= toml_stat%success) then + call fatal_error(error,"Error while reading value for 'auto-executables' in fpm.toml, expecting logical") + return + end if + + call get_value(table, "auto-tests", self%auto_tests, .true., stat=stat) + + if (stat /= toml_stat%success) then + call fatal_error(error,"Error while reading value for 'auto-tests' in fpm.toml, expecting logical") + return + end if + + call get_value(table, "auto-examples", self%auto_examples, .true., stat=stat) + + if (stat /= toml_stat%success) then + call fatal_error(error,"Error while reading value for 'auto-examples' in fpm.toml, expecting logical") + return + end if + + !> Module naming: fist, attempt boolean value first + call get_value(table, "module-naming", self%module_naming, .false., stat=stat) + + if (stat == toml_stat%success) then + + ! Boolean value found. Set no custom prefix. This also falls back to key not provided + if (allocated(self%module_prefix%s)) deallocate(self%module_prefix%s) + + else + + !> Value found, but not a boolean. Attempt to read a prefix string + call get_value(table, "module-naming", self%module_prefix%s) + + if (.not.allocated(self%module_prefix%s)) then + call syntax_error(error,"Could not read value for 'module-naming' in fpm.toml, expecting logical or a string") + return + end if + + if (.not.is_valid_module_prefix(self%module_prefix)) then + call syntax_error(error,"Invalid custom module name prefix for in fpm.toml: <"//self%module_prefix%s// & + ">, expecting a valid alphanumeric string") + return + end if + + ! Set module naming to ON + self%module_naming = .true. + + end if + + call get_list(table, "link", self%link, error) + if (allocated(error)) return + + call get_list(table, "external-modules", self%external_modules, error) + if (allocated(error)) return + + end subroutine new_build_config + + !> Check local schema for allowed entries + subroutine check(table, package_name, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Package name + character(len=*), intent(in) :: package_name + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + integer :: ikey + + call table%get_keys(list) + + ! table can be empty + if (size(list) < 1) return + + do ikey = 1, size(list) + select case(list(ikey)%key) + + case("auto-executables", "auto-examples", "auto-tests", "link", "external-modules", "module-naming") + continue + + case default + + call syntax_error(error, 'Manifest file syntax error: key "'//list(ikey)%key//'" found in the [build] '//& + 'section of package/dependency "'//package_name//'" fpm.toml is not allowed') + exit + + end select + end do + + end subroutine check + + !> Write information on build configuration instance + subroutine info(self, unit, verbosity) + + !> Instance of the build configuration + class(build_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr, ilink, imod + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Build configuration" + write(unit, fmt) " - auto-discovery (apps) ", merge("enabled ", "disabled", self%auto_executables) + write(unit, fmt) " - auto-discovery (examples) ", merge("enabled ", "disabled", self%auto_examples) + write(unit, fmt) " - auto-discovery (tests) ", merge("enabled ", "disabled", self%auto_tests) + write(unit, fmt) " - enforce module naming ", merge("enabled ", "disabled", self%module_naming) + if (allocated(self%link)) then + write(unit, fmt) " - link against" + do ilink = 1, size(self%link) + write(unit, fmt) " - " // self%link(ilink)%s + end do + end if + if (allocated(self%external_modules)) then + write(unit, fmt) " - external modules" + do imod = 1, size(self%external_modules) + write(unit, fmt) " - " // self%external_modules(imod)%s + end do + end if + + end subroutine info + + !> Check that two dependency trees are equal + logical function build_conf_is_same(this,that) + class(build_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + build_conf_is_same = .false. + + select type (other=>that) + type is (build_config_t) + + if (this%auto_executables.neqv.other%auto_executables) return + if (this%auto_examples.neqv.other%auto_examples) return + if (this%auto_tests.neqv.other%auto_tests) return + if (this%module_naming.neqv.other%module_naming) return + if (.not.this%module_prefix==other%module_prefix) return + if (.not.this%link==other%link) return + if (.not.this%external_modules==other%external_modules) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + build_conf_is_same = .true. + + end function build_conf_is_same + + !> Dump build config to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(build_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_value(table, "auto-executables", self%auto_executables, error, class_name) + if (allocated(error)) return + call set_value(table, "auto-tests", self%auto_tests, error, class_name) + if (allocated(error)) return + call set_value(table, "auto-examples", self%auto_examples, error, class_name) + if (allocated(error)) return + + ! Module naming can either contain a boolean value, or the prefix + has_prefix: if (self%module_naming .and. len_trim(self%module_prefix)>0) then + call set_string(table, "module-naming", self%module_prefix, error, class_name) + else + call set_value (table, "module-naming", self%module_naming, error, class_name) + end if has_prefix + if (allocated(error)) return + + call set_list(table, "link", self%link, error) + if (allocated(error)) return + call set_list(table, "external-modules", self%external_modules, error) + if (allocated(error)) return + + end subroutine dump_to_toml + + !> Read build config from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(build_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: stat + + call get_value(table, "auto-executables", self%auto_executables, error, class_name) + if (allocated(error)) return + call get_value(table, "auto-tests", self%auto_tests, error, class_name) + if (allocated(error)) return + call get_value(table, "auto-examples", self%auto_examples, error, class_name) + if (allocated(error)) return + + !> Module naming: fist, attempt boolean value first + call get_value(table, "module-naming", self%module_naming, .false., stat=stat) + if (stat == toml_stat%success) then + ! Boolean value found. Set no custom prefix. This also falls back to key not provided + if (allocated(self%module_prefix%s)) deallocate(self%module_prefix%s) + else + !> Value found, but not a boolean. Attempt to read a prefix string + call get_value(table, "module-naming", self%module_prefix%s) + if (.not.allocated(self%module_prefix%s)) then + call syntax_error(error,"Could not read value for 'module-naming' in fpm.toml, expecting logical or a string") + return + end if + self%module_naming = .true. + end if + + call get_list(table, "link", self%link, error) + if (allocated(error)) return + call get_list(table, "external-modules", self%external_modules, error) + if (allocated(error)) return + + end subroutine load_from_toml + +end module fpm_manifest_build + +!>>>>> ././src/fpm/manifest/fortran.f90 + +module fpm_manifest_fortran + use fpm_error, only : error_t, syntax_error, fatal_error + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, serializable_t, set_value, set_string + implicit none + private + + public :: fortran_config_t, new_fortran_config + + !> Configuration data for Fortran + type, extends(serializable_t) :: fortran_config_t + + !> Enable default implicit typing + logical :: implicit_typing = .false. + + !> Enable implicit external interfaces + logical :: implicit_external = .false. + + !> Form to use for all Fortran sources + character(:), allocatable :: source_form + + contains + + !> Serialization interface + procedure :: serializable_is_same => fortran_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + + end type fortran_config_t + + character(len=*), parameter, private :: class_name = 'fortran_config_t' + +contains + + !> Construct a new build configuration from a TOML data structure + subroutine new_fortran_config(self, table, error) + + !> Instance of the fortran configuration + type(fortran_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: stat + character(:), allocatable :: source_form + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "implicit-typing", self%implicit_typing, .false., stat=stat) + + if (stat /= toml_stat%success) then + call fatal_error(error,"Error while reading value for 'implicit-typing' in fpm.toml, expecting logical") + return + end if + + call get_value(table, "implicit-external", self%implicit_external, .false., stat=stat) + + if (stat /= toml_stat%success) then + call fatal_error(error,"Error while reading value for 'implicit-external' in fpm.toml, expecting logical") + return + end if + + call get_value(table, "source-form", source_form, "free", stat=stat) + + if (stat /= toml_stat%success) then + call fatal_error(error,"Error while reading value for 'source-form' in fpm.toml, expecting logical") + return + end if + select case(source_form) + case default + call fatal_error(error,"Value of source-form cannot be '"//source_form//"'") + return + case("free", "fixed", "default") + self%source_form = source_form + end select + + end subroutine new_fortran_config + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + integer :: ikey + + call table%get_keys(list) + + ! table can be empty + if (size(list) < 1) return + + do ikey = 1, size(list) + select case(list(ikey)%key) + + case("implicit-typing", "implicit-external", "source-form") + continue + + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in fortran") + exit + + end select + end do + + end subroutine check + + logical function fortran_is_same(this,that) + class(fortran_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + fortran_is_same = .false. + + select type (other=>that) + type is (fortran_config_t) + if (this%implicit_typing.neqv.other%implicit_typing) return + if (this%implicit_external.neqv.other%implicit_external) return + if (.not.allocated(this%source_form).eqv.allocated(other%source_form)) return + if (.not.this%source_form==other%source_form) return + class default + ! Not the same type + return + end select + + !> All checks passed! + fortran_is_same = .true. + + end function fortran_is_same + + !> Dump install config to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(fortran_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_value(table, "implicit-typing", self%implicit_typing, error, class_name) + if (allocated(error)) return + call set_value(table, "implicit-external", self%implicit_external, error, class_name) + if (allocated(error)) return + call set_string(table, "source-form", self%source_form, error, class_name) + if (allocated(error)) return + + end subroutine dump_to_toml + + !> Read install config from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(fortran_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call get_value(table, "implicit-typing", self%implicit_typing, error, class_name) + if (allocated(error)) return + call get_value(table, "implicit-external", self%implicit_external, error, class_name) + if (allocated(error)) return + call get_value(table, "source-form", self%source_form) + + end subroutine load_from_toml + +end module fpm_manifest_fortran + +!>>>>> ././src/fpm/manifest/install.f90 + +!> Implementation of the installation configuration. +!> +!> An install table can currently have the following fields +!> +!>```toml +!>library = bool +!>``` +module fpm_manifest_install + use fpm_error, only : error_t, fatal_error, syntax_error + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, set_value, serializable_t + implicit none + private + + public :: install_config_t, new_install_config + + !> Configuration data for installation + type, extends(serializable_t) :: install_config_t + + !> Install library with this project + logical :: library = .false. + + !> Install tests with this project + logical :: test = .false. + + contains + + !> Print information on this instance + procedure :: info + + !> Serialization interface + procedure :: serializable_is_same => install_conf_same + procedure :: dump_to_toml + procedure :: load_from_toml + + end type install_config_t + + character(*), parameter, private :: class_name = 'install_config_t' + +contains + + !> Create a new installation configuration from a TOML data structure + subroutine new_install_config(self, table, error) + + !> Instance of the install configuration + type(install_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "library", self%library, .false.) + call get_value(table, "test", self%test, .false.) + + end subroutine new_install_config + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + integer :: ikey + + call table%get_keys(list) + if (size(list) < 1) return + + do ikey = 1, size(list) + select case(list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in install table") + exit + case("library","test") + continue + end select + end do + if (allocated(error)) return + + end subroutine check + + !> Write information on install configuration instance + subroutine info(self, unit, verbosity) + + !> Instance of the build configuration + class(install_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Install configuration" + write(unit, fmt) " - library install", trim(merge("enabled ", "disabled", self%library)) + write(unit, fmt) " - test install", trim(merge("enabled ", "disabled", self%test)) + + end subroutine info + + logical function install_conf_same(this,that) + class(install_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + install_conf_same = .false. + + select type (other=>that) + type is (install_config_t) + if (this%library.neqv.other%library) return + if (this%test.neqv.other%test) return + class default + ! Not the same type + return + end select + + !> All checks passed! + install_conf_same = .true. + + end function install_conf_same + + !> Dump install config to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(install_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_value(table, "library", self%library, error, class_name) + if (allocated(error)) return + + call set_value(table, "test", self%test, error, class_name) + if (allocated(error)) return + + end subroutine dump_to_toml + + !> Read install config from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(install_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: stat + + call get_value(table, "library", self%library, error, class_name) + if (allocated(error)) return + call get_value(table, "test", self%test, error, class_name) + if (allocated(error)) return + + end subroutine load_from_toml + +end module fpm_manifest_install + +!>>>>> ././src/fpm/manifest/library.f90 + +!> Implementation of the meta data for libraries. +!> +!> A library table can currently have the following fields +!> +!>```toml +!>[library] +!>source-dir = "path" +!>include-dir = ["path1","path2"] +!>build-script = "file" +!>``` +module fpm_manifest_library + use fpm_error, only : error_t, syntax_error + use fpm_strings, only: string_t, string_cat, operator(==) + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list, serializable_t, set_value, & + set_list, set_string, get_value, has_list + implicit none + private + + public :: library_config_t, new_library + + !> Configuration meta data for a library + type, extends(serializable_t) :: library_config_t + + !> Source path prefix + character(len=:), allocatable :: source_dir + + !> Include path prefix + type(string_t), allocatable :: include_dir(:) + + !> Alternative build script to be invoked + character(len=:), allocatable :: build_script + + contains + + !> Print information on this instance + procedure :: info + + !> Serialization interface + procedure :: serializable_is_same => library_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + + end type library_config_t + + character(*), parameter, private :: class_name = 'library_config_t' + +contains + + !> Construct a new library configuration from a TOML data structure + subroutine new_library(self, table, error) + + !> Instance of the library configuration + type(library_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call check(table, error) + if (allocated(error)) return + + if (has_list(table, "source-dir")) then + call syntax_error(error, "Manifest key [library.source-dir] does not allow list input") + return + end if + + call get_value(table, "source-dir", self%source_dir, "src") + call get_value(table, "build-script", self%build_script) + + call get_list(table, "include-dir", self%include_dir, error) + if (allocated(error)) return + + ! Set default value of include-dir if not found in manifest + if (.not.allocated(self%include_dir)) then + self%include_dir = [string_t("include")] + end if + + end subroutine new_library + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + integer :: ikey + + call table%get_keys(list) + + ! table can be empty + if (size(list) < 1) return + + do ikey = 1, size(list) + select case(list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in library") + exit + + case("source-dir", "include-dir", "build-script") + continue + + end select + end do + + end subroutine check + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the library configuration + class(library_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Library target" + if (allocated(self%source_dir)) then + write(unit, fmt) "- source directory", self%source_dir + end if + if (allocated(self%include_dir)) then + write(unit, fmt) "- include directory", string_cat(self%include_dir,",") + end if + if (allocated(self%build_script)) then + write(unit, fmt) "- custom build", self%build_script + end if + + end subroutine info + + logical function library_is_same(this,that) + class(library_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + library_is_same = .false. + + select type (other=>that) + type is (library_config_t) + if (.not.this%include_dir==other%include_dir) return + if (.not.allocated(this%source_dir).eqv.allocated(other%source_dir)) return + if (.not.this%source_dir==other%source_dir) return + if (.not.allocated(this%build_script).eqv.allocated(other%build_script)) return + if (.not.this%build_script==other%build_script) return + class default + ! Not the same type + return + end select + + !> All checks passed! + library_is_same = .true. + + end function library_is_same + + !> Dump install config to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(library_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_string(table, "source-dir", self%source_dir, error, class_name) + if (allocated(error)) return + call set_string(table, "build-script", self%build_script, error, class_name) + if (allocated(error)) return + call set_list(table, "include-dir", self%include_dir, error) + if (allocated(error)) return + + end subroutine dump_to_toml + + !> Read install config from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(library_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call get_value(table, "source-dir", self%source_dir) + if (allocated(error)) return + call get_value(table, "build-script", self%build_script) + if (allocated(error)) return + call get_list(table, "include-dir", self%include_dir, error) + + end subroutine load_from_toml + +end module fpm_manifest_library + +!>>>>> ././src/fpm/manifest/meta.f90 + +!> Implementation of the metapackage configuration data. +!> +!> A metapackage table can currently have the following fields +!> +!>```toml +!>[metapackages] +!>fpm = "0.1.0" +!>openmp = bool +!>stdlib = bool +!>``` +module fpm_manifest_metapackages + use fpm_error, only: error_t, fatal_error, syntax_error + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value + use fpm_environment + implicit none + private + + public :: metapackage_config_t, new_meta_config, is_meta_package + public :: metapackage_request_t, new_meta_request + + !> Configuration data for a single metapackage request + type :: metapackage_request_t + + !> Request flag + logical :: on = .false. + + !> Metapackage name + character(len=:), allocatable :: name + + !> Version Specification string + character(len=:), allocatable :: version + + end type metapackage_request_t + + !> Configuration data for metapackages + type :: metapackage_config_t + + !> Request MPI support + type(metapackage_request_t) :: mpi + + !> Request OpenMP support + type(metapackage_request_t) :: openmp + + !> Request stdlib support + type(metapackage_request_t) :: stdlib + + !> fortran-lang minpack + type(metapackage_request_t) :: minpack + + !> HDF5 + type(metapackage_request_t) :: hdf5 + + end type metapackage_config_t + +contains + + !> Destroy a metapackage request + elemental subroutine request_destroy(self) + + !> Instance of the request + class(metapackage_request_t), intent(inout) :: self + + self%on = .false. + if (allocated(self%version)) deallocate(self%version) + if (allocated(self%name)) deallocate(self%name) + + end subroutine request_destroy + + !> Parse version string of a metapackage request + subroutine request_parse(self, version_request, error) + + ! Instance of this metapackage + type(metapackage_request_t), intent(inout) :: self + + ! Parse version request + character(len=*), intent(in) :: version_request + + ! Error message + type(error_t), allocatable, intent(out) :: error + + ! wildcard = use any versions + if (version_request=="*") then + + ! Any version is OK + self%on = .true. + self%version = version_request + + else + + call fatal_error(error,'Value <'//version_request//'> for metapackage '//self%name//& + 'is not currently supported. Try "*" instead. ') + return + + end if + + end subroutine request_parse + + !> Construct a new metapackage request from the dependencies table + subroutine new_meta_request(self, key, table, meta_allowed, error) + + type(metapackage_request_t), intent(out) :: self + + !> The package name + character(len=*), intent(in) :: key + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> List of keys allowed to be metapackages + logical, intent(in), optional :: meta_allowed(:) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: stat,i + character(len=:), allocatable :: value + logical, allocatable :: allow_meta(:) + type(toml_key), allocatable :: keys(:) + + call request_destroy(self) + + !> Set name + self%name = key + if (.not.is_meta_package(key)) then + call fatal_error(error,"Error reading fpm.toml: <"//key//"> is not a valid metapackage name") + return + end if + + !> The toml table is not checked here because it already passed + !> the "new_dependencies" check + + call table%get_keys(keys) + + !> Set list of entries that are allowed to be metapackages + if (present(meta_allowed)) then + if (size(meta_allowed)/=size(keys)) then + call fatal_error(error,"Internal error: list of metapackage-enable entries does not match table size") + return + end if + allow_meta = meta_allowed + else + allocate(allow_meta(size(keys)),source=.true.) + endif + + do i=1,size(keys) + + ! Skip standard dependencies + if (.not.allow_meta(i)) cycle + + if (keys(i)%key==key) then + call get_value(table, key, value) + if (.not. allocated(value)) then + call syntax_error(error, "Could not retrieve version string for metapackage key <"//key//">. Check syntax") + return + else + call request_parse(self, value, error) + return + endif + end if + end do + + ! Key is not present, metapackage not requested + return + + end subroutine new_meta_request + + !> Construct a new build configuration from a TOML data structure + subroutine new_meta_config(self, table, meta_allowed, error) + + !> Instance of the build configuration + type(metapackage_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> List of keys allowed to be metapackages + logical, intent(in) :: meta_allowed(:) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: stat + + !> The toml table is not checked here because it already passed + !> the "new_dependencies" check + call new_meta_request(self%openmp, "openmp", table, meta_allowed, error) + if (allocated(error)) return + + call new_meta_request(self%stdlib, "stdlib", table, meta_allowed, error) + if (allocated(error)) return + + call new_meta_request(self%minpack, "minpack", table, meta_allowed, error) + if (allocated(error)) return + + call new_meta_request(self%mpi, "mpi", table, meta_allowed, error) + if (allocated(error)) return + + call new_meta_request(self%hdf5, "hdf5", table, meta_allowed, error) + if (allocated(error)) return + + end subroutine new_meta_config + + !> Check local schema for allowed entries + logical function is_meta_package(key) + + !> Instance of the TOML data structure + character(*), intent(in) :: key + + select case (key) + + !> Supported metapackages + case ("openmp","stdlib","mpi","minpack","hdf5") + is_meta_package = .true. + + case default + is_meta_package = .false. + + end select + + end function is_meta_package + +end module fpm_manifest_metapackages + +!>>>>> ././src/fpm/manifest/preprocess.f90 + +!> Implementation of the meta data for preprocessing. +!> +!> A preprocess table can currently have the following fields +!> +!> ```toml +!> [preprocess] +!> [preprocess.cpp] +!> suffixes = ["F90", "f90"] +!> directories = ["src/feature1", "src/models"] +!> macros = [] +!> ``` + +module fpm_manifest_preprocess + use fpm_error, only : error_t, syntax_error + use fpm_strings, only : string_t, operator(==) + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list, serializable_t, set_value, set_list, & + set_string + use,intrinsic :: iso_fortran_env, only : stderr=>error_unit + implicit none + private + + public :: preprocess_config_t, new_preprocess_config, new_preprocessors, operator(==) + + !> Configuration meta data for a preprocessor + type, extends(serializable_t) :: preprocess_config_t + + !> Name of the preprocessor + character(len=:), allocatable :: name + + !> Suffixes of the files to be preprocessed + type(string_t), allocatable :: suffixes(:) + + !> Directories to search for files to be preprocessed + type(string_t), allocatable :: directories(:) + + !> Macros to be defined for the preprocessor + type(string_t), allocatable :: macros(:) + + contains + + !> Print information on this instance + procedure :: info + + !> Serialization interface + procedure :: serializable_is_same => preprocess_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + + !> Operations + procedure :: destroy + procedure :: add_config + + !> Properties + procedure :: is_cpp + procedure :: is_fypp + + end type preprocess_config_t + + character(*), parameter, private :: class_name = 'preprocess_config_t' + +contains + + !> Construct a new preprocess configuration from TOML data structure + subroutine new_preprocess_config(self, table, error) + + !> Instance of the preprocess configuration + type(preprocess_config_t), intent(out) :: self + + !> Instance of the TOML data structure. + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call check(table, error) + if (allocated(error)) return + + call table%get_key(self%name) + + call get_list(table, "suffixes", self%suffixes, error) + if (allocated(error)) return + + call get_list(table, "directories", self%directories, error) + if (allocated(error)) return + + call get_list(table, "macros", self%macros, error) + if (allocated(error)) return + + end subroutine new_preprocess_config + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure. + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(inout) :: error + + character(len=:), allocatable :: name + type(toml_key), allocatable :: list(:) + integer :: ikey + + call table%get_key(name) + call table%get_keys(list) + + do ikey = 1, size(list) + select case(list(ikey)%key) + !> Valid keys. + case("suffixes", "directories", "macros") + case default + call syntax_error(error, "Key '"//list(ikey)%key//"' not allowed in preprocessor '"//name//"'."); exit + end select + end do + end subroutine check + + !> Construct new preprocess array from a TOML data structure. + subroutine new_preprocessors(preprocessors, table, error) + + !> Instance of the preprocess configuration + type(preprocess_config_t), allocatable, intent(out) :: preprocessors(:) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), pointer :: node + type(toml_key), allocatable :: list(:) + integer :: iprep, stat + + call table%get_keys(list) + + ! An empty table is not allowed + if (size(list) == 0) then + call syntax_error(error, "No preprocessors defined") + end if + + allocate(preprocessors(size(list))) + do iprep = 1, size(list) + call get_value(table, list(iprep)%key, node, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "Preprocessor "//list(iprep)%key//" must be a table entry") + exit + end if + call new_preprocess_config(preprocessors(iprep), node, error) + if (allocated(error)) exit + end do + + end subroutine new_preprocessors + + !> Write information on this instance + subroutine info(self, unit, verbosity) + + !> Instance of the preprocess configuration + class(preprocess_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr, ilink + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Preprocessor" + if (allocated(self%name)) then + write(unit, fmt) "- name", self%name + end if + if (allocated(self%suffixes)) then + write(unit, fmt) " - suffixes" + do ilink = 1, size(self%suffixes) + write(unit, fmt) " - " // self%suffixes(ilink)%s + end do + end if + if (allocated(self%directories)) then + write(unit, fmt) " - directories" + do ilink = 1, size(self%directories) + write(unit, fmt) " - " // self%directories(ilink)%s + end do + end if + if (allocated(self%macros)) then + write(unit, fmt) " - macros" + do ilink = 1, size(self%macros) + write(unit, fmt) " - " // self%macros(ilink)%s + end do + end if + + end subroutine info + + logical function preprocess_is_same(this,that) + class(preprocess_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + integer :: istr + + preprocess_is_same = .false. + + select type (other=>that) + type is (preprocess_config_t) + if (allocated(this%name).neqv.allocated(other%name)) return + if (allocated(this%name)) then + if (.not.(this%name==other%name)) return + endif + + if (.not.(this%suffixes==other%suffixes)) return + if (.not.(this%directories==other%directories)) return + if (.not.(this%macros==other%macros)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + preprocess_is_same = .true. + + end function preprocess_is_same + + !> Dump install config to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(preprocess_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_string(table, "name", self%name, error) + if (allocated(error)) return + call set_list(table, "suffixes", self%suffixes, error) + if (allocated(error)) return + call set_list(table, "directories", self%directories, error) + if (allocated(error)) return + call set_list(table, "macros", self%macros, error) + if (allocated(error)) return + + end subroutine dump_to_toml + + !> Read install config from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(preprocess_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call get_value(table, "name", self%name) + call get_list(table, "suffixes", self%suffixes, error) + if (allocated(error)) return + call get_list(table, "directories", self%directories, error) + if (allocated(error)) return + call get_list(table, "macros", self%macros, error) + if (allocated(error)) return + + end subroutine load_from_toml + + !> Clean preprocessor structure + elemental subroutine destroy(this) + class(preprocess_config_t), intent(inout) :: this + + if (allocated(this%name))deallocate(this%name) + if (allocated(this%suffixes))deallocate(this%suffixes) + if (allocated(this%directories))deallocate(this%directories) + if (allocated(this%macros))deallocate(this%macros) + + end subroutine destroy + + !> Add preprocessor settings + subroutine add_config(this,that) + class(preprocess_config_t), intent(inout) :: this + type(preprocess_config_t), intent(in) :: that + + if (.not.that%is_cpp()) then + write(stderr, '(a)') 'Warning: Preprocessor ' // that%name // & + ' is not supported; will ignore it' + return + end if + + if (.not.allocated(this%name)) this%name = that%name + + ! Add macros + if (allocated(that%macros)) then + if (allocated(this%macros)) then + this%macros = [this%macros, that%macros] + else + allocate(this%macros, source = that%macros) + end if + endif + + ! Add suffixes + if (allocated(that%suffixes)) then + if (allocated(this%suffixes)) then + this%suffixes = [this%suffixes, that%suffixes] + else + allocate(this%suffixes, source = that%suffixes) + end if + endif + + ! Add directories + if (allocated(that%directories)) then + if (allocated(this%directories)) then + this%directories = [this%directories, that%directories] + else + allocate(this%directories, source = that%directories) + end if + endif + + end subroutine add_config + + ! Check cpp + logical function is_cpp(this) + class(preprocess_config_t), intent(in) :: this + is_cpp = .false. + if (allocated(this%name)) is_cpp = this%name == "cpp" + end function is_cpp + + ! Check cpp + logical function is_fypp(this) + class(preprocess_config_t), intent(in) :: this + is_fypp = .false. + if (allocated(this%name)) is_fypp = this%name == "fypp" + end function is_fypp + +end module fpm_manifest_preprocess + +!>>>>> ././src/fpm/manifest/profiles.f90 + +!> Implementation of the meta data for compiler flag profiles. +!> +!> A profiles table can currently have the following subtables: +!> Profile names - any string, if omitted, flags are appended to all matching profiles +!> Compiler - any from the following list, omitting it yields an error +!> +!> - "gfortran" +!> - "ifort" +!> - "ifx" +!> - "pgfortran" +!> - "nvfortran" +!> - "flang" +!> - "caf" +!> - "f95" +!> - "lfortran" +!> - "lfc" +!> - "nagfor" +!> - "crayftn" +!> - "xlf90" +!> - "ftn95" +!> +!> OS - any from the following list, if omitted, the profile is used if and only +!> if there is no profile perfectly matching the current configuration +!> +!> - "linux" +!> - "macos" +!> - "windows" +!> - "cygwin" +!> - "solaris" +!> - "freebsd" +!> - "openbsd" +!> - "unknown" +!> +!> Each of the subtables currently supports the following fields: +!>```toml +!>[profiles.debug.gfortran.linux] +!> flags="-Wall -g -Og" +!> c-flags="-g O1" +!> cxx-flags="-g O1" +!> link-time-flags="-xlinkopt" +!> files={"hello_world.f90"="-Wall -O3"} +!>``` +!> +module fpm_manifest_profile + use fpm_error, only : error_t, syntax_error, fatal_error, fpm_stop + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, serializable_t, set_value, & + set_string, add_table + use fpm_strings, only: lower + use fpm_environment, only: get_os_type, OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & + OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD, OS_NAME + use fpm_filesystem, only: join_path + implicit none + public :: profile_config_t, new_profile, new_profiles, get_default_profiles, & + & info_profile, find_profile, DEFAULT_COMPILER + + !> Name of the default compiler + character(len=*), parameter :: DEFAULT_COMPILER = 'gfortran' + integer, parameter :: OS_ALL = -1 + character(len=:), allocatable :: path + + !> Type storing file name - file scope compiler flags pairs + type, extends(serializable_t) :: file_scope_flag + + !> Name of the file + character(len=:), allocatable :: file_name + + !> File scope flags + character(len=:), allocatable :: flags + + contains + + !> Serialization interface + procedure :: serializable_is_same => file_scope_same + procedure :: dump_to_toml => file_scope_dump + procedure :: load_from_toml => file_scope_load + + end type file_scope_flag + + !> Configuration meta data for a profile + type, extends(serializable_t) :: profile_config_t + !> Name of the profile + character(len=:), allocatable :: profile_name + + !> Name of the compiler + character(len=:), allocatable :: compiler + + !> Value repesenting OS + integer :: os_type = OS_ALL + + !> Fortran compiler flags + character(len=:), allocatable :: flags + + !> C compiler flags + character(len=:), allocatable :: c_flags + + !> C++ compiler flags + character(len=:), allocatable :: cxx_flags + + !> Link time compiler flags + character(len=:), allocatable :: link_time_flags + + !> File scope flags + type(file_scope_flag), allocatable :: file_scope_flags(:) + + !> Is this profile one of the built-in ones? + logical :: is_built_in = .false. + + contains + + !> Print information on this instance + procedure :: info + + !> Serialization interface + procedure :: serializable_is_same => profile_same + procedure :: dump_to_toml => profile_dump + procedure :: load_from_toml => profile_load + + end type profile_config_t + + contains + + !> Construct a new profile configuration from a TOML data structure + function new_profile(profile_name, compiler, os_type, flags, c_flags, cxx_flags, & + link_time_flags, file_scope_flags, is_built_in) & + & result(profile) + + !> Name of the profile + character(len=*), intent(in) :: profile_name + + !> Name of the compiler + character(len=*), intent(in) :: compiler + + !> Type of the OS + integer, intent(in) :: os_type + + !> Fortran compiler flags + character(len=*), optional, intent(in) :: flags + + !> C compiler flags + character(len=*), optional, intent(in) :: c_flags + + !> C++ compiler flags + character(len=*), optional, intent(in) :: cxx_flags + + !> Link time compiler flags + character(len=*), optional, intent(in) :: link_time_flags + + !> File scope flags + type(file_scope_flag), optional, intent(in) :: file_scope_flags(:) + + !> Is this profile one of the built-in ones? + logical, optional, intent(in) :: is_built_in + + type(profile_config_t) :: profile + + profile%profile_name = profile_name + profile%compiler = compiler + profile%os_type = os_type + if (present(flags)) then + profile%flags = flags + else + profile%flags = "" + end if + if (present(c_flags)) then + profile%c_flags = c_flags + else + profile%c_flags = "" + end if + if (present(cxx_flags)) then + profile%cxx_flags = cxx_flags + else + profile%cxx_flags = "" + end if + if (present(link_time_flags)) then + profile%link_time_flags = link_time_flags + else + profile%link_time_flags = "" + end if + if (present(file_scope_flags)) then + profile%file_scope_flags = file_scope_flags + end if + if (present(is_built_in)) then + profile%is_built_in = is_built_in + else + profile%is_built_in = .false. + end if + + end function new_profile + + !> Check if compiler name is a valid compiler name + subroutine validate_compiler_name(compiler_name, is_valid) + + !> Name of a compiler + character(len=:), allocatable, intent(in) :: compiler_name + + !> Boolean value of whether compiler_name is valid or not + logical, intent(out) :: is_valid + select case(compiler_name) + case("gfortran", "ifort", "ifx", "pgfortran", "nvfortran", "flang", "caf", & + & "f95", "lfortran", "lfc", "nagfor", "crayftn", "xlf90", "ftn95") + is_valid = .true. + case default + is_valid = .false. + end select + end subroutine validate_compiler_name + + !> Check if os_name is a valid name of a supported OS + subroutine validate_os_name(os_name, is_valid) + + !> Name of an operating system + character(len=:), allocatable, intent(in) :: os_name + + !> Boolean value of whether os_name is valid or not + logical, intent(out) :: is_valid + + select case (os_name) + case ("linux", "macos", "windows", "cygwin", "solaris", "freebsd", & + & "openbsd", "unknown") + is_valid = .true. + case default + is_valid = .false. + end select + + end subroutine validate_os_name + + !> Match os_type enum to a lowercase string with name of OS + subroutine match_os_type(os_name, os_type) + + !> Name of operating system + character(len=:), allocatable, intent(in) :: os_name + + !> Enum representing type of OS + integer, intent(out) :: os_type + + select case (os_name) + case ("linux"); os_type = OS_LINUX + case ("macos"); os_type = OS_MACOS + case ("windows"); os_type = OS_WINDOWS + case ("cygwin"); os_type = OS_CYGWIN + case ("solaris"); os_type = OS_SOLARIS + case ("freebsd"); os_type = OS_FREEBSD + case ("openbsd"); os_type = OS_OPENBSD + case ("all"); os_type = OS_ALL + case default; os_type = OS_UNKNOWN + end select + + end subroutine match_os_type + + !> Match lowercase string with name of OS to os_type enum + function os_type_name(os_type) + + !> Name of operating system + character(len=:), allocatable :: os_type_name + + !> Enum representing type of OS + integer, intent(in) :: os_type + + select case (os_type) + case (OS_ALL); os_type_name = "all" + case default; os_type_name = lower(OS_NAME(os_type)) + end select + + end function os_type_name + + subroutine validate_profile_table(profile_name, compiler_name, key_list, table, error, os_valid) + + !> Name of profile + character(len=:), allocatable, intent(in) :: profile_name + + !> Name of compiler + character(len=:), allocatable, intent(in) :: compiler_name + + !> List of keys in the table + type(toml_key), allocatable, intent(in) :: key_list(:) + + !> Table containing OS tables + type(toml_table), pointer, intent(in) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Was called with valid operating system + logical, intent(in) :: os_valid + + character(len=:), allocatable :: flags, c_flags, cxx_flags, link_time_flags, key_name, file_name, file_flags, err_message + type(toml_table), pointer :: files + type(toml_key), allocatable :: file_list(:) + integer :: ikey, ifile, stat + logical :: is_valid + + if (size(key_list).ge.1) then + do ikey=1,size(key_list) + key_name = key_list(ikey)%key + if (key_name.eq.'flags') then + call get_value(table, 'flags', flags, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "flags has to be a key-value pair") + return + end if + else if (key_name.eq.'c-flags') then + call get_value(table, 'c-flags', c_flags, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "c-flags has to be a key-value pair") + return + end if + else if (key_name.eq.'cxx-flags') then + call get_value(table, 'cxx-flags', cxx_flags, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "cxx-flags has to be a key-value pair") + return + end if + else if (key_name.eq.'link-time-flags') then + call get_value(table, 'link-time-flags', link_time_flags, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "link-time-flags has to be a key-value pair") + return + end if + else if (key_name.eq.'files') then + call get_value(table, 'files', files, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "files has to be a table") + return + end if + call files%get_keys(file_list) + do ifile=1,size(file_list) + file_name = file_list(ifile)%key + call get_value(files, file_name, file_flags, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "file scope flags has to be a key-value pair") + return + end if + end do + else if (.not. os_valid) then + call validate_os_name(key_name, is_valid) + err_message = "Unexpected key " // key_name // " found in profile table "//profile_name//" "//compiler_name//"." + if (.not. is_valid) call syntax_error(error, err_message) + else + err_message = "Unexpected key " // key_name // " found in profile table "//profile_name//" "//compiler_name//"." + call syntax_error(error, err_message) + end if + end do + end if + + if (allocated(error)) return + + end subroutine validate_profile_table + + !> Look for flags, c-flags, link-time-flags key-val pairs + !> and files table in a given table and create new profiles + subroutine get_flags(profile_name, compiler_name, os_type, key_list, table, profiles, profindex, os_valid) + + !> Name of profile + character(len=:), allocatable, intent(in) :: profile_name + + !> Name of compiler + character(len=:), allocatable, intent(in) :: compiler_name + + !> OS type + integer, intent(in) :: os_type + + !> List of keys in the table + type(toml_key), allocatable, intent(in) :: key_list(:) + + !> Table containing OS tables + type(toml_table), pointer, intent(in) :: table + + !> List of profiles + type(profile_config_t), allocatable, intent(inout) :: profiles(:) + + !> Index in the list of profiles + integer, intent(inout) :: profindex + + !> Was called with valid operating system + logical, intent(in) :: os_valid + + character(len=:), allocatable :: flags, c_flags, cxx_flags, link_time_flags, key_name, file_name, file_flags, err_message + type(toml_table), pointer :: files + type(toml_key), allocatable :: file_list(:) + type(file_scope_flag), allocatable :: file_scope_flags(:) + integer :: ikey, ifile, stat + logical :: is_valid + + call get_value(table, 'flags', flags) + call get_value(table, 'c-flags', c_flags) + call get_value(table, 'cxx-flags', cxx_flags) + call get_value(table, 'link-time-flags', link_time_flags) + call get_value(table, 'files', files) + if (associated(files)) then + call files%get_keys(file_list) + allocate(file_scope_flags(size(file_list))) + do ifile=1,size(file_list) + file_name = file_list(ifile)%key + call get_value(files, file_name, file_flags) + associate(cur_file=>file_scope_flags(ifile)) + if (.not.(path.eq."")) file_name = join_path(path, file_name) + cur_file%file_name = file_name + cur_file%flags = file_flags + end associate + end do + end if + + profiles(profindex) = new_profile(profile_name, compiler_name, os_type, & + & flags, c_flags, cxx_flags, link_time_flags, file_scope_flags) + profindex = profindex + 1 + end subroutine get_flags + + !> Traverse operating system tables to obtain number of profiles + subroutine traverse_oss_for_size(profile_name, compiler_name, os_list, table, profiles_size, error) + + !> Name of profile + character(len=:), allocatable, intent(in) :: profile_name + + !> Name of compiler + character(len=:), allocatable, intent(in) :: compiler_name + + !> List of OSs in table with profile name and compiler name given + type(toml_key), allocatable, intent(in) :: os_list(:) + + !> Table containing OS tables + type(toml_table), pointer, intent(in) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Number of profiles in list of profiles + integer, intent(inout) :: profiles_size + + type(toml_key), allocatable :: key_list(:) + character(len=:), allocatable :: os_name, l_os_name + type(toml_table), pointer :: os_node + integer :: ios, stat + logical :: is_valid, key_val_added, is_key_val + + if (size(os_list)<1) return + key_val_added = .false. + do ios = 1, size(os_list) + os_name = os_list(ios)%key + call validate_os_name(os_name, is_valid) + if (is_valid) then + call get_value(table, os_name, os_node, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "os "//os_name//" has to be a table") + return + end if + call os_node%get_keys(key_list) + profiles_size = profiles_size + 1 + call validate_profile_table(profile_name, compiler_name, key_list, os_node, error, .true.) + else + ! Not lowercase OS name + l_os_name = lower(os_name) + call validate_os_name(l_os_name, is_valid) + if (is_valid) then + call fatal_error(error,'*traverse_oss*:Error: Name of the operating system must be a lowercase string.') + end if + if (allocated(error)) return + + ! Missing OS name + is_key_val = .false. + os_name = os_list(ios)%key + call get_value(table, os_name, os_node, stat=stat) + if (stat /= toml_stat%success) then + is_key_val = .true. + end if + os_node=>table + if (is_key_val.and..not.key_val_added) then + key_val_added = .true. + is_key_val = .false. + profiles_size = profiles_size + 1 + else if (.not.is_key_val) then + profiles_size = profiles_size + 1 + end if + call validate_profile_table(profile_name, compiler_name, os_list, os_node, error, .false.) + end if + end do + end subroutine traverse_oss_for_size + + !> Traverse operating system tables to obtain profiles + subroutine traverse_oss(profile_name, compiler_name, os_list, table, profiles, profindex, error) + + !> Name of profile + character(len=:), allocatable, intent(in) :: profile_name + + !> Name of compiler + character(len=:), allocatable, intent(in) :: compiler_name + + !> List of OSs in table with profile name and compiler name given + type(toml_key), allocatable, intent(in) :: os_list(:) + + !> Table containing OS tables + type(toml_table), pointer, intent(in) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> List of profiles + type(profile_config_t), allocatable, intent(inout) :: profiles(:) + + !> Index in the list of profiles + integer, intent(inout) :: profindex + + type(toml_key), allocatable :: key_list(:) + character(len=:), allocatable :: os_name, l_os_name + type(toml_table), pointer :: os_node + integer :: ios, stat, os_type + logical :: is_valid, is_key_val + + if (size(os_list)<1) return + do ios = 1, size(os_list) + os_name = os_list(ios)%key + call validate_os_name(os_name, is_valid) + if (is_valid) then + call get_value(table, os_name, os_node, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "os "//os_name//" has to be a table") + return + end if + call os_node%get_keys(key_list) + call match_os_type(os_name, os_type) + call get_flags(profile_name, compiler_name, os_type, key_list, os_node, profiles, profindex, .true.) + else + ! Not lowercase OS name + l_os_name = lower(os_name) + call validate_os_name(l_os_name, is_valid) + if (is_valid) then + call fatal_error(error,'*traverse_oss*:Error: Name of the operating system must be a lowercase string.') + end if + if (allocated(error)) return + + ! Missing OS name + is_key_val = .false. + os_name = os_list(ios)%key + call get_value(table, os_name, os_node, stat=stat) + if (stat /= toml_stat%success) then + is_key_val = .true. + end if + os_node=>table + os_type = OS_ALL + call get_flags(profile_name, compiler_name, os_type, os_list, os_node, profiles, profindex, .false.) + end if + end do + end subroutine traverse_oss + + !> Traverse compiler tables + subroutine traverse_compilers(profile_name, comp_list, table, error, profiles_size, profiles, profindex) + + !> Name of profile + character(len=:), allocatable, intent(in) :: profile_name + + !> List of OSs in table with profile name given + type(toml_key), allocatable, intent(in) :: comp_list(:) + + !> Table containing compiler tables + type(toml_table), pointer, intent(in) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Number of profiles in list of profiles + integer, intent(inout), optional :: profiles_size + + !> List of profiles + type(profile_config_t), allocatable, intent(inout), optional :: profiles(:) + + !> Index in the list of profiles + integer, intent(inout), optional :: profindex + + character(len=:), allocatable :: compiler_name + type(toml_table), pointer :: comp_node + type(toml_key), allocatable :: os_list(:) + integer :: icomp, stat + logical :: is_valid + + if (size(comp_list)<1) return + do icomp = 1, size(comp_list) + call validate_compiler_name(comp_list(icomp)%key, is_valid) + if (is_valid) then + compiler_name = comp_list(icomp)%key + call get_value(table, compiler_name, comp_node, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "Compiler "//comp_list(icomp)%key//" must be a table entry") + exit + end if + call comp_node%get_keys(os_list) + if (present(profiles_size)) then + call traverse_oss_for_size(profile_name, compiler_name, os_list, comp_node, profiles_size, error) + if (allocated(error)) return + else + if (.not.(present(profiles).and.present(profindex))) then + call fatal_error(error, "Both profiles and profindex have to be present") + return + end if + call traverse_oss(profile_name, compiler_name, os_list, comp_node, & + & profiles, profindex, error) + if (allocated(error)) return + end if + else + call fatal_error(error,'*traverse_compilers*:Error: Compiler name not specified or invalid.') + end if + end do + end subroutine traverse_compilers + + !> Construct new profiles array from a TOML data structure + subroutine new_profiles(profiles, table, error) + + !> Instance of the dependency configuration + type(profile_config_t), allocatable, intent(out) :: profiles(:) + + !> Instance of the TOML data structure + type(toml_table), target, intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), pointer :: prof_node + type(toml_key), allocatable :: prof_list(:) + type(toml_key), allocatable :: comp_list(:) + type(toml_key), allocatable :: os_list(:) + character(len=:), allocatable :: profile_name, compiler_name + integer :: profiles_size, iprof, stat, profindex + logical :: is_valid + type(profile_config_t), allocatable :: default_profiles(:) + + path = '' + + default_profiles = get_default_profiles(error) + if (allocated(error)) return + call table%get_keys(prof_list) + + if (size(prof_list) < 1) return + + profiles_size = 0 + + do iprof = 1, size(prof_list) + profile_name = prof_list(iprof)%key + call validate_compiler_name(profile_name, is_valid) + if (is_valid) then + profile_name = "all" + comp_list = prof_list(iprof:iprof) + prof_node=>table + call traverse_compilers(profile_name, comp_list, prof_node, error, profiles_size=profiles_size) + if (allocated(error)) return + else + call validate_os_name(profile_name, is_valid) + if (is_valid) then + os_list = prof_list(iprof:iprof) + profile_name = 'all' + compiler_name = DEFAULT_COMPILER + call traverse_oss_for_size(profile_name, compiler_name, os_list, table, profiles_size, error) + if (allocated(error)) return + else + call get_value(table, profile_name, prof_node, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "Profile "//prof_list(iprof)%key//" must be a table entry") + exit + end if + call prof_node%get_keys(comp_list) + call traverse_compilers(profile_name, comp_list, prof_node, error, profiles_size=profiles_size) + if (allocated(error)) return + end if + end if + end do + + profiles_size = profiles_size + size(default_profiles) + allocate(profiles(profiles_size)) + + do profindex=1, size(default_profiles) + profiles(profindex) = default_profiles(profindex) + end do + + do iprof = 1, size(prof_list) + profile_name = prof_list(iprof)%key + call validate_compiler_name(profile_name, is_valid) + if (is_valid) then + profile_name = "all" + comp_list = prof_list(iprof:iprof) + prof_node=>table + call traverse_compilers(profile_name, comp_list, prof_node, error, profiles=profiles, profindex=profindex) + if (allocated(error)) return + else + call validate_os_name(profile_name, is_valid) + if (is_valid) then + os_list = prof_list(iprof:iprof) + profile_name = 'all' + compiler_name = DEFAULT_COMPILER + prof_node=>table + call traverse_oss(profile_name, compiler_name, os_list, prof_node, profiles, profindex, error) + if (allocated(error)) return + else + call get_value(table, profile_name, prof_node, stat=stat) + call prof_node%get_keys(comp_list) + call traverse_compilers(profile_name, comp_list, prof_node, error, profiles=profiles, profindex=profindex) + if (allocated(error)) return + end if + end if + end do + + ! Apply profiles with profile name 'all' to matching profiles + do iprof = 1,size(profiles) + if (profiles(iprof)%profile_name.eq.'all') then + do profindex = 1,size(profiles) + if (.not.(profiles(profindex)%profile_name.eq.'all') & + & .and.(profiles(profindex)%compiler.eq.profiles(iprof)%compiler) & + & .and.(profiles(profindex)%os_type.eq.profiles(iprof)%os_type)) then + profiles(profindex)%flags=profiles(profindex)%flags// & + & " "//profiles(iprof)%flags + profiles(profindex)%c_flags=profiles(profindex)%c_flags// & + & " "//profiles(iprof)%c_flags + profiles(profindex)%cxx_flags=profiles(profindex)%cxx_flags// & + & " "//profiles(iprof)%cxx_flags + profiles(profindex)%link_time_flags=profiles(profindex)%link_time_flags// & + & " "//profiles(iprof)%link_time_flags + end if + end do + end if + end do + end subroutine new_profiles + + !> Construct an array of built-in profiles + function get_default_profiles(error) result(default_profiles) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(profile_config_t), allocatable :: default_profiles(:) + + default_profiles = [ & + & new_profile('release', & + & 'caf', & + & OS_ALL, & + & flags=' -O3 -Wimplicit-interface -fPIC -fmax-errors=1 -funroll-loops', & + & is_built_in=.true.), & + & new_profile('release', & + & 'gfortran', & + & OS_ALL, & + & flags=' -O3 -Wimplicit-interface -fPIC -fmax-errors=1 -funroll-loops -fcoarray=single', & + & is_built_in=.true.), & + & new_profile('release', & + & 'f95', & + & OS_ALL, & + & flags=' -O3 -Wimplicit-interface -fPIC -fmax-errors=1 -ffast-math -funroll-loops', & + & is_built_in=.true.), & + & new_profile('release', & + & 'nvfortran', & + & OS_ALL, & + & flags = ' -Mbackslash', & + & is_built_in=.true.), & + & new_profile('release', & + & 'ifort', & + & OS_ALL, & + & flags = ' -fp-model precise -pc64 -align all -error-limit 1 -reentrancy& + & 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', & + & 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', & + & is_built_in=.true.), & + & new_profile('release', & + & 'ifx', & + & OS_WINDOWS, & + & flags = ' /fp:precise /align:all /error-limit:1 /reentrancy:threaded& + & /nogen-interfaces /assume:byterecl', & + & is_built_in=.true.), & + & new_profile('release', & + &'nagfor', & + & OS_ALL, & + & flags = ' -O4 -coarray=single -PIC', & + & is_built_in=.true.), & + & new_profile('release', & + &'lfortran', & + & OS_ALL, & + & flags = ' flag_lfortran_opt', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'caf', & + & OS_ALL, & + & flags = ' -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1 -g -fcheck=bounds& + & -fcheck=array-temps -fbacktrace', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'gfortran', & + & OS_ALL, & + & flags = ' -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1 -g -fcheck=bounds& + & -fcheck=array-temps -fbacktrace -fcoarray=single', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'f95', & + & OS_ALL, & + & flags = ' -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1 -g -fcheck=bounds& + & -fcheck=array-temps -Wno-maybe-uninitialized -Wno-uninitialized -fbacktrace', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'nvfortran', & + & OS_ALL, & + & flags = ' -Minform=inform -Mbackslash -g -Mbounds -Mchkptr -Mchkstk -traceback', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'ifort', & + & OS_ALL, & + & 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 /traceback', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'ifx', & + & OS_ALL, & + & 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', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'ifx', & + & OS_WINDOWS, & + & flags = ' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'lfortran', & + & OS_ALL, & + & flags = '', & + & is_built_in=.true.) & + &] + end function get_default_profiles + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the profile configuration + class(profile_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + write(unit, fmt) "Profile" + if (allocated(self%profile_name)) then + write(unit, fmt) "- profile name", self%profile_name + end if + + if (allocated(self%compiler)) then + write(unit, fmt) "- compiler", self%compiler + end if + + write(unit, fmt) "- os", os_type_name(self%os_type) + + if (allocated(self%flags)) then + write(unit, fmt) "- compiler flags", self%flags + end if + + end subroutine info + + !> Print a representation of profile_config_t + function info_profile(profile) result(s) + + !> Profile to be represented + type(profile_config_t), intent(in) :: profile + + !> String representation of given profile + character(:), allocatable :: s + + integer :: i + + s = "profile_config_t(" + s = s // 'profile_name="' // profile%profile_name // '"' + s = s // ', compiler="' // profile%compiler // '"' + s = s // ", os_type=" + select case(profile%os_type) + case (OS_UNKNOWN) + s = s // "OS_UNKNOWN" + case (OS_LINUX) + s = s // "OS_LINUX" + case (OS_MACOS) + s = s // "OS_MACOS" + case (OS_WINDOWS) + s = s // "OS_WINDOWS" + case (OS_CYGWIN) + s = s // "OS_CYGWIN" + case (OS_SOLARIS) + s = s // "OS_SOLARIS" + case (OS_FREEBSD) + s = s // "OS_FREEBSD" + case (OS_OPENBSD) + s = s // "OS_OPENBSD" + case (OS_ALL) + s = s // "OS_ALL" + case default + s = s // "INVALID" + end select + if (allocated(profile%flags)) s = s // ', flags="' // profile%flags // '"' + if (allocated(profile%c_flags)) s = s // ', c_flags="' // profile%c_flags // '"' + if (allocated(profile%cxx_flags)) s = s // ', cxx_flags="' // profile%cxx_flags // '"' + if (allocated(profile%link_time_flags)) s = s // ', link_time_flags="' // profile%link_time_flags // '"' + if (allocated(profile%file_scope_flags)) then + do i=1,size(profile%file_scope_flags) + s = s // ', flags for '//profile%file_scope_flags(i)%file_name// & + & ' ="' // profile%file_scope_flags(i)%flags // '"' + end do + end if + s = s // ")" + + end function info_profile + + !> Look for profile with given configuration in array profiles + subroutine find_profile(profiles, profile_name, compiler, os_type, found_matching, chosen_profile) + + !> Array of profiles + type(profile_config_t), allocatable, intent(in) :: profiles(:) + + !> Name of profile + character(:), allocatable, intent(in) :: profile_name + + !> Name of compiler + character(:), allocatable, intent(in) :: compiler + + !> Type of operating system (enum) + integer, intent(in) :: os_type + + !> Boolean value containing true if matching profile was found + logical, intent(out) :: found_matching + + !> Last matching profile in the profiles array + type(profile_config_t), intent(out) :: chosen_profile + + character(:), allocatable :: curr_profile_name + character(:), allocatable :: curr_compiler + integer :: curr_os + integer :: i, priority, curr_priority + + found_matching = .false. + if (size(profiles) < 1) return + ! Try to find profile with matching OS type + do i=1,size(profiles) + curr_profile_name = profiles(i)%profile_name + curr_compiler = profiles(i)%compiler + curr_os = profiles(i)%os_type + if (curr_profile_name.eq.profile_name) then + if (curr_compiler.eq.compiler) then + if (curr_os.eq.os_type) then + chosen_profile = profiles(i) + found_matching = .true. + end if + end if + end if + end do + ! Try to find profile with OS type 'all' + if (.not. found_matching) then + do i=1,size(profiles) + curr_profile_name = profiles(i)%profile_name + curr_compiler = profiles(i)%compiler + curr_os = profiles(i)%os_type + if (curr_profile_name.eq.profile_name) then + if (curr_compiler.eq.compiler) then + if (curr_os.eq.OS_ALL) then + chosen_profile = profiles(i) + found_matching = .true. + end if + end if + end if + end do + end if + end subroutine find_profile + + logical function file_scope_same(this,that) + class(file_scope_flag), intent(in) :: this + class(serializable_t), intent(in) :: that + + file_scope_same = .false. + + select type (other=>that) + type is (file_scope_flag) + if (allocated(this%file_name).neqv.allocated(other%file_name)) return + if (allocated(this%file_name)) then + if (.not.(this%file_name==other%file_name)) return + endif + if (allocated(this%flags).neqv.allocated(other%flags)) return + if (allocated(this%flags)) then + if (.not.(this%flags==other%flags)) return + endif + + class default + ! Not the same type + return + end select + + !> All checks passed! + file_scope_same = .true. + + end function file_scope_same + + !> Dump to toml table + subroutine file_scope_dump(self, table, error) + + !> Instance of the serializable object + class(file_scope_flag), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_string(table, "file-name", self%file_name, error) + if (allocated(error)) return + call set_string(table, "flags", self%flags, error) + if (allocated(error)) return + + end subroutine file_scope_dump + + !> Read from toml table (no checks made at this stage) + subroutine file_scope_load(self, table, error) + + !> Instance of the serializable object + class(file_scope_flag), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call get_value(table, "file-name", self%file_name) + call get_value(table, "flags", self%flags) + + end subroutine file_scope_load + + logical function profile_same(this,that) + class(profile_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + integer :: ii + + profile_same = .false. + + select type (other=>that) + type is (profile_config_t) + if (allocated(this%profile_name).neqv.allocated(other%profile_name)) return + if (allocated(this%profile_name)) then + if (.not.(this%profile_name==other%profile_name)) return + endif + if (allocated(this%compiler).neqv.allocated(other%compiler)) return + if (allocated(this%compiler)) then + if (.not.(this%compiler==other%compiler)) return + endif + if (this%os_type/=other%os_type) return + if (allocated(this%flags).neqv.allocated(other%flags)) return + if (allocated(this%flags)) then + if (.not.(this%flags==other%flags)) return + endif + if (allocated(this%c_flags).neqv.allocated(other%c_flags)) return + if (allocated(this%c_flags)) then + if (.not.(this%c_flags==other%c_flags)) return + endif + if (allocated(this%cxx_flags).neqv.allocated(other%cxx_flags)) return + if (allocated(this%cxx_flags)) then + if (.not.(this%cxx_flags==other%cxx_flags)) return + endif + if (allocated(this%link_time_flags).neqv.allocated(other%link_time_flags)) return + if (allocated(this%link_time_flags)) then + if (.not.(this%link_time_flags==other%link_time_flags)) return + endif + + if (allocated(this%file_scope_flags).neqv.allocated(other%file_scope_flags)) return + if (allocated(this%file_scope_flags)) then + if (.not.size(this%file_scope_flags)==size(other%file_scope_flags)) return + do ii=1,size(this%file_scope_flags) + print *, 'check ii-th file scope: ',ii + if (.not.this%file_scope_flags(ii)==other%file_scope_flags(ii)) return + end do + endif + + if (this%is_built_in.neqv.other%is_built_in) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + profile_same = .true. + + end function profile_same + + !> Dump to toml table + subroutine profile_dump(self, table, error) + + !> Instance of the serializable object + class(profile_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + integer :: ierr, ii + type(toml_table), pointer :: ptr_deps, ptr + character(len=30) :: unnamed + + call set_string(table, "profile-name", self%profile_name, error) + if (allocated(error)) return + call set_string(table, "compiler", self%compiler, error) + if (allocated(error)) return + call set_string(table,"os-type",os_type_name(self%os_type), error, 'profile_config_t') + if (allocated(error)) return + call set_string(table, "flags", self%flags, error) + if (allocated(error)) return + call set_string(table, "c-flags", self%c_flags, error) + if (allocated(error)) return + call set_string(table, "cxx-flags", self%cxx_flags, error) + if (allocated(error)) return + call set_string(table, "link-time-flags", self%link_time_flags, error) + if (allocated(error)) return + + if (allocated(self%file_scope_flags)) then + + ! Create dependency table + call add_table(table, "file-scope-flags", ptr_deps) + if (.not. associated(ptr_deps)) then + call fatal_error(error, "profile_config_t cannot create file scope table ") + return + end if + + do ii = 1, size(self%file_scope_flags) + associate (dep => self%file_scope_flags(ii)) + + !> Because files need a name, fallback if this has no name + if (len_trim(dep%file_name)==0) then + write(unnamed,1) ii + call add_table(ptr_deps, trim(unnamed), ptr) + else + call add_table(ptr_deps, dep%file_name, ptr) + end if + if (.not. associated(ptr)) then + call fatal_error(error, "profile_config_t cannot create entry for file "//dep%file_name) + return + end if + call dep%dump_to_toml(ptr, error) + if (allocated(error)) return + end associate + end do + + endif + + call set_value(table, "is-built-in", self%is_built_in, error, 'profile_config_t') + if (allocated(error)) return + + 1 format('UNNAMED_FILE_',i0) + + end subroutine profile_dump + + !> Read from toml table (no checks made at this stage) + subroutine profile_load(self, table, error) + + !> Instance of the serializable object + class(profile_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + character(len=:), allocatable :: flag + integer :: ii, jj + type(toml_table), pointer :: ptr_dep, ptr + type(toml_key), allocatable :: keys(:),dep_keys(:) + + call table%get_keys(keys) + + call get_value(table, "profile-name", self%profile_name) + call get_value(table, "compiler", self%compiler) + call get_value(table,"os-type",flag) + call match_os_type(flag, self%os_type) + call get_value(table, "flags", self%flags) + call get_value(table, "c-flags", self%c_flags) + call get_value(table, "cxx-flags", self%cxx_flags) + call get_value(table, "link-time-flags", self%link_time_flags) + call get_value(table, "is-built-in", self%is_built_in, error, 'profile_config_t') + if (allocated(error)) return + + if (allocated(self%file_scope_flags)) deallocate(self%file_scope_flags) + sub_deps: do ii = 1, size(keys) + + select case (keys(ii)%key) + case ("file-scope-flags") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,'profile_config_t: error retrieving file_scope_flags table') + return + end if + + !> Read all packages + call ptr%get_keys(dep_keys) + allocate(self%file_scope_flags(size(dep_keys))) + + do jj = 1, size(dep_keys) + + call get_value(ptr, dep_keys(jj), ptr_dep) + call self%file_scope_flags(jj)%load_from_toml(ptr_dep, error) + if (allocated(error)) return + + end do + + end select + end do sub_deps + + end subroutine profile_load + +end module fpm_manifest_profile + +!>>>>> ././src/fpm/manifest/dependency.f90 + +!> Implementation of the meta data for dependencies. +!> +!> A dependency table can currently have the following fields +!> +!>```toml +!>[dependencies] +!>"dep1" = { git = "url" } +!>"dep2" = { git = "url", branch = "name" } +!>"dep3" = { git = "url", tag = "name" } +!>"dep4" = { git = "url", rev = "sha1" } +!>"dep0" = { path = "path" } +!>``` +!> +!> To reduce the amount of boilerplate code this module provides two constructors +!> for dependency types, one basic for an actual dependency (inline) table +!> and another to collect all dependency objects from a dependencies table, +!> which is handling the allocation of the objects and is forwarding the +!> individual dependency tables to their respective constructors. +!> The usual entry point should be the constructor for the super table. +!> +!> This objects contains a target to retrieve required `fpm` projects to +!> build the target declaring the dependency. +!> Resolving a dependency will result in obtaining a new package configuration +!> data for the respective project. +module fpm_manifest_dependency + use fpm_error, only: error_t, syntax_error, fatal_error + use fpm_git, only: git_target_t, git_target_tag, git_target_branch, & + & git_target_revision, git_target_default, git_matches_manifest + use fpm_toml, only: toml_table, toml_key, toml_stat, get_value, check_keys, serializable_t, add_table, & + & set_value, set_string + use fpm_filesystem, only: windows_path, join_path + use fpm_environment, only: get_os_type, OS_WINDOWS + use fpm_manifest_metapackages, only: metapackage_config_t, is_meta_package, new_meta_config, & + metapackage_request_t, new_meta_request + use fpm_versioning, only: version_t, new_version + use fpm_strings, only: string_t + use fpm_manifest_preprocess + implicit none + private + + public :: dependency_config_t, new_dependency, new_dependencies, manifest_has_changed, & + & dependency_destroy, resize + + !> Configuration meta data for a dependency + type, extends(serializable_t) :: dependency_config_t + + !> Name of the dependency + character(len=:), allocatable :: name + + !> Local target + character(len=:), allocatable :: path + + !> Namespace which the dependency belongs to. + !> Enables multiple dependencies with the same name. + !> Required for dependencies that are obtained via the official registry. + character(len=:), allocatable :: namespace + + !> The requested version of the dependency. + !> The latest version is used if not specified. + type(version_t), allocatable :: requested_version + + !> Requested macros for the dependency + type(preprocess_config_t), allocatable :: preprocess(:) + + !> Git descriptor + type(git_target_t), allocatable :: git + + contains + + !> Print information on this instance + procedure :: info + + !> Serialization interface + procedure :: serializable_is_same => dependency_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + + end type dependency_config_t + + !> Common output format for writing to the command line + character(len=*), parameter :: out_fmt = '("#", *(1x, g0))' + + interface resize + module procedure resize_dependency_config + end interface resize + +contains + + !> Construct a new dependency configuration from a TOML data structure + subroutine new_dependency(self, table, root, error) + + !> Instance of the dependency configuration + type(dependency_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Root directory of the manifest + character(*), intent(in), optional :: root + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: uri, value, requested_version + + type(toml_table), pointer :: child + + call check(table, error) + if (allocated(error)) return + + call table%get_key(self%name) + call get_value(table, "namespace", self%namespace) + + call get_value(table, "v", requested_version) + if (allocated(requested_version)) then + if (.not. allocated(self%requested_version)) allocate (self%requested_version) + call new_version(self%requested_version, requested_version, error) + if (allocated(error)) return + end if + + !> Get optional preprocessor directives + call get_value(table, "preprocess", child, requested=.false.) + if (associated(child)) then + call new_preprocessors(self%preprocess, child, error) + if (allocated(error)) return + endif + + call get_value(table, "path", uri) + if (allocated(uri)) then + if (get_os_type() == OS_WINDOWS) uri = windows_path(uri) + if (present(root)) uri = join_path(root,uri) ! Relative to the fpm.toml it’s written in + call move_alloc(uri, self%path) + return + end if + + call get_value(table, "git", uri) + if (allocated(uri)) then + call get_value(table, "tag", value) + if (allocated(value)) then + self%git = git_target_tag(uri, value) + end if + + if (.not. allocated(self%git)) then + call get_value(table, "branch", value) + if (allocated(value)) then + self%git = git_target_branch(uri, value) + end if + end if + + if (.not. allocated(self%git)) then + call get_value(table, "rev", value) + if (allocated(value)) then + self%git = git_target_revision(uri, value) + end if + end if + + if (.not. allocated(self%git)) then + self%git = git_target_default(uri) + end if + return + end if + + end subroutine new_dependency + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: name + type(toml_key), allocatable :: list(:) + type(toml_table), pointer :: child + + !> List of valid keys for the dependency table. + character(*), dimension(*), parameter :: valid_keys = [character(24) :: & + & "namespace", & + "v", & + "path", & + "git", & + "tag", & + "branch", & + "rev", & + "preprocess" & + & ] + + call table%get_key(name) + call table%get_keys(list) + + if (size(list) < 1) then + call syntax_error(error, "Dependency '"//name//"' does not provide sufficient entries") + return + end if + + call check_keys(table, valid_keys, error) + if (allocated(error)) return + + if (table%has_key("path") .and. table%has_key("git")) then + call syntax_error(error, "Dependency '"//name//"' cannot have both git and path entries") + return + end if + + if ((table%has_key("branch") .and. table%has_key("rev")) .or. & + (table%has_key("branch") .and. table%has_key("tag")) .or. & + (table%has_key("rev") .and. table%has_key("tag"))) then + call syntax_error(error, "Dependency '"//name//"' can only have one of branch, rev or tag present") + return + end if + + if ((table%has_key("branch") .or. table%has_key("tag") .or. table%has_key("rev")) & + .and. .not. table%has_key("git")) then + call syntax_error(error, "Dependency '"//name//"' has git identifier but no git url") + return + end if + + if (.not. table%has_key("path") .and. .not. table%has_key("git") & + .and. .not. table%has_key("namespace")) then + call syntax_error(error, "Please provide a 'namespace' for dependency '"//name// & + & "' if it is not a local path or git repository") + return + end if + + if (table%has_key('v') .and. (table%has_key('path') .or. table%has_key('git'))) then + call syntax_error(error, "Dependency '"//name//"' cannot have both v and git/path entries") + return + end if + + ! Check preprocess key + if (table%has_key('preprocess')) then + + call get_value(table, 'preprocess', child) + + if (.not.associated(child)) then + call syntax_error(error, "Dependency '"//name//"' has invalid 'preprocess' entry") + return + end if + + end if + + end subroutine check + + !> Construct new dependency array from a TOML data structure + subroutine new_dependencies(deps, table, root, meta, error) + + !> Instance of the dependency configuration + type(dependency_config_t), allocatable, intent(out) :: deps(:) + + !> (optional) metapackages + type(metapackage_config_t), optional, intent(out) :: meta + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Root directory of the manifest + character(*), intent(in), optional :: root + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), pointer :: node + type(toml_key), allocatable :: list(:) + type(dependency_config_t), allocatable :: all_deps(:) + type(metapackage_request_t) :: meta_request + logical, allocatable :: is_meta(:) + logical :: metapackages_allowed + integer :: idep, stat, ndep + + call table%get_keys(list) + ! An empty table is okay + if (size(list) < 1) return + + !> Flag dependencies that should be treated as metapackages + metapackages_allowed = present(meta) + allocate(is_meta(size(list)),source=.false.) + allocate(all_deps(size(list))) + + !> Parse all meta- and non-metapackage dependencies + do idep = 1, size(list) + + ! Check if this is a standard dependency node + call get_value(table, list(idep)%key, node, stat=stat) + is_standard_dependency: if (stat /= toml_stat%success) then + + ! See if it can be a valid metapackage name + call new_meta_request(meta_request, list(idep)%key, table, error=error) + + !> Neither a standard dep nor a metapackage + if (allocated(error)) then + call syntax_error(error, "Dependency "//list(idep)%key//" is not a valid metapackage or a table entry") + return + endif + + !> Valid meta dependency + is_meta(idep) = .true. + + else + + ! Parse as a standard dependency + is_meta(idep) = .false. + + call new_dependency(all_deps(idep), node, root, error) + if (allocated(error)) return + + end if is_standard_dependency + + end do + + ! Non-meta dependencies + ndep = count(.not.is_meta) + + ! Finalize standard dependencies + allocate(deps(ndep)) + ndep = 0 + do idep = 1, size(list) + if (is_meta(idep)) cycle + ndep = ndep+1 + deps(ndep) = all_deps(idep) + end do + + ! Finalize meta dependencies + if (metapackages_allowed) call new_meta_config(meta,table,is_meta,error) + + end subroutine new_dependencies + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the dependency configuration + class(dependency_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + write (unit, fmt) "Dependency" + if (allocated(self%name)) then + write (unit, fmt) "- name", self%name + end if + + if (allocated(self%git)) then + write (unit, fmt) "- kind", "git" + call self%git%info(unit, pr - 1) + end if + + if (allocated(self%path)) then + write (unit, fmt) "- kind", "local" + write (unit, fmt) "- path", self%path + end if + + end subroutine info + + !> Check if two dependency configurations are different + logical function manifest_has_changed(cached, manifest, verbosity, iunit) result(has_changed) + + !> Two instances of the dependency configuration + class(dependency_config_t), intent(in) :: cached, manifest + + !> Log verbosity + integer, intent(in) :: verbosity, iunit + + has_changed = .true. + + !> Perform all checks + if (allocated(cached%git).neqv.allocated(manifest%git)) then + if (verbosity>1) write(iunit,out_fmt) "GIT presence has changed. " + return + endif + if (allocated(cached%git)) then + if (.not.git_matches_manifest(cached%git,manifest%git,verbosity,iunit)) return + end if + + !> All checks passed! The two instances are equal + has_changed = .false. + + end function manifest_has_changed + + !> Clean memory + elemental subroutine dependency_destroy(self) + class(dependency_config_t), intent(inout) :: self + + if (allocated(self%name)) deallocate(self%name) + if (allocated(self%path)) deallocate(self%path) + if (allocated(self%namespace)) deallocate(self%namespace) + if (allocated(self%requested_version)) deallocate(self%requested_version) + if (allocated(self%git)) deallocate(self%git) + + end subroutine dependency_destroy + + !> Check that two dependency configs are equal + logical function dependency_is_same(this,that) + class(dependency_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + dependency_is_same = .false. + + select type (other=>that) + type is (dependency_config_t) + + if (.not.(this%name==other%name)) return + if (.not.(this%path==other%path)) return + if (.not.(this%namespace==other%namespace)) return + if (.not.(allocated(this%requested_version).eqv.allocated(other%requested_version))) return + if (allocated(this%requested_version)) then + if (.not.(this%requested_version==other%requested_version)) return + endif + + if (.not.(allocated(this%git).eqv.allocated(other%git))) return + if (allocated(this%git)) then + if (.not.(this%git==other%git)) return + endif + + class default + ! Not the same type + return + end select + + !> All checks passed! + dependency_is_same = .true. + + end function dependency_is_same + + !> Dump dependency to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(dependency_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(toml_table), pointer :: ptr + type(error_t), allocatable, intent(out) :: error + + integer :: ierr + + call set_string(table, "name", self%name, error, 'dependency_config_t') + if (allocated(error)) return + call set_string(table, "path", self%path, error, 'dependency_config_t') + if (allocated(error)) return + call set_string(table, "namespace", self%namespace, error, 'dependency_config_t') + if (allocated(error)) return + if (allocated(self%requested_version)) then + call set_string(table, "requested_version", self%requested_version%s(), error, 'dependency_config_t') + if (allocated(error)) return + endif + + if (allocated(self%git)) then + call add_table(table, "git", ptr, error) + if (allocated(error)) return + call self%git%dump_to_toml(ptr, error) + if (allocated(error)) return + endif + + end subroutine dump_to_toml + + !> Read dependency from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(dependency_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + type(toml_key), allocatable :: list(:) + type(toml_table), pointer :: ptr + character(len=:), allocatable :: requested_version + integer :: ierr,ii + + call dependency_destroy(self) + + call get_value(table, "name", self%name) + call get_value(table, "path", self%path) + call get_value(table, "namespace", self%namespace) + call get_value(table, "requested_version", requested_version) + if (allocated(requested_version)) then + allocate(self%requested_version) + call new_version(self%requested_version, requested_version, error) + if (allocated(error)) then + error%message = 'dependency_config_t: version error from TOML table - '//error%message + return + endif + end if + + call table%get_keys(list) + add_git: do ii = 1, size(list) + if (list(ii)%key=="git") then + call get_value(table, list(ii)%key, ptr, stat=ierr) + if (ierr /= toml_stat%success) then + call fatal_error(error,'dependency_config_t: cannot retrieve git from TOML table') + exit + endif + allocate(self%git) + call self%git%load_from_toml(ptr, error) + if (allocated(error)) return + exit add_git + end if + end do add_git + + end subroutine load_from_toml + + !> Reallocate a list of dependencies + pure subroutine resize_dependency_config(var, n) + !> Instance of the array to be resized + type(dependency_config_t), allocatable, intent(inout) :: var(:) + !> Dimension of the final array size + integer, intent(in), optional :: n + + type(dependency_config_t), allocatable :: tmp(:) + integer :: this_size, new_size + integer, parameter :: initial_size = 16 + + if (allocated(var)) then + this_size = size(var, 1) + call move_alloc(var, tmp) + else + this_size = initial_size + end if + + if (present(n)) then + new_size = n + else + new_size = this_size + this_size/2 + 1 + end if + + allocate (var(new_size)) + + if (allocated(tmp)) then + this_size = min(size(tmp, 1), size(var, 1)) + var(:this_size) = tmp(:this_size) + deallocate (tmp) + end if + + end subroutine resize_dependency_config + +end module fpm_manifest_dependency + +!>>>>> ././src/fpm/manifest/executable.f90 + +!> Implementation of the meta data for an executables. +!> +!> An executable table can currently have the following fields +!> +!>```toml +!>[[ executable ]] +!>name = "string" +!>source-dir = "path" +!>main = "file" +!>link = ["lib"] +!>[executable.dependencies] +!>``` +module fpm_manifest_executable + use fpm_manifest_dependency, only : dependency_config_t, new_dependencies, resize + use fpm_error, only : error_t, syntax_error, bad_name_error, fatal_error + use fpm_strings, only : string_t, operator(==) + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list, serializable_t, add_table, & + set_string, set_list + implicit none + private + + public :: executable_config_t, new_executable + + !> Configuation meta data for an executable + type, extends(serializable_t) :: executable_config_t + + !> Name of the resulting executable + character(len=:), allocatable :: name + + !> Source directory for collecting the executable + character(len=:), allocatable :: source_dir + + !> Name of the source file declaring the main program + character(len=:), allocatable :: main + + !> Dependency meta data for this executable + type(dependency_config_t), allocatable :: dependency(:) + + !> Libraries to link against + type(string_t), allocatable :: link(:) + + contains + + !> Print information on this instance + procedure :: info + + !> Serialization interface + procedure :: serializable_is_same => exe_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + + end type executable_config_t + + character(*), parameter, private :: class_name = 'executable_config_t' + +contains + + !> Construct a new executable configuration from a TOML data structure + subroutine new_executable(self, table, error) + + !> Instance of the executable configuration + type(executable_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), pointer :: child + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "name", self%name) + if (.not.allocated(self%name)) then + call syntax_error(error, "Could not retrieve executable name") + return + end if + if (bad_name_error(error,'executable',self%name))then + return + endif + call get_value(table, "source-dir", self%source_dir, "app") + call get_value(table, "main", self%main, "main.f90") + + call get_value(table, "dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dependency, child, error=error) + if (allocated(error)) return + end if + + call get_list(table, "link", self%link, error) + if (allocated(error)) return + + end subroutine new_executable + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + logical :: name_present + integer :: ikey + + name_present = .false. + + call table%get_keys(list) + + if (size(list) < 1) then + call syntax_error(error, "Executable section does not provide sufficient entries") + return + end if + + do ikey = 1, size(list) + select case(list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed as executable entry") + exit + + case("name") + name_present = .true. + + case("source-dir", "main", "dependencies", "link") + continue + + end select + end do + if (allocated(error)) return + + if (.not.name_present) then + call syntax_error(error, "Executable name is not provided, please add a name entry") + end if + + end subroutine check + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the executable configuration + class(executable_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr, ii + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & + & fmti = '("#", 1x, a, t30, i0)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Executable target" + if (allocated(self%name)) then + write(unit, fmt) "- name", self%name + end if + if (allocated(self%source_dir)) then + if (self%source_dir /= "app" .or. pr > 2) then + write(unit, fmt) "- source directory", self%source_dir + end if + end if + if (allocated(self%main)) then + if (self%main /= "main.f90" .or. pr > 2) then + write(unit, fmt) "- program source", self%main + end if + end if + + if (allocated(self%dependency)) then + if (size(self%dependency) > 1 .or. pr > 2) then + write(unit, fmti) "- dependencies", size(self%dependency) + end if + do ii = 1, size(self%dependency) + call self%dependency(ii)%info(unit, pr - 1) + end do + end if + + end subroutine info + + logical function exe_is_same(this,that) + class(executable_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + integer :: ii + + exe_is_same = .false. + + select type (other=>that) + type is (executable_config_t) + if (.not.this%link==other%link) return + if (.not.allocated(this%name).eqv.allocated(other%name)) return + if (.not.this%name==other%name) return + if (.not.allocated(this%source_dir).eqv.allocated(other%source_dir)) return + if (.not.this%source_dir==other%source_dir) return + if (.not.allocated(this%main).eqv.allocated(other%main)) return + if (.not.this%main==other%main) return + if (.not.allocated(this%dependency).eqv.allocated(other%dependency)) return + if (allocated(this%dependency)) then + if (.not.(size(this%dependency)==size(other%dependency))) return + do ii = 1, size(this%dependency) + if (.not.(this%dependency(ii)==other%dependency(ii))) return + end do + end if + class default + ! Not the same type + return + end select + + !> All checks passed! + exe_is_same = .true. + + end function exe_is_same + + !> Dump install config to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(executable_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + integer :: ierr, ii + type(toml_table), pointer :: ptr_deps,ptr + character(27) :: unnamed + + call set_string(table, "name", self%name, error) + if (allocated(error)) return + call set_string(table, "source-dir", self%source_dir, error) + if (allocated(error)) return + call set_string(table, "main", self%main, error) + if (allocated(error)) return + + if (allocated(self%dependency)) then + + ! Create dependency table + call add_table(table, "dependencies", ptr_deps) + if (.not. associated(ptr_deps)) then + call fatal_error(error, class_name//" cannot create dependency table ") + return + end if + + do ii = 1, size(self%dependency) + associate (dep => self%dependency(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(dep%name)==0) then + write(unnamed,1) ii + call add_table(ptr_deps, trim(unnamed), ptr) + else + call add_table(ptr_deps, dep%name, ptr) + end if + if (.not. associated(ptr)) then + call fatal_error(error, class_name//" cannot create entry for dependency "//dep%name) + return + end if + call dep%dump_to_toml(ptr, error) + if (allocated(error)) return + end associate + end do + + endif + + call set_list(table, "link", self%link, error) + if (allocated(error)) return + + 1 format('UNNAMED_DEPENDENCY_',i0) + + end subroutine dump_to_toml + + !> Read install config from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(executable_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + type(toml_key), allocatable :: keys(:),dep_keys(:) + type(toml_table), pointer :: ptr_deps,ptr + integer :: ii, jj, ierr + + call table%get_keys(keys) + + call get_value(table, "name", self%name) + if (allocated(error)) return + call get_value(table, "source-dir", self%source_dir) + if (allocated(error)) return + call get_value(table, "main", self%main) + if (allocated(error)) return + call get_list(table, "link", self%link, error) + + find_deps_table: do ii = 1, size(keys) + if (keys(ii)%key=="dependencies") then + + call get_value(table, keys(ii), ptr_deps) + if (.not.associated(ptr_deps)) then + call fatal_error(error,class_name//': error retrieving dependency table from TOML table') + return + end if + + !> Read all dependencies + call ptr_deps%get_keys(dep_keys) + call resize(self%dependency, size(dep_keys)) + + do jj = 1, size(dep_keys) + + call get_value(ptr_deps, dep_keys(jj), ptr) + call self%dependency(jj)%load_from_toml(ptr, error) + if (allocated(error)) return + + end do + + exit find_deps_table + + endif + end do find_deps_table + + end subroutine load_from_toml + +end module fpm_manifest_executable + +!>>>>> ././src/fpm/manifest/example.f90 + +!> Implementation of the meta data for an example. +!> +!> The example data structure is effectively a decorated version of an executable +!> and shares most of its properties, except for the defaults and can be +!> handled under most circumstances just like any other executable. +!> +!> A example table can currently have the following fields +!> +!>```toml +!>[[ example ]] +!>name = "string" +!>source-dir = "path" +!>main = "file" +!>link = ["lib"] +!>[example.dependencies] +!>``` +module fpm_manifest_example + use fpm_manifest_dependency, only : dependency_config_t, new_dependencies + use fpm_manifest_executable, only : executable_config_t + use fpm_error, only : error_t, syntax_error, bad_name_error + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list + implicit none + private + + public :: example_config_t, new_example + + !> Configuation meta data for an example + type, extends(executable_config_t) :: example_config_t + + contains + + !> Print information on this instance + procedure :: info + + end type example_config_t + +contains + + !> Construct a new example configuration from a TOML data structure + subroutine new_example(self, table, error) + + !> Instance of the example configuration + type(example_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), pointer :: child + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "name", self%name) + if (.not.allocated(self%name)) then + call syntax_error(error, "Could not retrieve example name") + return + end if + if (bad_name_error(error,'example',self%name))then + return + endif + call get_value(table, "source-dir", self%source_dir, "example") + call get_value(table, "main", self%main, "main.f90") + + call get_value(table, "dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dependency, child, error=error) + if (allocated(error)) return + end if + + call get_list(table, "link", self%link, error) + if (allocated(error)) return + + end subroutine new_example + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + logical :: name_present + integer :: ikey + + name_present = .false. + + call table%get_keys(list) + + if (size(list) < 1) then + call syntax_error(error, "Example section does not provide sufficient entries") + return + end if + + do ikey = 1, size(list) + select case(list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in example entry") + exit + + case("name") + name_present = .true. + + case("source-dir", "main", "dependencies", "link") + continue + + end select + end do + if (allocated(error)) return + + if (.not.name_present) then + call syntax_error(error, "Example name is not provided, please add a name entry") + end if + + end subroutine check + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the example configuration + class(example_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr, ii + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & + & fmti = '("#", 1x, a, t30, i0)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Example target" + if (allocated(self%name)) then + write(unit, fmt) "- name", self%name + end if + if (allocated(self%source_dir)) then + if (self%source_dir /= "example" .or. pr > 2) then + write(unit, fmt) "- source directory", self%source_dir + end if + end if + if (allocated(self%main)) then + if (self%main /= "main.f90" .or. pr > 2) then + write(unit, fmt) "- example source", self%main + end if + end if + + if (allocated(self%dependency)) then + if (size(self%dependency) > 1 .or. pr > 2) then + write(unit, fmti) "- dependencies", size(self%dependency) + end if + do ii = 1, size(self%dependency) + call self%dependency(ii)%info(unit, pr - 1) + end do + end if + + end subroutine info + +end module fpm_manifest_example + +!>>>>> ././src/fpm/manifest/test.f90 + +!> Implementation of the meta data for a test. +!> +!> The test data structure is effectively a decorated version of an executable +!> and shares most of its properties, except for the defaults and can be +!> handled under most circumstances just like any other executable. +!> +!> A test table can currently have the following fields +!> +!>```toml +!>[[ test ]] +!>name = "string" +!>source-dir = "path" +!>main = "file" +!>link = ["lib"] +!>[test.dependencies] +!>``` +module fpm_manifest_test + use fpm_manifest_dependency, only : new_dependencies + use fpm_manifest_executable, only : executable_config_t + use fpm_error, only : error_t, syntax_error, bad_name_error + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list + implicit none + private + + public :: test_config_t, new_test + + !> Configuation meta data for an test + type, extends(executable_config_t) :: test_config_t + + contains + + !> Print information on this instance + procedure :: info + + end type test_config_t + +contains + + !> Construct a new test configuration from a TOML data structure + subroutine new_test(self, table, error) + + !> Instance of the test configuration + type(test_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), pointer :: child + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "name", self%name) + if (.not.allocated(self%name)) then + call syntax_error(error, "Could not retrieve test name") + return + end if + if (bad_name_error(error,'test',self%name))then + return + endif + call get_value(table, "source-dir", self%source_dir, "test") + call get_value(table, "main", self%main, "main.f90") + + call get_value(table, "dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dependency, child, error=error) + if (allocated(error)) return + end if + + call get_list(table, "link", self%link, error) + if (allocated(error)) return + + end subroutine new_test + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + logical :: name_present + integer :: ikey + + name_present = .false. + + call table%get_keys(list) + + if (size(list) < 1) then + call syntax_error(error, "Test section does not provide sufficient entries") + return + end if + + do ikey = 1, size(list) + select case(list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in test entry") + exit + + case("name") + name_present = .true. + + case("source-dir", "main", "dependencies", "link") + continue + + end select + end do + if (allocated(error)) return + + if (.not.name_present) then + call syntax_error(error, "Test name is not provided, please add a name entry") + end if + + end subroutine check + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the test configuration + class(test_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr, ii + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & + & fmti = '("#", 1x, a, t30, i0)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Test target" + if (allocated(self%name)) then + write(unit, fmt) "- name", self%name + end if + if (allocated(self%source_dir)) then + if (self%source_dir /= "test" .or. pr > 2) then + write(unit, fmt) "- source directory", self%source_dir + end if + end if + if (allocated(self%main)) then + if (self%main /= "main.f90" .or. pr > 2) then + write(unit, fmt) "- test source", self%main + end if + end if + + if (allocated(self%dependency)) then + if (size(self%dependency) > 1 .or. pr > 2) then + write(unit, fmti) "- dependencies", size(self%dependency) + end if + do ii = 1, size(self%dependency) + call self%dependency(ii)%info(unit, pr - 1) + end do + end if + + end subroutine info + +end module fpm_manifest_test + +!>>>>> ././src/fpm/manifest/package.f90 + +!> Define the package data containing the meta data from the configuration file. +!> +!> The package data defines a Fortran type corresponding to the respective +!> TOML document, after creating it from a package file no more interaction +!> with the TOML document is required. +!> +!> Every configuration type provides it custom constructor (prefixed with `new_`) +!> and knows how to deserialize itself from a TOML document. +!> To ensure we find no untracked content in the package file all keywords are +!> checked and possible entries have to be explicitly allowed in the `check` +!> function. +!> If entries are mutally exclusive or interdependent inside the current table +!> the `check` function is required to enforce this schema on the data structure. +!> +!> The package file root allows the following keywords +!> +!>```toml +!>name = "string" +!>version = "string" +!>license = "string" +!>author = "string" +!>maintainer = "string" +!>copyright = "string" +!>[library] +!>[dependencies] +!>[dev-dependencies] +!>[profiles] +!>[build] +!>[install] +!>[fortran] +!>[[ executable ]] +!>[[ example ]] +!>[[ test ]] +!>[extra] +!>``` +module fpm_manifest_package + use fpm_manifest_build, only: build_config_t, new_build_config + use fpm_manifest_dependency, only : dependency_config_t, new_dependencies + use fpm_manifest_profile, only : profile_config_t, new_profiles, get_default_profiles + use fpm_manifest_example, only : example_config_t, new_example + use fpm_manifest_executable, only : executable_config_t, new_executable + use fpm_manifest_fortran, only : fortran_config_t, new_fortran_config + use fpm_manifest_library, only : library_config_t, new_library + use fpm_manifest_install, only: install_config_t, new_install_config + use fpm_manifest_test, only : test_config_t, new_test + use fpm_manifest_preprocess, only : preprocess_config_t, new_preprocessors + use fpm_manifest_metapackages, only: metapackage_config_t, new_meta_config + use fpm_filesystem, only : exists, getline, join_path + use fpm_error, only : error_t, fatal_error, syntax_error, bad_name_error + use fpm_toml, only : toml_table, toml_array, toml_key, toml_stat, get_value, len, & + serializable_t, set_value, set_string, set_list, add_table + use fpm_versioning, only : version_t, new_version + implicit none + private + + public :: package_config_t, new_package + + interface unique_programs + module procedure :: unique_programs1 + module procedure :: unique_programs2 + end interface unique_programs + + !> Package meta data + type, extends(serializable_t) :: package_config_t + + !> Name of the package + character(len=:), allocatable :: name + + !> Package version + type(version_t) :: version + + !> Build configuration data + type(build_config_t) :: build + + !> Metapackage data + type(metapackage_config_t) :: meta + + !> Installation configuration data + type(install_config_t) :: install + + !> Fortran meta data + type(fortran_config_t) :: fortran + + !> License meta data + character(len=:), allocatable :: license + + !> Author meta data + character(len=:), allocatable :: author + + !> Maintainer meta data + character(len=:), allocatable :: maintainer + + !> Copyright meta data + character(len=:), allocatable :: copyright + + !> Library meta data + type(library_config_t), allocatable :: library + + !> Executable meta data + type(executable_config_t), allocatable :: executable(:) + + !> Dependency meta data + type(dependency_config_t), allocatable :: dependency(:) + + !> Development dependency meta data + type(dependency_config_t), allocatable :: dev_dependency(:) + + !> Profiles meta data + type(profile_config_t), allocatable :: profiles(:) + + !> Example meta data + type(example_config_t), allocatable :: example(:) + + !> Test meta data + type(test_config_t), allocatable :: test(:) + + !> Preprocess meta data + type(preprocess_config_t), allocatable :: preprocess(:) + + contains + + !> Print information on this instance + procedure :: info + + !> Serialization interface + procedure :: serializable_is_same => manifest_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + + end type package_config_t + + character(len=*), parameter, private :: class_name = 'package_config_t' + +contains + + !> Construct a new package configuration from a TOML data structure + subroutine new_package(self, table, root, error) + + !> Instance of the package configuration + type(package_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Root directory of the manifest + character(len=*), intent(in), optional :: root + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + ! Backspace (8), tabulator (9), newline (10), formfeed (12) and carriage + ! return (13) are invalid in package names + character(len=*), parameter :: invalid_chars = & + achar(8) // achar(9) // achar(10) // achar(12) // achar(13) + type(toml_table), pointer :: child, node + type(toml_array), pointer :: children + character(len=:), allocatable :: version, version_file + integer :: ii, nn, stat, io + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "name", self%name) + if (.not.allocated(self%name)) then + call syntax_error(error, "Could not retrieve package name") + return + end if + if (bad_name_error(error,'package',self%name))then + return + endif + + call get_value(table, "license", self%license) + call get_value(table, "author", self%author) + call get_value(table, "maintainer", self%maintainer) + call get_value(table, "copyright", self%copyright) + + if (len(self%name) <= 0) then + call syntax_error(error, "Package name must be a non-empty string") + return + end if + + ii = scan(self%name, invalid_chars) + if (ii > 0) then + call syntax_error(error, "Package name contains invalid characters") + return + end if + + call get_value(table, "build", child, requested=.true., stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Type mismatch for build entry, must be a table") + return + end if + call new_build_config(self%build, child, self%name, error) + if (allocated(error)) return + + call get_value(table, "install", child, requested=.true., stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Type mismatch for install entry, must be a table") + return + end if + call new_install_config(self%install, child, error) + if (allocated(error)) return + + call get_value(table, "fortran", child, requested=.true., stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Type mismatch for fortran entry, must be a table") + return + end if + call new_fortran_config(self%fortran, child, error) + if (allocated(error)) return + + call get_value(table, "version", version, "0") + call new_version(self%version, version, error) + if (allocated(error) .and. present(root)) then + version_file = join_path(root, version) + if (exists(version_file)) then + deallocate(error) + open(file=version_file, newunit=io, iostat=stat) + if (stat == 0) then + call getline(io, version, iostat=stat) + end if + if (stat == 0) then + close(io, iostat=stat) + end if + if (stat == 0) then + call new_version(self%version, version, error) + else + call fatal_error(error, "Reading version number from file '" & + & //version_file//"' failed") + end if + end if + end if + if (allocated(error)) return + + call get_value(table, "dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dependency, child, root, self%meta, error) + if (allocated(error)) return + end if + + call get_value(table, "dev-dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dev_dependency, child, root, error=error) + if (allocated(error)) return + end if + + call get_value(table, "library", child, requested=.false.) + if (associated(child)) then + allocate(self%library) + call new_library(self%library, child, error) + if (allocated(error)) return + end if + + call get_value(table, "profiles", child, requested=.false.) + if (associated(child)) then + call new_profiles(self%profiles, child, error) + if (allocated(error)) return + else + self%profiles = get_default_profiles(error) + if (allocated(error)) return + end if + + call get_value(table, "executable", children, requested=.false.) + if (associated(children)) then + nn = len(children) + allocate(self%executable(nn)) + do ii = 1, nn + call get_value(children, ii, node, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Could not retrieve executable from array entry") + exit + end if + call new_executable(self%executable(ii), node, error) + if (allocated(error)) exit + end do + if (allocated(error)) return + + call unique_programs(self%executable, error) + if (allocated(error)) return + end if + + call get_value(table, "example", children, requested=.false.) + if (associated(children)) then + nn = len(children) + allocate(self%example(nn)) + do ii = 1, nn + call get_value(children, ii, node, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Could not retrieve example from array entry") + exit + end if + call new_example(self%example(ii), node, error) + if (allocated(error)) exit + end do + if (allocated(error)) return + + call unique_programs(self%example, error) + if (allocated(error)) return + + if (allocated(self%executable)) then + call unique_programs(self%executable, self%example, error) + if (allocated(error)) return + end if + end if + + call get_value(table, "test", children, requested=.false.) + if (associated(children)) then + nn = len(children) + allocate(self%test(nn)) + do ii = 1, nn + call get_value(children, ii, node, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Could not retrieve test from array entry") + exit + end if + call new_test(self%test(ii), node, error) + if (allocated(error)) exit + end do + if (allocated(error)) return + + call unique_programs(self%test, error) + if (allocated(error)) return + end if + + call get_value(table, "preprocess", child, requested=.false.) + if (associated(child)) then + call new_preprocessors(self%preprocess, child, error) + if (allocated(error)) return + end if + end subroutine new_package + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + logical :: name_present + integer :: ikey + + name_present = .false. + + call table%get_keys(list) + + if (size(list) < 1) then + call syntax_error(error, "Package file is empty") + return + end if + + do ikey = 1, size(list) + select case(list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in package file") + exit + + case("name") + name_present = .true. + + case("version", "license", "author", "maintainer", "copyright", & + & "description", "keywords", "categories", "homepage", "build", & + & "dependencies", "dev-dependencies", "profiles", "test", "executable", & + & "example", "library", "install", "extra", "preprocess", "fortran") + continue + + end select + end do + if (allocated(error)) return + + if (.not.name_present) then + call syntax_error(error, "Package name is not provided, please add a name entry") + end if + + end subroutine check + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the package configuration + class(package_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr, ii + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & + & fmti = '("#", 1x, a, t30, i0)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Package" + if (allocated(self%name)) then + write(unit, fmt) "- name", self%name + end if + + call self%build%info(unit, pr - 1) + + call self%install%info(unit, pr - 1) + + if (allocated(self%library)) then + write(unit, fmt) "- target", "archive" + call self%library%info(unit, pr - 1) + end if + + if (allocated(self%executable)) then + if (size(self%executable) > 1 .or. pr > 2) then + write(unit, fmti) "- executables", size(self%executable) + end if + do ii = 1, size(self%executable) + call self%executable(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%dependency)) then + if (size(self%dependency) > 1 .or. pr > 2) then + write(unit, fmti) "- dependencies", size(self%dependency) + end if + do ii = 1, size(self%dependency) + call self%dependency(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%example)) then + if (size(self%example) > 1 .or. pr > 2) then + write(unit, fmti) "- examples", size(self%example) + end if + do ii = 1, size(self%example) + call self%example(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%test)) then + if (size(self%test) > 1 .or. pr > 2) then + write(unit, fmti) "- tests", size(self%test) + end if + do ii = 1, size(self%test) + call self%test(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%dev_dependency)) then + if (size(self%dev_dependency) > 1 .or. pr > 2) then + write(unit, fmti) "- development deps.", size(self%dev_dependency) + end if + do ii = 1, size(self%dev_dependency) + call self%dev_dependency(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%profiles)) then + if (size(self%profiles) > 1 .or. pr > 2) then + write(unit, fmti) "- profiles", size(self%profiles) + end if + do ii = 1, size(self%profiles) + call self%profiles(ii)%info(unit, pr - 1) + end do + end if + + end subroutine info + + !> Check whether or not the names in a set of executables are unique + subroutine unique_programs1(executable, error) + + !> Array of executables + class(executable_config_t), intent(in) :: executable(:) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: i, j + + do i = 1, size(executable) + do j = 1, i - 1 + if (executable(i)%name == executable(j)%name) then + call fatal_error(error, "The program named '"//& + executable(j)%name//"' is duplicated. "//& + "Unique program names are required.") + exit + end if + end do + end do + if (allocated(error)) return + + end subroutine unique_programs1 + + !> Check whether or not the names in a set of executables are unique + subroutine unique_programs2(executable_i, executable_j, error) + + !> Array of executables + class(executable_config_t), intent(in) :: executable_i(:) + + !> Array of executables + class(executable_config_t), intent(in) :: executable_j(:) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: i, j + + do i = 1, size(executable_i) + do j = 1, size(executable_j) + if (executable_i(i)%name == executable_j(j)%name) then + call fatal_error(error, "The program named '"//& + executable_j(j)%name//"' is duplicated. "//& + "Unique program names are required.") + exit + end if + end do + end do + if (allocated(error)) return + + end subroutine unique_programs2 + + logical function manifest_is_same(this,that) + class(package_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + integer :: ii + + manifest_is_same = .false. + + select type (other=>that) + type is (package_config_t) + + if (.not.this%name==other%name) return + if (.not.this%version==other%version) return + if (.not.this%build==other%build) return + if (.not.this%install==other%install) return + if (.not.this%fortran==other%fortran) return + if (.not.this%license==other%license) return + if (.not.this%author==other%author) return + if (.not.this%maintainer==other%maintainer) return + if (.not.this%copyright==other%copyright) return + if (allocated(this%library).neqv.allocated(other%library)) return + if (allocated(this%library)) then + if (.not.this%library==other%library) return + endif + if (allocated(this%executable).neqv.allocated(other%executable)) return + if (allocated(this%executable)) then + if (.not.size(this%executable)==size(other%executable)) return + do ii=1,size(this%executable) + if (.not.this%executable(ii)==other%executable(ii)) return + end do + end if + if (allocated(this%dependency).neqv.allocated(other%dependency)) return + if (allocated(this%dependency)) then + if (.not.size(this%dependency)==size(other%dependency)) return + do ii=1,size(this%dependency) + if (.not.this%dependency(ii)==other%dependency(ii)) return + end do + end if + if (allocated(this%dev_dependency).neqv.allocated(other%dev_dependency)) return + if (allocated(this%dev_dependency)) then + if (.not.size(this%dev_dependency)==size(other%dev_dependency)) return + do ii=1,size(this%dev_dependency) + if (.not.this%dev_dependency(ii)==other%dev_dependency(ii)) return + end do + end if + if (allocated(this%profiles).neqv.allocated(other%profiles)) return + if (allocated(this%profiles)) then + if (.not.size(this%profiles)==size(other%profiles)) return + do ii=1,size(this%profiles) + if (.not.this%profiles(ii)==other%profiles(ii)) return + end do + end if + if (allocated(this%example).neqv.allocated(other%example)) return + if (allocated(this%example)) then + if (.not.size(this%example)==size(other%example)) return + do ii=1,size(this%example) + if (.not.this%example(ii)==other%example(ii)) return + end do + end if + if (allocated(this%preprocess).neqv.allocated(other%preprocess)) return + if (allocated(this%preprocess)) then + if (.not.size(this%preprocess)==size(other%preprocess)) return + do ii=1,size(this%preprocess) + if (.not.this%preprocess(ii)==other%preprocess(ii)) return + end do + end if + if (allocated(this%test).neqv.allocated(other%test)) return + if (allocated(this%test)) then + if (.not.size(this%test)==size(other%test)) return + do ii=1,size(this%test) + if (.not.this%test(ii)==other%test(ii)) return + end do + end if + + class default + ! Not the same type + return + end select + + !> All checks passed! + manifest_is_same = .true. + + end function manifest_is_same + + !> Dump manifest to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(package_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr, ii + type(toml_table), pointer :: ptr,ptr_pkg + character(30) :: unnamed + character(128) :: profile_name + + call set_string(table, "name", self%name, error, class_name) + if (allocated(error)) return + call set_string(table, "version", self%version%s(), error, class_name) + if (allocated(error)) return + call set_string(table, "license", self%license, error, class_name) + if (allocated(error)) return + call set_string(table, "author", self%author, error, class_name) + if (allocated(error)) return + call set_string(table, "maintainer", self%maintainer, error, class_name) + if (allocated(error)) return + call set_string(table, "copyright", self%copyright, error, class_name) + if (allocated(error)) return + + call add_table(table, "build", ptr, error, class_name) + if (allocated(error)) return + call self%build%dump_to_toml(ptr, error) + if (allocated(error)) return + + call add_table(table, "fortran", ptr, error, class_name) + if (allocated(error)) return + call self%fortran%dump_to_toml(ptr, error) + if (allocated(error)) return + + call add_table(table, "install", ptr, error, class_name) + if (allocated(error)) return + call self%install%dump_to_toml(ptr, error) + if (allocated(error)) return + + if (allocated(self%library)) then + call add_table(table, "library", ptr, error, class_name) + if (allocated(error)) return + call self%library%dump_to_toml(ptr, error) + if (allocated(error)) return + end if + + if (allocated(self%executable)) then + + call add_table(table, "executable", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'executable' table ") + return + end if + + do ii = 1, size(self%executable) + + associate (pkg => self%executable(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) 'EXECUTABLE',ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(executable)') + else + call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(executable)') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + if (allocated(self%dependency)) then + + call add_table(table, "dependencies", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'dependencies' table ") + return + end if + + do ii = 1, size(self%dependency) + + associate (pkg => self%dependency(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) 'DEPENDENCY',ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(dependencies)') + else + call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(dependencies)') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + if (allocated(self%dev_dependency)) then + + call add_table(table, "dev-dependencies", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'dev-dependencies' table ") + return + end if + + do ii = 1, size(self%dev_dependency) + + associate (pkg => self%dev_dependency(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) 'DEV-DEPENDENCY',ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(dev-dependencies)') + else + call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(dev-dependencies)') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + if (allocated(self%profiles)) then + + call add_table(table, "profiles", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'profiles' table ") + return + end if + + do ii = 1, size(self%profiles) + + associate (pkg => self%profiles(ii)) + + !> Duplicate profile names are possible, as multiple profiles are possible with the + !> same name, same compiler, etc. So, use a unique name here + write(profile_name,2) ii + call add_table(ptr_pkg, trim(profile_name), ptr, error, class_name//'(profiles)') + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + if (allocated(self%example)) then + + call add_table(table, "example", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'example' table ") + return + end if + + do ii = 1, size(self%example) + + associate (pkg => self%example(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) 'EXAMPLE',ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(example)') + else + call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(example)') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + if (allocated(self%test)) then + + call add_table(table, "test", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'test' table ") + return + end if + + do ii = 1, size(self%test) + + associate (pkg => self%test(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) 'TEST',ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(test)') + else + call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(test)') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + if (allocated(self%preprocess)) then + + call add_table(table, "preprocess", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'preprocess' table ") + return + end if + + do ii = 1, size(self%preprocess) + + associate (pkg => self%preprocess(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) 'PREPROCESS',ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(preprocess)') + else + call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(preprocess)') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + 1 format('UNNAMED_',a,'_',i0) + 2 format('PROFILE_',i0) + + end subroutine dump_to_toml + + !> Read manifest from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(package_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: keys(:),pkg_keys(:) + integer :: ierr, ii, jj + character(len=:), allocatable :: flag + type(toml_table), pointer :: ptr,ptr_pkg + + call table%get_keys(keys) + + call get_value(table, "name", self%name) + call get_value(table, "license", self%license) + call get_value(table, "author", self%author) + call get_value(table, "maintainer", self%maintainer) + call get_value(table, "copyright", self%copyright) + call get_value(table, "version", flag) + call new_version(self%version, flag, error) + if (allocated(error)) then + error%message = class_name//': version error from TOML table - '//error%message + return + endif + + if (allocated(self%library)) deallocate(self%library) + if (allocated(self%executable)) deallocate(self%executable) + if (allocated(self%dependency)) deallocate(self%dependency) + if (allocated(self%dev_dependency)) deallocate(self%dev_dependency) + if (allocated(self%profiles)) deallocate(self%profiles) + if (allocated(self%example)) deallocate(self%example) + if (allocated(self%test)) deallocate(self%test) + if (allocated(self%preprocess)) deallocate(self%preprocess) + sub_deps: do ii = 1, size(keys) + + select case (keys(ii)%key) + case ("build") + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table') + return + end if + call self%build%load_from_toml(ptr, error) + if (allocated(error)) return + + case ("install") + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table') + return + end if + call self%install%load_from_toml(ptr, error) + + case ("fortran") + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table') + return + end if + call self%fortran%load_from_toml(ptr, error) + + case ("library") + + allocate(self%library) + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table') + return + end if + call self%library%load_from_toml(ptr, error) + + case ("executable") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving executable table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%executable(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%executable(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case ("dependencies") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving dependency table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%dependency(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%dependency(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case ("dev-dependencies") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving dev-dependencies table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%dev_dependency(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%dev_dependency(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case ("profiles") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving profiles table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%profiles(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%profiles(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case ("example") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving example table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%example(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%example(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case ("test") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving test table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%test(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%test(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case ("preprocess") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving preprocess table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%preprocess(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%preprocess(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case default + cycle sub_deps + end select + + end do sub_deps + + end subroutine load_from_toml + +end module fpm_manifest_package + +!>>>>> ././src/fpm/manifest.f90 + +!> Package configuration data. +!> +!> This module provides the necessary procedure to translate a TOML document +!> to the corresponding Fortran type, while verifying it with respect to +!> its schema. +!> +!> Additionally, the required data types for users of this module are reexported +!> to hide the actual implementation details. +module fpm_manifest + use fpm_manifest_example, only : example_config_t + use fpm_manifest_executable, only : executable_config_t + use fpm_manifest_dependency, only : dependency_config_t + use fpm_manifest_library, only : library_config_t + use fpm_manifest_preprocess, only : preprocess_config_t + use fpm_manifest_package, only : package_config_t, new_package + use fpm_error, only : error_t, fatal_error + use fpm_toml, only : toml_table, read_package_file + use fpm_manifest_test, only : test_config_t + use fpm_filesystem, only: join_path, exists, dirname, is_dir + use fpm_environment, only: os_is_unix + use fpm_strings, only: string_t + implicit none + private + + public :: get_package_data, default_executable, default_library, default_test + public :: default_example + public :: package_config_t, dependency_config_t, preprocess_config_t + +contains + + !> Populate library in case we find the default src directory + subroutine default_library(self) + + !> Instance of the library meta data + type(library_config_t), intent(out) :: self + + self%source_dir = "src" + self%include_dir = [string_t("include")] + + end subroutine default_library + + !> Populate executable in case we find the default app directory + subroutine default_executable(self, name) + + !> Instance of the executable meta data + type(executable_config_t), intent(out) :: self + + !> Name of the package + character(len=*), intent(in) :: name + + self%name = name + self%source_dir = "app" + self%main = "main.f90" + + end subroutine default_executable + + !> Populate test in case we find the default example/ directory + subroutine default_example(self, name) + + !> Instance of the executable meta data + type(example_config_t), intent(out) :: self + + !> Name of the package + character(len=*), intent(in) :: name + + self%name = name // "-demo" + self%source_dir = "example" + self%main = "main.f90" + + end subroutine default_example + + !> Populate test in case we find the default test/ directory + subroutine default_test(self, name) + + !> Instance of the executable meta data + type(test_config_t), intent(out) :: self + + !> Name of the package + character(len=*), intent(in) :: name + + self%name = name // "-test" + self%source_dir = "test" + self%main = "main.f90" + + end subroutine default_test + + !> Obtain package meta data from a configuation file + subroutine get_package_data(package, file, error, apply_defaults) + + !> Parsed package meta data + type(package_config_t), intent(out) :: package + + !> Name of the package configuration file + character(len=*), intent(in) :: file + + !> Error status of the operation + type(error_t), allocatable, intent(out) :: error + + !> Apply package defaults (uses file system operations) + logical, intent(in), optional :: apply_defaults + + type(toml_table), allocatable :: table + character(len=:), allocatable :: root + + call read_package_file(table, file, error) + if (allocated(error)) return + + if (.not. allocated(table)) then + call fatal_error(error, "Unclassified error while reading: '"//file//"'") + return + end if + + call new_package(package, table, dirname(file), error) + if (allocated(error)) return + + if (present(apply_defaults)) then + if (apply_defaults) then + root = dirname(file) + if (len_trim(root) == 0) root = "." + call package_defaults(package, root, error) + if (allocated(error)) return + end if + end if + + end subroutine get_package_data + + !> Apply package defaults + subroutine package_defaults(package, root, error) + + !> Parsed package meta data + type(package_config_t), intent(inout) :: package + + !> Current working directory + character(len=*), intent(in) :: root + + !> Error status of the operation + type(error_t), allocatable, intent(out) :: error + + ! Populate library in case we find the default src directory + if (.not.allocated(package%library) .and. & + & (is_dir(join_path(root, "src")) .or. & + & is_dir(join_path(root, "include")))) then + + allocate(package%library) + call default_library(package%library) + end if + + ! Populate executable in case we find the default app + if (.not.allocated(package%executable) .and. & + & exists(join_path(root, "app", "main.f90"))) then + allocate(package%executable(1)) + call default_executable(package%executable(1), package%name) + end if + + ! Populate example in case we find the default example directory + if (.not.allocated(package%example) .and. & + & exists(join_path(root, "example", "main.f90"))) then + allocate(package%example(1)) + call default_example(package%example(1), package%name) + endif + + ! Populate test in case we find the default test directory + if (.not.allocated(package%test) .and. & + & exists(join_path(root, "test", "main.f90"))) then + allocate(package%test(1)) + call default_test(package%test(1), package%name) + endif + + if (.not.(allocated(package%library) & + & .or. allocated(package%executable) & + & .or. allocated(package%example) & + & .or. allocated(package%test))) then + call fatal_error(error, "Neither library nor executable found, there is nothing to do") + return + end if + + end subroutine package_defaults + +end module fpm_manifest + +!>>>>> ././src/fpm/cmd/new.f90 + +module fpm_cmd_new +!># Definition of the "new" subcommand +!> +!> A type of the general command base class [[fpm_cmd_settings]] +!> was created for the "new" subcommand ==> type [[fpm_new_settings]]. +!> This procedure read the values that were set on the command line +!> from this type to decide what actions to take. +!> +!> It is virtually self-contained and so independant of the rest of the +!> application that it could function as a separate program. +!> +!> The "new" subcommand options currently consist of a SINGLE top +!> directory name to create that must have a name that is an +!> allowable Fortran variable name. That should have been ensured +!> by the command line processing before this procedure is called. +!> So basically this routine has already had the options vetted and +!> just needs to conditionally create a few files. +!> +!> As described in the documentation it will selectively +!> create the subdirectories app/, test/, src/, and example/ +!> and populate them with sample files. +!> +!> It also needs to create an initial manifest file "fpm.toml". +!> +!> It then calls the system command "git init". +!> +!> It should test for file existence and not overwrite existing +!> files and inform the user if there were conflicts. +!> +!> Any changes should be reflected in the documentation in +!> [[fpm_command_line.f90]] +!> +!> FUTURE +!> A filename like "." would need system commands or a standard routine +!> like realpath(3c) to process properly. +!> +!> Perhaps allow more than one name on a single command. It is an arbitrary +!> restriction based on a concensus preference, not a required limitation. +!> +!> Initially the name of the directory is used as the module name in the +!> src file so it must be an allowable Fortran variable name. If there are +!> complaints about it it might be changed. Handling unicode at this point +!> might be problematic as not all current compilers handle it. Other +!> utilities like content trackers (ie. git) or repositories like github +!> might also have issues with alternative names or names with spaces, etc. +!> So for the time being it seems prudent to encourage simple ASCII top directory +!> names (similiar to the primary programming language Fortran itself). +!> +!> Should be able to create or pull more complicated initial examples +!> based on various templates. It should place or mention other relevant +!> documents such as a description of the manifest file format in user hands; +!> or how to access registered packages and local packages, +!> although some other command might provide that (and the help command should +!> be the first go-to for a CLI utility). + +use fpm_command_line, only : fpm_new_settings +use fpm_environment, only : OS_LINUX, OS_MACOS, OS_WINDOWS +use fpm_filesystem, only : join_path, exists, basename, mkdir, is_dir +use fpm_filesystem, only : fileopen, fileclose, warnwrite, which, run +use fpm_strings, only : join, to_fortran_name +use fpm_error, only : fpm_stop + +use,intrinsic :: iso_fortran_env, only : stderr=>error_unit +implicit none +private +public :: cmd_new + +contains + +subroutine cmd_new(settings) +type(fpm_new_settings), intent(in) :: settings +integer,parameter :: tfc = selected_char_kind('DEFAULT') +character(len=:,kind=tfc),allocatable :: bname ! baeename of NAME +character(len=:,kind=tfc),allocatable :: tomlfile(:) +character(len=:,kind=tfc),allocatable :: littlefile(:) + + !> TOP DIRECTORY NAME PROCESSING + !> see if requested new directory already exists and process appropriately + if(exists(settings%name) .and. .not.settings%backfill )then + write(stderr,'(*(g0,1x))')& + & '',settings%name,'already exists.' + write(stderr,'(*(g0,1x))')& + & ' perhaps you wanted to add --backfill ?' + return + elseif(is_dir(settings%name) .and. settings%backfill )then + write(*,'(*(g0))')'backfilling ',settings%name + elseif(exists(settings%name) )then + write(stderr,'(*(g0,1x))')& + & '',settings%name,'already exists and is not a directory.' + return + else + ! make new directory + call mkdir(settings%name) + endif + + !> temporarily change to new directory as a test. NB: System dependent + call run('cd '//settings%name) + ! NOTE: need some system routines to handle filenames like "." + ! like realpath() or getcwd(). + bname=basename(settings%name) + + littlefile=[character(len=80) :: '# '//bname, 'My cool new project!'] + + ! create NAME/README.md + call warnwrite(join_path(settings%name, 'README.md'), littlefile) + + ! start building NAME/fpm.toml + if(settings%with_full)then + tomlfile=[character(len=80) :: & + &' # This is your fpm(Fortran Package Manager) manifest file ',& + &' # ("fpm.toml"). It is heavily annotated to help guide you though ',& + &' # customizing a package build, although the defaults are sufficient ',& + &' # for many basic packages. ',& + &' # ',& + &' # The manifest file is not only used to provide metadata identifying ',& + &' # your project (so it can be used by others as a dependency). It can ',& + &' # specify where your library and program sources live, what the name ',& + &' # of the executable(s) will be, what files to build, dependencies on ',& + &' # other fpm packages, and what external libraries are required. ',& + &' # ',& + &' # The manifest format must conform to the TOML configuration file ',& + &' # standard. ',& + &' # ',& + &' # TOML files support flexible use of white-space and commenting of the ',& + &' # configuration data, but for clarity in this sample active directives ',& + &' # begin in column one. Inactive example directives are commented ',& + &' # out with a pound character ("#") but begin in column one as well. ',& + &' # Commentary begins with a pound character in column three. ',& + &' # ',& + &' # This file draws heavily upon the following references: ',& + &' # ',& + &' # The fpm home page at ',& + &' # https://github.com/fortran-lang/fpm ',& + &' # A complete list of keys and their attributes at ',& + &' # https://github.com/fortran-lang/fpm/blob/main/manifest-reference.md ',& + &' # examples of fpm project packaging at ',& + &' # https://github.com/fortran-lang/fpm/blob/main/PACKAGING.md ',& + &' # The Fortran TOML file interface and it''s references at ',& + &' # https://github.com/toml-f/toml-f ',& + &' # ',& + &' #----------------------- ',& + &' # project Identification ',& + &' #----------------------- ',& + &' # We begin with project metadata at the manifest root. This data is designed ',& + &' # to aid others when searching for the project in a repository and to ',& + &' # identify how and when to contact the package supporters. ',& + &' ',& + &'name = "'//bname//'"',& + &' # The project name (required) is how the project will be referred to. ',& + &' # The name is used by other packages using it as a dependency. It also ',& + &' # is used as the default name of any library built and the optional ',& + &' # default executable built from app/main.f90. It must conform to the rules ',& + &' # for a Fortran variable name. ',& + &' ',& + &'version = "0.1.0" ',& + &' # The project version number is a string. A recommended scheme for ',& + &' # specifying versions is the Semantic Versioning scheme. ',& + &' ',& + &'license = "license" ',& + &' # Licensing information specified using SPDX identifiers is preferred ',& + &' # (eg. "Apache-2.0 OR MIT" or "LGPL-3.0-or-later"). ',& + &' ',& + &'maintainer = "jane.doe@example.com" ',& + &' # Information on the project maintainer and means to reach out to them. ',& + &' ',& + &'author = "Jane Doe" ',& + &' # Information on the project author. ',& + &' ',& + &'copyright = "Copyright 2020 Jane Doe" ',& + &' # A statement clarifying the Copyright status of the project. ',& + &' ',& + &'#description = "A short project summary in plain text" ',& + &' # The description provides a short summary on the project. It should be ',& + &' # plain text and not use any markup formatting. ',& + &' ',& + &'#categories = ["fortran", "graphics"] ',& + &' # Categories associated with the project. Listing only one is preferred. ',& + &' ',& + &'#keywords = ["hdf5", "mpi"] ',& + &' # The keywords field is an array of strings describing the project. ',& + &' ',& + &'#homepage = "https://stdlib.fortran-lang.org" ',& + &' # URL to the webpage of the project. ',& + &' ',& + &' # ----------------------------------------- ',& + &' # We are done with identifying the project. ',& + &' # ----------------------------------------- ',& + &' # ',& + &' # Now lets start describing how the project should be built. ',& + &' # ',& + &' # Note tables would go here but we will not be talking about them (much)!!' ,& + &' # ',& + &' # Tables are a way to explicitly specify large numbers of programs in ',& + &' # a compact format instead of individual per-program entries in the ',& + &' # [[executable]], [[test]], and [[example]] sections to follow but ',& + &' # will not be discussed further except for the following notes: ',& + &' # ',& + &' # + Tables must appear (here) before any sections are declared. Once a ',& + &' # section is specified in a TOML file everything afterwards must be ',& + &' # values for that section or the beginning of a new section. A simple ',& + &' # example looks like: ',& + &' ',& + &'#executable = [ ',& + &'# { name = "a-prog" }, ',& + &'# { name = "app-tool", source-dir = "tool" }, ',& + &'# { name = "fpm-man", source-dir = "tool", main="fman.f90" } ',& + &'#] ',& + &' ',& + &' # This would be in lieue of the [[executable]] section found later in this ',& + &' # configuration file. ',& + &' # + See the reference documents (at the beginning of this document) ',& + &' # for more information on tables if you have long lists of programs ',& + &' # to build and are not simply depending on auto-detection. ',& + &' # ',& + &' # Now lets begin the TOML sections (lines beginning with "[") ... ',& + &' # ',& + &' ',& + &'[install] # Options for the "install" subcommand ',& + &' ',& + &' # When you run the "install" subcommand only executables are installed by ',& + &' # default on the local system. Library projects that will be used outside of ',& + &' # "fpm" can set the "library" boolean to also allow installing the module ',& + &' # files and library archive. Without this being set to "true" an "install" ',& + &' # subcommand ignores parameters that specify library installation. ',& + &' ',& + &'library = false ',& + &' ',& + &'[build] # General Build Options ',& + &' ',& + &' ### Automatic target discovery ',& + &' # ',& + &' # Normally fpm recursively searches the app/, example/, and test/ directories ',& + &' # for program sources and builds them. To disable this automatic discovery of ',& + &' # program targets set the following to "false": ',& + &' ',& + &'#auto-executables = true ',& + &'#auto-examples = true ',& + &'#auto-tests = true ',& + &' ',& + &' ### Package-level External Library Links ',& + &' # ',& + &' # To declare link-time dependencies on external libraries a list of ',& + &' # native libraries can be specified with the "link" entry. You may ',& + &' # have one library name or a list of strings in case several ',& + &' # libraries should be linked. This list of library dependencies is ',& + &' # exported to dependent packages. You may have to alter your library ',& + &' # search-path to ensure the libraries can be accessed. Typically, ',& + &' # this is done with the LD_LIBRARY_PATH environment variable on ULS ',& + &' # (Unix-Like Systems). You only specify the core name of the library ',& + &' # (as is typical with most programming environments, where you ',& + &' # would specify "-lz" on your load command to link against the zlib ',& + &' # compression library even though the library file would typically be ',& + &' # a file called "libz.a" "or libz.so"). So to link against that library ',& + &' # you would specify: ',& + &' ',& + &'#link = "z" ',& + &' ',& + &' # Note that in some cases the order of the libraries matters: ',& + &' ',& + &'#link = ["blas", "lapack"] ',& + &''] + endif + + if(settings%with_bare)then + elseif(settings%with_lib)then + call mkdir(join_path(settings%name,'src') ) + ! create next section of fpm.toml + if(settings%with_full)then + tomlfile=[character(len=80) :: tomlfile, & + &'[library] ',& + &' ',& + &' # You can change the name of the directory to search for your library ',& + &' # source from the default of "src/". Library targets are exported ',& + &' # and usable by other projects. ',& + &' ',& + &'source-dir="src" ',& + &' ',& + &' # this can be a list: ',& + &' ',& + &'#source-dir=["src", "src2"] ',& + &' ',& + &' # More complex libraries may organize their modules in subdirectories. ',& + &' # For modules in a top-level directory fpm requires (but does not ',& + &' # enforce) that: ',& + &' # ',& + &' # + The module has the same name as the source file. This is important. ',& + &' # + There should be only one module per file. ',& + &' # ',& + &' # These two requirements simplify the build process for fpm. As Fortran ',& + &' # compilers emit module files (.mod) with the same name as the module ',& + &' # itself (but not the source file, .f90), naming the module the same ',& + &' # as the source file allows fpm to: ',& + &' # ',& + &' # + Uniquely and exactly map a source file (.f90) to its object (.o) ',& + &' # and module (.mod) files. ',& + &' # + Avoid conflicts with modules of the same name that could appear ',& + &' # in dependency packages. ',& + &' # ',& + &' ### Multi-level library source ',& + &' # You can place your module source files in any number of levels of ',& + &' # subdirectories inside your source directory, but there are certain naming ',& + &' # conventions to be followed -- module names must contain the path components ',& + &' # of the directory that its source file is in. ',& + &' # ',& + &' # This rule applies generally to any number of nested directories and ',& + &' # modules. For example, src/a/b/c/d.f90 must define a module called a_b_c_d. ',& + &' # Again, this is not enforced but may be required in future releases. ',& + &''] + endif + ! create placeholder module src/bname.f90 + littlefile=[character(len=80) :: & + &'module '//to_fortran_name(bname), & + &' implicit none', & + &' private', & + &'', & + &' public :: say_hello', & + &'contains', & + &' subroutine say_hello', & + &' print *, "Hello, '//bname//'!"', & + &' end subroutine say_hello', & + &'end module '//to_fortran_name(bname)] + ! create NAME/src/NAME.f90 + call warnwrite(join_path(settings%name, 'src', bname//'.f90'),& + & littlefile) + endif + + if(settings%with_full)then + tomlfile=[character(len=80) :: tomlfile ,& + &'[dependencies] ',& + &' ',& + &' # Inevitably, you will want to be able to include other packages in ',& + &' # a project. Fpm makes this incredibly simple, by taking care of ',& + &' # fetching and compiling your dependencies for you. You just tell it ',& + &' # what your dependencies names are, and where to find them. ',& + &' # ',& + &' # If you are going to distribute your package only place dependencies ',& + &' # here someone using your package as a remote dependency needs built. ',& + &' # You can define dependencies just for developer executables in the ',& + &' # next section, or even for specific executables as we will see below ',& + &' # (Then fpm will still fetch and compile it when building your ',& + &' # developer executables, but users of your library will not have to). ',& + &' # ',& + &' ## GLOBAL DEPENDENCIES (exported with your project) ',& + &' # ',& + &' # Typically, dependencies are defined by specifying the project''s ',& + &' # git repository. ',& + &' # ',& + &' # You can be specific about which version of a dependency you would ',& + &' # like. By default the latest default branch is used. You can ',& + &' # optionally specify a branch, a tag or a commit value. ',& + &' # ',& + &' # So here are several alternates for specifying a remote dependency (you ',& + &' # can have at most one of "branch", "rev" or "tag" present): ',& + &' ',& + &'#stdlib = { git = "https://github.com/LKedward/stdlib-fpm.git" } ',& + &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git",branch = "master" },',& + &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git", tag = "v0.1.0" }, ',& + &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git", rev = "5a9b7a8" }. ',& + &' ',& + &' # There may be multiple packages listed: ',& + &' ',& + &'#M_strings = { git = "https://github.com/urbanjost/M_strings.git" } ',& + &'#M_time = { git = "https://github.com/urbanjost/M_time.git" } ',& + &' ',& + &' # ',& + &' # You can even specify the local path to another project if it is in ',& + &' # a sub-folder (If for example you have got another fpm package **in ',& + &' # the same repository**) like this: ',& + &' ',& + &'#M_strings = { path = "M_strings" } ',& + &' ',& + &' # This tells fpm that we depend on a crate called M_strings which is found ',& + &' # in the M_strings folder (relative to the fpm.toml it’s written in). ',& + &' # ',& + &' # For a more verbose layout use normal tables rather than inline tables ',& + &' # to specify dependencies: ',& + &' ',& + &'#[dependencies.toml-f] ',& + &'#git = "https://github.com/toml-f/toml-f" ',& + &'#rev = "2f5eaba864ff630ba0c3791126a3f811b6e437f3" ',& + &' ',& + &' # Now you can use any modules from these libraries anywhere in your ',& + &' # code -- whether is in your library source or a program source. ',& + &' ',& + &'[dev-dependencies] ',& + &' ',& + &' ## Dependencies Only for Development ',& + &' # ',& + &' # You can specify dependencies your library or application does not ',& + &' # depend on in a similar way. The difference is that these will not ',& + &' # be exported as part of your project to those using it as a remote ',& + &' # dependency. ',& + &' # ',& + &' # Currently, like a global dependency it will still be available for ',& + &' # all codes. It is up to the developer to ensure that nothing except ',& + &' # developer test programs rely upon it. ',& + &' ',& + &'#M_msg = { git = "https://github.com/urbanjost/M_msg.git" } ',& + &'#M_verify = { git = "https://github.com/urbanjost/M_verify.git" } ',& + &''] + endif + if(settings%with_bare)then + elseif(settings%with_executable)then + ! create next section of fpm.toml + call mkdir(join_path(settings%name, 'app')) + ! create NAME/app or stop + if(settings%with_full)then + tomlfile=[character(len=80) :: tomlfile, & + &' #----------------------------------- ',& + &' ## Application-specific declarations ',& + &' #----------------------------------- ',& + &' # Now lets begin entries for the TOML tables (lines beginning with "[[") ',& + &' # that describe the program sources -- applications, tests, and examples. ',& + &' # ',& + &' # First we will configuration individual applications run with "fpm run". ',& + &' # ',& + &' # + the "name" entry for the executable to be built must always ',& + &' # be specified. The name must satisfy the rules for a Fortran ',& + &' # variable name. This will be the name of the binary installed by ',& + &' # the "install" subcommand and used on the "run" subcommand. ',& + &' # + The source directory for each executable can be adjusted by the ',& + &' # "source-dir" entry. ',& + &' # + The basename of the source file containing the program body can ',& + &' # be specified with the "main" entry. ',& + &' # + Executables can also specify their own external package and ',& + &' # library link dependencies. ',& + &' # ',& + &' # Currently, like a global dependency any external package dependency ',& + &' # will be available for all codes. It is up to the developer to ensure ',& + &' # that nothing except the application programs specified rely upon it. ',& + &' # ',& + &' # Note if your application needs to use a module internally, but you do not ',& + &' # intend to build it as a library to be used in other projects, you can ',& + &' # include the module in your program source file or directory as well. ',& + &' ',& + &'[[executable]] ',& + &'name="'//bname//'"',& + &'source-dir="app" ',& + &'main="main.f90" ',& + &' ',& + &' # You may repeat this pattern to define additional applications. For instance,',& + &' # the following sample illustrates all accepted options, where "link" and ',& + &' # "executable.dependencies" keys are the same as the global external library ',& + &' # links and package dependencies described previously except they apply ',& + &' # only to this executable: ',& + &' ',& + &'#[[ executable ]] ',& + &'#name = "app-name" ',& + &'#source-dir = "prog" ',& + &'#main = "program.f90" ',& + &'#link = "z" ',& + &'#[executable.dependencies] ',& + &'#M_CLI = { git = "https://github.com/urbanjost/M_CLI.git" } ',& + &'#helloff = { git = "https://gitlab.com/everythingfunctional/helloff.git" } ',& + &'#M_path = { git = "https://github.com/urbanjost/M_path.git" } ',& + &''] + endif + + if(exists(bname//'/src/'))then + littlefile=[character(len=80) :: & + &'program main', & + &' use '//to_fortran_name(bname)//', only: say_hello', & + &' implicit none', & + &'', & + &' call say_hello()', & + &'end program main'] + else + littlefile=[character(len=80) :: & + &'program main', & + &' implicit none', & + &'', & + &' print *, "hello from project '//bname//'"', & + &'end program main'] + endif + call warnwrite(join_path(settings%name, 'app/main.f90'), littlefile) + endif + + if(settings%with_bare)then + elseif(settings%with_test)then + + ! create NAME/test or stop + call mkdir(join_path(settings%name, 'test')) + ! create next section of fpm.toml + if(settings%with_full)then + tomlfile=[character(len=80) :: tomlfile ,& + &'[[test]] ',& + &' ',& + &' # The same declarations can be made for test programs, which are ',& + &' # executed with the "fpm test" command and are not build when your ',& + &' # package is used as a dependency by other packages. These are ',& + &' # typically unit tests of the package only used during package ',& + &' # development. ',& + &' ',& + &'name="runTests" ',& + &'source-dir="test" ',& + &'main="check.f90" ',& + &' ',& + &' # you may repeat this pattern to add additional explicit test program ',& + &' # parameters. The following example contains a sample of all accepted ',& + &' # options. ',& + &' ',& + &'#[[ test ]] ',& + &'#name = "tester" ',& + &'#source-dir="test" ',& + &'#main="tester.f90" ',& + &'#link = ["blas", "lapack"] ',& + &'#[test.dependencies] ',& + &'#M_CLI2 = { git = "https://github.com/urbanjost/M_CLI2.git" } ',& + &'#M_io = { git = "https://github.com/urbanjost/M_io.git" } ',& + &'#M_system= { git = "https://github.com/urbanjost/M_system.git" } ',& + &''] + endif + + littlefile=[character(len=80) :: & + &'program check', & + &'implicit none', & + &'', & + &'print *, "Put some tests in here!"', & + &'end program check'] + ! create NAME/test/check.f90 + call warnwrite(join_path(settings%name, 'test/check.f90'), littlefile) + endif + + if(settings%with_bare)then + elseif(settings%with_example)then + + ! create NAME/example or stop + call mkdir(join_path(settings%name, 'example')) + ! create next section of fpm.toml + if(settings%with_full)then + tomlfile=[character(len=80) :: tomlfile, & + &'[[example]] ',& + &' ',& + &' # Example applications for a project are defined here. ',& + &' # These are run via "fpm run --example NAME" and like the ',& + &' # test applications, are not built when this package is used as a ',& + &' # dependency by other packages. ',& + &' ',& + &'name="demo" ',& + &'source-dir="example" ',& + &'main="demo.f90" ',& + &' ',& + &' # ',& + &' # you may add additional programs to the example table. The following ',& + &' # example contains a sample of all accepted options ',& + &' ',& + &'#[[ example ]] ',& + &'#name = "example-tool" ',& + &'#source-dir="example" ',& + &'#main="tool.f90" ',& + &'#link = "z" ',& + &'#[example.dependencies] ',& + &'#M_kracken95 = { git = "https://github.com/urbanjost/M_kracken95.git" } ',& + &'#datetime = {git = "https://github.com/wavebitscientific/datetime-fortran.git" }',& + &''] + endif + + littlefile=[character(len=80) :: & + &'program demo', & + &'implicit none', & + &'', & + &'print *, "Put some examples in here!"', & + &'end program demo'] + ! create NAME/example/demo.f90 + call warnwrite(join_path(settings%name, 'example/demo.f90'), littlefile) + endif + + ! now that built it write NAME/fpm.toml + if( allocated(tomlfile) )then + call validate_toml_data(tomlfile) + call warnwrite(join_path(settings%name, 'fpm.toml'), tomlfile) + else + call create_verified_basic_manifest(join_path(settings%name, 'fpm.toml')) + endif + ! assumes git(1) is installed and in path + if(which('git')/='')then + call run('git init ' // settings%name) + endif +contains + +function git_metadata(what) result(returned) +!> get metadata values such as email address and git name from git(1) or return appropriate default + use fpm_filesystem, only : get_temp_filename, getline + character(len=*), intent(in) :: what ! keyword designating what git metatdata to query + character(len=:), allocatable :: returned ! value to return for requested keyword + character(len=:), allocatable :: command + character(len=:), allocatable :: temp_filename + character(len=:), allocatable :: iomsg + character(len=:), allocatable :: temp_value + integer :: stat, unit + temp_filename = get_temp_filename() + ! for known keywords set default value for RETURNED and associated git(1) command for query + select case(what) + case('uname') + returned = "Jane Doe" + command = "git config --get user.name > " // temp_filename + case('email') + returned = "jane.doe@example.com" + command = "git config --get user.email > " // temp_filename + case default + write(stderr,'(*(g0,1x))')& + & ' *git_metadata* unknown metadata name ',trim(what) + returned='' + return + end select + ! Execute command if git(1) is in command path + if(which('git')/='')then + call run(command, exitstat=stat) + if (stat /= 0) then ! If command failed just return default + return + else ! Command did not return an error so try to read expected output file + open(file=temp_filename, newunit=unit,iostat=stat) + if(stat == 0)then + ! Read file into a scratch variable until status of doing so is checked + call getline(unit, temp_value, stat, iomsg) + if (stat == 0 .and. temp_value /= '') then + ! Return output from successful command + returned=temp_value + endif + endif + ! Always do the CLOSE because a failed open has unpredictable results. + ! Add IOSTAT so a failed close does not cause program to stop + close(unit, status="delete",iostat=stat) + endif + endif +end function git_metadata + +subroutine create_verified_basic_manifest(filename) +!> create a basic but verified default manifest file +use fpm_toml, only : toml_table, toml_serialize, set_value +use fpm_manifest_package, only : package_config_t, new_package +use fpm_error, only : error_t +implicit none +character(len=*),intent(in) :: filename + type(toml_table) :: table + type(package_config_t) :: package + type(error_t), allocatable :: error + integer :: lun + character(len=8) :: date + character(:), allocatable :: output + + if(exists(filename))then + write(stderr,'(*(g0,1x))')' ',filename,& + & 'already exists. Not overwriting' + return + endif + !> get date to put into metadata in manifest file "fpm.toml" + call date_and_time(DATE=date) + table = toml_table() + call fileopen(filename,lun) ! fileopen stops on error + + call set_value(table, "name", BNAME) + call set_value(table, "version", "0.1.0") + call set_value(table, "license", "license") + call set_value(table, "author", git_metadata('uname')) + call set_value(table, "maintainer", git_metadata('email')) + call set_value(table, "copyright", 'Copyright '//date(1:4)//', '//git_metadata('uname')) + ! continue building of manifest + ! ... + call new_package(package, table, error=error) + if (allocated(error)) call fpm_stop( 3,'') + output = toml_serialize(table) + if(settings%verbose)then + print '(a)', output + endif + write(lun, '(a)') output + call fileclose(lun) ! fileopen stops on error + +end subroutine create_verified_basic_manifest + +subroutine validate_toml_data(input) +!> verify a string array is a valid fpm.toml file +! +use tomlf, only : toml_load +use fpm_toml, only : toml_table, toml_serialize +implicit none +character(kind=tfc,len=:),intent(in),allocatable :: input(:) +character(len=1), parameter :: nl = new_line('a') +type(toml_table), allocatable :: table +character(kind=tfc, len=:), allocatable :: joined_string + +! you have to add a newline character by using the intrinsic +! function `new_line("a")` to get the lines processed correctly. +joined_string = join(input,right=nl) + +if (allocated(table)) deallocate(table) +call toml_load(table, joined_string) +if (allocated(table)) then + if(settings%verbose)then + ! If the TOML file is successfully parsed the table will be allocated and + ! can be written by `toml_serialize` to the standard output + print '(a)', toml_serialize(table) + endif + call table%destroy +endif + +end subroutine validate_toml_data + +end subroutine cmd_new + +end module fpm_cmd_new + +!>>>>> ././src/fpm_compiler.F90 + +!># Define compiler command options +!! +!! This module defines compiler options to use for the debug and release builds. + +! vendor Fortran C Module output Module include OpenMP Free for OSS +! compiler compiler directory directory +! Gnu gfortran gcc -J -I -fopenmp X +! Intel ifort icc -module -I -qopenmp X +! Intel(Windows) ifort icc /module:path /I /Qopenmp X +! Intel oneAPI ifx icx -module -I -qopenmp X +! PGI pgfortran pgcc -module -I -mp X +! NVIDIA nvfortran nvc -module -I -mp X +! LLVM flang flang clang -module -I -mp X +! LFortran lfortran --- -J -I --openmp X +! Lahey/Futjitsu lfc ? -M -I -openmp ? +! NAG nagfor ? -mdir -I -openmp x +! Cray crayftn craycc -J -I -homp ? +! IBM xlf90 ? -qmoddir -I -qsmp X +! Oracle/Sun ? ? -moddir= -M -xopenmp ? +! Silverfrost FTN95 ftn95 ? ? /MOD_PATH ? ? +! Elbrus ? lcc -J -I -fopenmp ? +! Hewlett Packard ? ? ? ? ? discontinued +! Watcom ? ? ? ? ? discontinued +! PathScale ? ? -module -I -mp discontinued +! G95 ? ? -fmod= -I -fopenmp discontinued +! Open64 ? ? -module -I -mp discontinued +! Unisys ? ? ? ? ? discontinued +module fpm_compiler +use,intrinsic :: iso_fortran_env, only: stderr=>error_unit +use fpm_environment, only: & + get_os_type, & + OS_LINUX, & + OS_MACOS, & + OS_WINDOWS, & + OS_CYGWIN, & + OS_SOLARIS, & + OS_FREEBSD, & + OS_OPENBSD, & + OS_UNKNOWN +use fpm_filesystem, only: join_path, basename, get_temp_filename, delete_file, unix_path, & + & getline, run +use fpm_strings, only: split, string_cat, string_t, str_ends_with, str_begins_with_str +use fpm_manifest, only : package_config_t +use fpm_error, only: error_t, fatal_error +use fpm_toml, only: serializable_t, toml_table, set_string, set_value, toml_stat, get_value +implicit none +public :: compiler_t, new_compiler, archiver_t, new_archiver, get_macros +public :: debug + +enum, bind(C) + enumerator :: & + id_unknown, & + id_gcc, & + id_f95, & + id_caf, & + id_intel_classic_nix, & + id_intel_classic_mac, & + id_intel_classic_windows, & + id_intel_llvm_nix, & + id_intel_llvm_windows, & + id_intel_llvm_unknown, & + id_pgi, & + id_nvhpc, & + id_nag, & + id_flang, & + id_flang_new, & + id_f18, & + id_ibmxl, & + id_cray, & + id_lahey, & + id_lfortran +end enum +integer, parameter :: compiler_enum = kind(id_unknown) + +!> Definition of compiler object +type, extends(serializable_t) :: compiler_t + !> Identifier of the compiler + integer(compiler_enum) :: id = id_unknown + !> Path to the Fortran compiler + character(len=:), allocatable :: fc + !> Path to the C compiler + character(len=:), allocatable :: cc + !> Path to the C++ compiler + character(len=:), allocatable :: cxx + !> Print all commands + logical :: echo = .true. + !> Verbose output of command + logical :: verbose = .true. +contains + !> Get default compiler flags + procedure :: get_default_flags + !> Get flag for module output directories + procedure :: get_module_flag + !> Get flag for include directories + procedure :: get_include_flag + !> Get feature flag + procedure :: get_feature_flag + !> Get flags for the main linking command + procedure :: get_main_flags + !> Compile a Fortran object + procedure :: compile_fortran + !> Compile a C object + procedure :: compile_c + !> Compile a CPP object + procedure :: compile_cpp + !> Link executable + procedure :: link + !> Check whether compiler is recognized + procedure :: is_unknown + !> Check whether this is an Intel compiler + procedure :: is_intel + !> Check whether this is a GNU compiler + procedure :: is_gnu + !> Enumerate libraries, based on compiler and platform + procedure :: enumerate_libraries + + !> Serialization interface + procedure :: serializable_is_same => compiler_is_same + procedure :: dump_to_toml => compiler_dump + procedure :: load_from_toml => compiler_load + !> Fortran feature support + procedure :: check_fortran_source_runs + procedure :: with_xdp + procedure :: with_qp + !> Return compiler name + procedure :: name => compiler_name + +end type compiler_t + +!> Definition of archiver object +type, extends(serializable_t) :: archiver_t + !> Path to archiver + character(len=:), allocatable :: ar + !> Use response files to pass arguments + logical :: use_response_file = .false. + !> Print all command + logical :: echo = .true. + !> Verbose output of command + logical :: verbose = .true. +contains + !> Create static archive + procedure :: make_archive + + !> Serialization interface + procedure :: serializable_is_same => ar_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + +end type archiver_t + +!> Create debug printout +interface debug + module procedure :: debug_compiler + module procedure :: debug_archiver +end interface debug + +character(*), parameter :: & + flag_gnu_coarray = " -fcoarray=single", & + flag_gnu_backtrace = " -fbacktrace", & + flag_gnu_opt = " -O3 -funroll-loops", & + flag_gnu_debug = " -g", & + flag_gnu_pic = " -fPIC", & + flag_gnu_warn = " -Wall -Wextra", & + flag_gnu_check = " -fcheck=bounds -fcheck=array-temps", & + flag_gnu_limit = " -fmax-errors=1", & + flag_gnu_external = " -Wimplicit-interface", & + flag_gnu_openmp = " -fopenmp", & + flag_gnu_no_implicit_typing = " -fimplicit-none", & + flag_gnu_no_implicit_external = " -Werror=implicit-interface", & + flag_gnu_free_form = " -ffree-form", & + flag_gnu_fixed_form = " -ffixed-form" + +character(*), parameter :: & + flag_pgi_backslash = " -Mbackslash", & + flag_pgi_traceback = " -traceback", & + flag_pgi_debug = " -g", & + flag_pgi_check = " -Mbounds -Mchkptr -Mchkstk", & + flag_pgi_warn = " -Minform=inform", & + flag_pgi_openmp = " -mp", & + flag_pgi_free_form = " -Mfree", & + flag_pgi_fixed_form = " -Mfixed" + +character(*), parameter :: & + flag_ibmxl_backslash = " -qnoescape" + +character(*), parameter :: & + flag_intel_backtrace = " -traceback", & + flag_intel_warn = " -warn all", & + flag_intel_check = " -check all", & + flag_intel_debug = " -O0 -g", & + flag_intel_opt = " -O3", & + flag_intel_fp = " -fp-model precise -pc64", & + flag_intel_align = " -align all", & + flag_intel_limit = " -error-limit 1", & + flag_intel_pthread = " -reentrancy threaded", & + flag_intel_nogen = " -nogen-interfaces", & + flag_intel_byterecl = " -assume byterecl", & + flag_intel_openmp = " -qopenmp", & + flag_intel_free_form = " -free", & + flag_intel_fixed_form = " -fixed", & + flag_intel_standard_compliance = " -standard-semantics" + +character(*), parameter :: & + flag_intel_llvm_check = " -check all,nouninit" + +character(*), parameter :: & + flag_intel_backtrace_win = " /traceback", & + flag_intel_warn_win = " /warn:all", & + flag_intel_check_win = " /check:all", & + flag_intel_debug_win = " /Od /Z7", & + flag_intel_opt_win = " /O3", & + flag_intel_fp_win = " /fp:precise", & + flag_intel_align_win = " /align:all", & + flag_intel_limit_win = " /error-limit:1", & + flag_intel_pthread_win = " /reentrancy:threaded", & + flag_intel_nogen_win = " /nogen-interfaces", & + flag_intel_byterecl_win = " /assume:byterecl", & + flag_intel_openmp_win = " /Qopenmp", & + flag_intel_free_form_win = " /free", & + flag_intel_fixed_form_win = " /fixed", & + flag_intel_standard_compliance_win = " /standard-semantics" + +character(*), parameter :: & + flag_nag_coarray = " -coarray=single", & + flag_nag_pic = " -PIC", & + flag_nag_check = " -C", & + flag_nag_debug = " -g -O0", & + flag_nag_opt = " -O4", & + flag_nag_backtrace = " -gline", & + flag_nag_openmp = " -openmp", & + flag_nag_free_form = " -free", & + flag_nag_fixed_form = " -fixed", & + flag_nag_no_implicit_typing = " -u" + +character(*), parameter :: & + flag_lfortran_opt = " --fast", & + flag_lfortran_openmp = " --openmp", & + flag_lfortran_implicit_typing = " --implicit-typing", & + flag_lfortran_implicit_external = " --implicit-interface", & + flag_lfortran_fixed_form = " --fixed-form" + +character(*), parameter :: & + flag_cray_no_implicit_typing = " -dl", & + flag_cray_implicit_typing = " -el", & + flag_cray_fixed_form = " -ffixed", & + flag_cray_free_form = " -ffree" + +contains + +function get_default_flags(self, release) result(flags) + class(compiler_t), intent(in) :: self + logical, intent(in) :: release + character(len=:), allocatable :: flags + + if (release) then + call get_release_compile_flags(self%id, flags) + else + call get_debug_compile_flags(self%id, flags) + end if + +end function get_default_flags + +subroutine get_release_compile_flags(id, flags) + integer(compiler_enum), intent(in) :: id + character(len=:), allocatable, intent(out) :: flags + + select case(id) + case default + flags = "" + case(id_caf) + flags = & + flag_gnu_opt//& + flag_gnu_external//& + flag_gnu_pic//& + flag_gnu_limit + + case(id_gcc) + flags = & + flag_gnu_opt//& + flag_gnu_external//& + flag_gnu_pic//& + flag_gnu_limit//& + flag_gnu_coarray + + case(id_f95) + flags = & + flag_gnu_opt//& + flag_gnu_external//& + flag_gnu_pic//& + flag_gnu_limit + + case(id_nvhpc) + flags = & + flag_pgi_backslash + + case(id_ibmxl) + flags = & + flag_ibmxl_backslash + + case(id_intel_classic_nix) + flags = & + flag_intel_opt//& + flag_intel_fp//& + flag_intel_align//& + flag_intel_limit//& + flag_intel_pthread//& + flag_intel_nogen//& + flag_intel_byterecl + + case(id_intel_classic_mac) + flags = & + flag_intel_opt//& + flag_intel_fp//& + flag_intel_align//& + flag_intel_limit//& + flag_intel_pthread//& + flag_intel_nogen//& + flag_intel_byterecl + + case(id_intel_classic_windows) + flags = & + flag_intel_opt_win//& + flag_intel_fp_win//& + flag_intel_align_win//& + flag_intel_limit_win//& + flag_intel_pthread_win//& + flag_intel_nogen_win//& + flag_intel_byterecl_win + + case(id_intel_llvm_nix) + flags = & + flag_intel_opt//& + flag_intel_fp//& + flag_intel_align//& + flag_intel_limit//& + flag_intel_pthread//& + flag_intel_nogen//& + flag_intel_byterecl + + case(id_intel_llvm_windows) + flags = & + flag_intel_opt_win//& + flag_intel_fp_win//& + flag_intel_align_win//& + flag_intel_limit_win//& + flag_intel_pthread_win//& + flag_intel_nogen_win//& + flag_intel_byterecl_win + + case(id_nag) + flags = & + flag_nag_opt//& + flag_nag_coarray//& + flag_nag_pic + + case(id_lfortran) + flags = & + flag_lfortran_opt + + end select +end subroutine get_release_compile_flags + +subroutine get_debug_compile_flags(id, flags) + integer(compiler_enum), intent(in) :: id + character(len=:), allocatable, intent(out) :: flags + + select case(id) + case default + flags = "" + case(id_caf) + flags = & + flag_gnu_warn//& + flag_gnu_pic//& + flag_gnu_limit//& + flag_gnu_debug//& + flag_gnu_check//& + flag_gnu_backtrace + case(id_gcc) + flags = & + flag_gnu_warn//& + flag_gnu_pic//& + flag_gnu_limit//& + flag_gnu_debug//& + flag_gnu_check//& + flag_gnu_backtrace//& + flag_gnu_coarray + case(id_f95) + flags = & + flag_gnu_warn//& + flag_gnu_pic//& + flag_gnu_limit//& + flag_gnu_debug//& + flag_gnu_check//& + ' -Wno-maybe-uninitialized -Wno-uninitialized'//& + flag_gnu_backtrace + case(id_nvhpc) + flags = & + flag_pgi_warn//& + flag_pgi_backslash//& + flag_pgi_check//& + flag_pgi_traceback + case(id_ibmxl) + flags = & + flag_ibmxl_backslash + case(id_intel_classic_nix) + flags = & + flag_intel_warn//& + flag_intel_check//& + flag_intel_limit//& + flag_intel_debug//& + flag_intel_byterecl//& + flag_intel_backtrace + + case(id_intel_classic_mac) + flags = & + flag_intel_warn//& + flag_intel_check//& + flag_intel_limit//& + flag_intel_debug//& + flag_intel_byterecl//& + flag_intel_backtrace + case(id_intel_classic_windows) + flags = & + flag_intel_warn_win//& + flag_intel_check_win//& + flag_intel_limit_win//& + flag_intel_debug_win//& + flag_intel_byterecl_win//& + flag_intel_backtrace_win + case(id_intel_llvm_nix) + flags = & + flag_intel_warn//& + flag_intel_llvm_check//& + flag_intel_limit//& + flag_intel_debug//& + flag_intel_byterecl//& + flag_intel_backtrace + case(id_intel_llvm_windows) + flags = & + flag_intel_warn_win//& + flag_intel_check_win//& + flag_intel_limit_win//& + flag_intel_debug_win//& + flag_intel_byterecl_win + case(id_nag) + flags = & + flag_nag_debug//& + flag_nag_check//& + flag_nag_backtrace//& + flag_nag_coarray//& + flag_nag_pic + + case(id_lfortran) + flags = "" + end select +end subroutine get_debug_compile_flags + +pure subroutine set_cpp_preprocessor_flags(id, flags) + integer(compiler_enum), intent(in) :: id + character(len=:), allocatable, intent(inout) :: flags + character(len=:), allocatable :: flag_cpp_preprocessor + + !> Modify the flag_cpp_preprocessor on the basis of the compiler. + select case(id) + case default + flag_cpp_preprocessor = "" + case(id_caf, id_gcc, id_f95, id_nvhpc) + flag_cpp_preprocessor = "-cpp" + case(id_intel_classic_windows, id_intel_llvm_windows) + flag_cpp_preprocessor = "/fpp" + case(id_intel_classic_nix, id_intel_classic_mac, id_intel_llvm_nix, id_nag) + flag_cpp_preprocessor = "-fpp" + case(id_lfortran) + flag_cpp_preprocessor = "--cpp" + end select + + flags = flag_cpp_preprocessor// flags + +end subroutine set_cpp_preprocessor_flags + +!> This function will parse and read the macros list and +!> return them as defined flags. +function get_macros(id, macros_list, version) result(macros) + integer(compiler_enum), intent(in) :: id + character(len=:), allocatable, intent(in) :: version + type(string_t), allocatable, intent(in) :: macros_list(:) + + character(len=:), allocatable :: macros + character(len=:), allocatable :: macro_definition_symbol + character(:), allocatable :: valued_macros(:) + + integer :: i + + if (.not.allocated(macros_list)) then + macros = "" + return + end if + + !> Set macro defintion symbol on the basis of compiler used + select case(id) + case default + macro_definition_symbol = " -D" + case (id_intel_classic_windows, id_intel_llvm_windows) + macro_definition_symbol = " /D" + end select + + !> Check if macros are not allocated. + if (.not.allocated(macros)) then + macros="" + end if + + do i = 1, size(macros_list) + + !> Split the macro name and value. + call split(macros_list(i)%s, valued_macros, delimiters="=") + + if (size(valued_macros) > 1) then + !> Check if the value of macro starts with '{' character. + if (str_begins_with_str(trim(valued_macros(size(valued_macros))), "{")) then + + !> Check if the value of macro ends with '}' character. + if (str_ends_with(trim(valued_macros(size(valued_macros))), "}")) then + + !> Check if the string contains "version" as substring. + if (index(valued_macros(size(valued_macros)), "version") /= 0) then + + !> These conditions are placed in order to ensure proper spacing between the macros. + macros = macros//macro_definition_symbol//trim(valued_macros(1))//'='//version + cycle + end if + end if + end if + end if + + macros = macros//macro_definition_symbol//macros_list(i)%s + + end do + +end function get_macros + +function get_include_flag(self, path) result(flags) + class(compiler_t), intent(in) :: self + character(len=*), intent(in) :: path + character(len=:), allocatable :: flags + + select case(self%id) + case default + flags = "-I "//path + + case(id_caf, id_gcc, id_f95, id_cray, id_nvhpc, id_pgi, & + & id_flang, id_flang_new, id_f18, & + & id_intel_classic_nix, id_intel_classic_mac, & + & id_intel_llvm_nix, id_lahey, id_nag, id_ibmxl, & + & id_lfortran) + flags = "-I "//path + + case(id_intel_classic_windows, id_intel_llvm_windows) + flags = "/I"//path + + end select +end function get_include_flag + +function get_module_flag(self, path) result(flags) + class(compiler_t), intent(in) :: self + character(len=*), intent(in) :: path + character(len=:), allocatable :: flags + + select case(self%id) + case default + flags = "-module "//path + + case(id_caf, id_gcc, id_f95, id_cray, id_lfortran) + flags = "-J "//path + + case(id_nvhpc, id_pgi, id_flang) + flags = "-module "//path + + case(id_flang_new, id_f18) + flags = "-module-dir "//path + + case(id_intel_classic_nix, id_intel_classic_mac, & + & id_intel_llvm_nix) + flags = "-module "//path + + case(id_intel_classic_windows, id_intel_llvm_windows) + flags = "/module:"//path + + case(id_lahey) + flags = "-M "//path + + case(id_nag) + flags = "-mdir "//path + + case(id_ibmxl) + flags = "-qmoddir "//path + + end select + +end function get_module_flag + +function get_feature_flag(self, feature) result(flags) + class(compiler_t), intent(in) :: self + character(len=*), intent(in) :: feature + character(len=:), allocatable :: flags + + flags = "" + select case(feature) + case("no-implicit-typing") + select case(self%id) + case(id_caf, id_gcc, id_f95) + flags = flag_gnu_no_implicit_typing + + case(id_nag) + flags = flag_nag_no_implicit_typing + + case(id_cray) + flags = flag_cray_no_implicit_typing + + end select + + case("implicit-typing") + select case(self%id) + case(id_cray) + flags = flag_cray_implicit_typing + + case(id_lfortran) + flags = flag_lfortran_implicit_typing + + end select + + case("no-implicit-external") + select case(self%id) + case(id_caf, id_gcc, id_f95) + flags = flag_gnu_no_implicit_external + + end select + + case("implicit-external") + select case(self%id) + case(id_lfortran) + flags = flag_lfortran_implicit_external + + end select + + case("free-form") + select case(self%id) + case(id_caf, id_gcc, id_f95) + flags = flag_gnu_free_form + + case(id_pgi, id_nvhpc, id_flang) + flags = flag_pgi_free_form + + case(id_nag) + flags = flag_nag_free_form + + case(id_intel_classic_nix, id_intel_classic_mac, id_intel_llvm_nix, & + & id_intel_llvm_unknown) + flags = flag_intel_free_form + + case(id_intel_classic_windows, id_intel_llvm_windows) + flags = flag_intel_free_form_win + + case(id_cray) + flags = flag_cray_free_form + + end select + + case("fixed-form") + select case(self%id) + case(id_caf, id_gcc, id_f95) + flags = flag_gnu_fixed_form + + case(id_pgi, id_nvhpc, id_flang) + flags = flag_pgi_fixed_form + + case(id_nag) + flags = flag_nag_fixed_form + + case(id_intel_classic_nix, id_intel_classic_mac, id_intel_llvm_nix, & + & id_intel_llvm_unknown) + flags = flag_intel_fixed_form + + case(id_intel_classic_windows, id_intel_llvm_windows) + flags = flag_intel_fixed_form_win + + case(id_cray) + flags = flag_cray_fixed_form + + case(id_lfortran) + flags = flag_lfortran_fixed_form + + end select + + case("default-form") + continue + + case default + error stop "Unknown feature '"//feature//"'" + end select +end function get_feature_flag + +!> Get special flags for the main linker +subroutine get_main_flags(self, language, flags) + class(compiler_t), intent(in) :: self + character(len=*), intent(in) :: language + character(len=:), allocatable, intent(out) :: flags + + flags = "" + select case(language) + + case("fortran") + flags = "" + + case("c") + + ! If the main program is on a C/C++ source, the Intel Fortran compiler requires option + ! -nofor-main to avoid "duplicate main" errors. + ! https://stackoverflow.com/questions/36221612/p3dfft-compilation-ifort-compiler-error-multiple-definiton-of-main + select case(self%id) + case(id_intel_classic_nix, id_intel_classic_mac, id_intel_llvm_nix) + flags = '-nofor-main' + case(id_intel_classic_windows,id_intel_llvm_windows) + flags = '/nofor-main' + case (id_pgi,id_nvhpc) + flags = '-Mnomain' + end select + + case("c++","cpp","cxx") + + select case(self%id) + case(id_intel_classic_nix, id_intel_classic_mac, id_intel_llvm_nix) + flags = '-nofor-main' + case(id_intel_classic_windows,id_intel_llvm_windows) + flags = '/nofor-main' + case (id_pgi,id_nvhpc) + flags = '-Mnomain' + end select + + case default + error stop "Unknown language '"//language//'", try "fortran", "c", "c++"' + end select + +end subroutine get_main_flags + +subroutine get_default_c_compiler(f_compiler, c_compiler) + character(len=*), intent(in) :: f_compiler + character(len=:), allocatable, intent(out) :: c_compiler + integer(compiler_enum) :: id + + id = get_compiler_id(f_compiler) + + select case(id) + + case(id_intel_classic_nix, id_intel_classic_mac, id_intel_classic_windows) + c_compiler = 'icc' + + case(id_intel_llvm_nix,id_intel_llvm_windows) + c_compiler = 'icx' + + case(id_flang, id_flang_new, id_f18) + c_compiler='clang' + + case(id_ibmxl) + c_compiler='xlc' + + case(id_lfortran) + c_compiler = 'cc' + + case(id_gcc) + c_compiler = 'gcc' + + case default + ! Fall-back to using Fortran compiler + c_compiler = f_compiler + end select + +end subroutine get_default_c_compiler + +!> Get C++ Compiler. +subroutine get_default_cxx_compiler(f_compiler, cxx_compiler) + character(len=*), intent(in) :: f_compiler + character(len=:), allocatable, intent(out) :: cxx_compiler + integer(compiler_enum) :: id + + id = get_compiler_id(f_compiler) + + select case(id) + + case(id_intel_classic_nix, id_intel_classic_mac, id_intel_classic_windows) + cxx_compiler = 'icpc' + + case(id_intel_llvm_nix,id_intel_llvm_windows) + cxx_compiler = 'icpx' + + case(id_flang, id_flang_new, id_f18) + cxx_compiler='clang++' + + case(id_ibmxl) + cxx_compiler='xlc++' + + case(id_lfortran) + cxx_compiler = 'cc' + + case(id_gcc) + cxx_compiler = 'g++' + + case default + ! Fall-back to using Fortran compiler + cxx_compiler = f_compiler + end select + +end subroutine get_default_cxx_compiler + +function get_compiler_id(compiler) result(id) + character(len=*), intent(in) :: compiler + integer(kind=compiler_enum) :: id + + character(len=:), allocatable :: full_command, full_command_parts(:), command, output + integer :: stat, io + + ! Check whether we are dealing with an MPI compiler wrapper first + if (check_compiler(compiler, "mpifort") & + & .or. check_compiler(compiler, "mpif90") & + & .or. check_compiler(compiler, "mpif77")) then + output = get_temp_filename() + call run(compiler//" -show > "//output//" 2>&1", & + & echo=.false., exitstat=stat) + if (stat == 0) then + open(file=output, newunit=io, iostat=stat) + if (stat == 0) call getline(io, full_command, stat) + close(io, iostat=stat) + + ! If we get a command from the wrapper, we will try to identify it + call split(full_command, full_command_parts, delimiters=' ') + if(size(full_command_parts) > 0)then + command = trim(full_command_parts(1)) + endif + if (allocated(command)) then + id = get_id(command) + if (id /= id_unknown) return + end if + end if + end if + + id = get_id(compiler) + +end function get_compiler_id + +function get_id(compiler) result(id) + character(len=*), intent(in) :: compiler + integer(kind=compiler_enum) :: id + + if (check_compiler(compiler, "gfortran")) then + id = id_gcc + return + end if + + if (check_compiler(compiler, "f95")) then + id = id_f95 + return + end if + + if (check_compiler(compiler, "caf")) then + id = id_caf + return + end if + + if (check_compiler(compiler, "ifort")) then + select case (get_os_type()) + case default + id = id_intel_classic_nix + case (OS_MACOS) + id = id_intel_classic_mac + case (OS_WINDOWS, OS_CYGWIN) + id = id_intel_classic_windows + end select + return + end if + + if (check_compiler(compiler, "ifx")) then + select case (get_os_type()) + case default + id = id_intel_llvm_nix + case (OS_WINDOWS, OS_CYGWIN) + id = id_intel_llvm_windows + end select + return + end if + + if (check_compiler(compiler, "nvfortran")) then + id = id_nvhpc + return + end if + + if (check_compiler(compiler, "pgfortran") & + & .or. check_compiler(compiler, "pgf90") & + & .or. check_compiler(compiler, "pgf95")) then + id = id_pgi + return + end if + + if (check_compiler(compiler, "nagfor")) then + id = id_nag + return + end if + + if (check_compiler(compiler, "flang-new")) then + id = id_flang_new + return + end if + + if (check_compiler(compiler, "f18")) then + id = id_f18 + return + end if + + if (check_compiler(compiler, "flang")) then + id = id_flang + return + end if + + if (check_compiler(compiler, "xlf90")) then + id = id_ibmxl + return + end if + + if (check_compiler(compiler, "crayftn")) then + id = id_cray + return + end if + + if (check_compiler(compiler, "lfc")) then + id = id_lahey + return + end if + + if (check_compiler(compiler, "lfortran")) then + id = id_lfortran + return + end if + + id = id_unknown + +end function get_id + +function check_compiler(compiler, expected) result(match) + character(len=*), intent(in) :: compiler + character(len=*), intent(in) :: expected + logical :: match + match = compiler == expected + if (.not. match) then + match = index(basename(compiler), expected) > 0 + end if +end function check_compiler + +pure function is_unknown(self) + class(compiler_t), intent(in) :: self + logical :: is_unknown + is_unknown = self%id == id_unknown +end function is_unknown + +pure logical function is_intel(self) + class(compiler_t), intent(in) :: self + is_intel = any(self%id == [id_intel_classic_nix,id_intel_classic_mac,id_intel_classic_windows, & + id_intel_llvm_nix,id_intel_llvm_windows,id_intel_llvm_unknown]) +end function is_intel + +pure logical function is_gnu(self) + class(compiler_t), intent(in) :: self + is_gnu = any(self%id == [id_f95,id_gcc,id_caf]) +end function is_gnu + +!> +!> Enumerate libraries, based on compiler and platform +!> +function enumerate_libraries(self, prefix, libs) result(r) + class(compiler_t), intent(in) :: self + character(len=*), intent(in) :: prefix + type(string_t), intent(in) :: libs(:) + character(len=:), allocatable :: r + + if (self%id == id_intel_classic_windows .or. & + self%id == id_intel_llvm_windows) then + r = prefix // " " // string_cat(libs,".lib ")//".lib" + else + r = prefix // " -l" // string_cat(libs," -l") + end if +end function enumerate_libraries + +!> Create new compiler instance +subroutine new_compiler(self, fc, cc, cxx, echo, verbose) + !> New instance of the compiler + type(compiler_t), intent(out) :: self + !> Fortran compiler name or path + character(len=*), intent(in) :: fc + !> C compiler name or path + character(len=*), intent(in) :: cc + !> C++ Compiler name or path + character(len=*), intent(in) :: cxx + !> Echo compiler command + logical, intent(in) :: echo + !> Verbose mode: dump compiler output + logical, intent(in) :: verbose + + self%id = get_compiler_id(fc) + + self%echo = echo + self%verbose = verbose + self%fc = fc + if (len_trim(cc) > 0) then + self%cc = cc + else + call get_default_c_compiler(self%fc, self%cc) + end if + + if (len_trim(cxx) > 0) then + self%cxx = cxx + else + call get_default_cxx_compiler(self%fc, self%cxx) + end if + +end subroutine new_compiler + +!> Create new archiver instance +subroutine new_archiver(self, ar, echo, verbose) + !> New instance of the archiver + type(archiver_t), intent(out) :: self + !> User provided archiver command + character(len=*), intent(in) :: ar + !> Echo compiler command + logical, intent(in) :: echo + !> Verbose mode: dump compiler output + logical, intent(in) :: verbose + + integer :: estat, os_type + + character(len=*), parameter :: arflags = " -rs ", libflags = " /OUT:" + + if (len_trim(ar) > 0) then + ! Check first for ar-like commands + if (check_compiler(ar, "ar")) then + self%ar = ar//arflags + end if + + ! Check for lib-like commands + if (check_compiler(ar, "lib")) then + self%ar = ar//libflags + end if + + ! Fallback and assume ar-like behaviour + self%ar = ar//arflags + else + os_type = get_os_type() + if (os_type /= OS_WINDOWS .and. os_type /= OS_UNKNOWN) then + self%ar = "ar"//arflags + else + ! Attempt "ar" + call execute_command_line("ar --version > "//get_temp_filename()//" 2>&1", & + & exitstat=estat) + + if (estat == 0) then + + self%ar = "ar"//arflags + + else + + ! Then "gcc-ar" + call execute_command_line("gcc-ar --version > "//get_temp_filename()//" 2>&1", & + & exitstat=estat) + + if (estat /= 0) then + self%ar = "lib"//libflags + else + self%ar = "gcc-ar"//arflags + end if + endif + end if + end if + self%use_response_file = os_type == OS_WINDOWS + self%echo = echo + self%verbose = verbose +end subroutine new_archiver + +!> Compile a Fortran object +subroutine compile_fortran(self, input, output, args, log_file, stat) + !> Instance of the compiler object + class(compiler_t), intent(in) :: self + !> Source file input + character(len=*), intent(in) :: input + !> Output file of object + character(len=*), intent(in) :: output + !> Arguments for compiler + character(len=*), intent(in) :: args + !> Compiler output log file + character(len=*), intent(in) :: log_file + !> Status flag + integer, intent(out) :: stat + + call run(self%fc // " -c " // input // " " // args // " -o " // output, & + & echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) +end subroutine compile_fortran + +!> Compile a C object +subroutine compile_c(self, input, output, args, log_file, stat) + !> Instance of the compiler object + class(compiler_t), intent(in) :: self + !> Source file input + character(len=*), intent(in) :: input + !> Output file of object + character(len=*), intent(in) :: output + !> Arguments for compiler + character(len=*), intent(in) :: args + !> Compiler output log file + character(len=*), intent(in) :: log_file + !> Status flag + integer, intent(out) :: stat + + call run(self%cc // " -c " // input // " " // args // " -o " // output, & + & echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) +end subroutine compile_c + +!> Compile a CPP object +subroutine compile_cpp(self, input, output, args, log_file, stat) + !> Instance of the compiler object + class(compiler_t), intent(in) :: self + !> Source file input + character(len=*), intent(in) :: input + !> Output file of object + character(len=*), intent(in) :: output + !> Arguments for compiler + character(len=*), intent(in) :: args + !> Compiler output log file + character(len=*), intent(in) :: log_file + !> Status flag + integer, intent(out) :: stat + + call run(self%cxx // " -c " // input // " " // args // " -o " // output, & + & echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) +end subroutine compile_cpp + +!> Link an executable +subroutine link(self, output, args, log_file, stat) + !> Instance of the compiler object + class(compiler_t), intent(in) :: self + !> Output file of object + character(len=*), intent(in) :: output + !> Arguments for compiler + character(len=*), intent(in) :: args + !> Compiler output log file + character(len=*), intent(in) :: log_file + !> Status flag + integer, intent(out) :: stat + + call run(self%fc // " " // args // " -o " // output, echo=self%echo, & + & verbose=self%verbose, redirect=log_file, exitstat=stat) +end subroutine link + +!> Create an archive +!> @todo For Windows OS, use the local `delete_file_win32` in stead of `delete_file`. +!> This may be related to a bug in Mingw64-openmp and is expected to be resolved in the future, +!> see issue #707, #708 and #808. +subroutine make_archive(self, output, args, log_file, stat) + !> Instance of the archiver object + class(archiver_t), intent(in) :: self + !> Name of the archive to generate + character(len=*), intent(in) :: output + !> Object files to include into the archive + type(string_t), intent(in) :: args(:) + !> Compiler output log file + character(len=*), intent(in) :: log_file + !> Status flag + integer, intent(out) :: stat + + if (self%use_response_file) then + call write_response_file(output//".resp" , args) + call run(self%ar // output // " @" // output//".resp", echo=self%echo, & + & verbose=self%verbose, redirect=log_file, exitstat=stat) + call delete_file_win32(output//".resp") + + else + call run(self%ar // output // " " // string_cat(args, " "), & + & echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + end if + + contains + subroutine delete_file_win32(file) + character(len=*), intent(in) :: file + logical :: exist + integer :: unit, iostat + inquire(file=file, exist=exist) + if (exist) then + open(file=file, newunit=unit) + close(unit, status='delete', iostat=iostat) + end if + end subroutine delete_file_win32 +end subroutine make_archive + +!> Response files allow to read command line options from files. +!> Whitespace is used to separate the arguments, we will use newlines +!> as separator to create readable response files which can be inspected +!> in case of errors. +subroutine write_response_file(name, argv) + character(len=*), intent(in) :: name + type(string_t), intent(in) :: argv(:) + + integer :: iarg, io + + open(file=name, newunit=io, status='replace') + do iarg = 1, size(argv) + write(io, '(a)') unix_path(argv(iarg)%s) + end do + close(io) +end subroutine write_response_file + +!> String representation of a compiler object +pure function debug_compiler(self) result(repr) + !> Instance of the compiler object + type(compiler_t), intent(in) :: self + !> Representation as string + character(len=:), allocatable :: repr + + repr = 'fc="'//self%fc//'", cc="'//self%cc//'"' +end function debug_compiler + +!> String representation of an archiver object +pure function debug_archiver(self) result(repr) + !> Instance of the archiver object + type(archiver_t), intent(in) :: self + !> Representation as string + character(len=:), allocatable :: repr + + repr = 'ar="'//self%ar//'"' +end function debug_archiver + +!> Check that two archiver_t objects are equal +logical function ar_is_same(this,that) + class(archiver_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + ar_is_same = .false. + + select type (other=>that) + type is (archiver_t) + + if (.not.(this%ar==other%ar)) return + if (.not.(this%use_response_file.eqv.other%use_response_file)) return + if (.not.(this%echo.eqv.other%echo)) return + if (.not.(this%verbose.eqv.other%verbose)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + ar_is_same = .true. + +end function ar_is_same + +!> Dump dependency to toml table +subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(archiver_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Path to archiver + call set_string(table, "ar", self%ar, error, 'archiver_t') + if (allocated(error)) return + call set_value(table, "use-response-file", self%use_response_file, error, 'archiver_t') + if (allocated(error)) return + call set_value(table, "echo", self%echo, error, 'archiver_t') + if (allocated(error)) return + call set_value(table, "verbose", self%verbose, error, 'archiver_t') + if (allocated(error)) return + +end subroutine dump_to_toml + +!> Read dependency from toml table (no checks made at this stage) +subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(archiver_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call get_value(table, "ar", self%ar) + + call get_value(table, "use-response-file", self%use_response_file, error, 'archiver_t') + if (allocated(error)) return + call get_value(table, "echo", self%echo, error, 'archiver_t') + if (allocated(error)) return + call get_value(table, "verbose", self%verbose, error, 'archiver_t') + if (allocated(error)) return + +end subroutine load_from_toml + +!> Check that two compiler_t objects are equal +logical function compiler_is_same(this,that) + class(compiler_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + compiler_is_same = .false. + + select type (other=>that) + type is (compiler_t) + + if (.not.(this%id==other%id)) return + if (.not.(this%fc==other%fc)) return + if (.not.(this%cc==other%cc)) return + if (.not.(this%cxx==other%cxx)) return + if (.not.(this%echo.eqv.other%echo)) return + if (.not.(this%verbose.eqv.other%verbose)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + compiler_is_same = .true. + +end function compiler_is_same + +!> Dump dependency to toml table +subroutine compiler_dump(self, table, error) + + !> Instance of the serializable object + class(compiler_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr + + call set_value(table, "id", self%id, error, 'compiler_t') + if (allocated(error)) return + call set_string(table, "fc", self%fc, error, 'compiler_t') + if (allocated(error)) return + call set_string(table, "cc", self%cc, error, 'compiler_t') + if (allocated(error)) return + call set_string(table, "cxx", self%cxx, error, 'compiler_t') + if (allocated(error)) return + call set_value(table, "echo", self%echo, error, 'compiler_t') + if (allocated(error)) return + call set_value(table, "verbose", self%verbose, error, 'compiler_t') + if (allocated(error)) return + +end subroutine compiler_dump + +!> Read dependency from toml table (no checks made at this stage) +subroutine compiler_load(self, table, error) + + !> Instance of the serializable object + class(compiler_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call get_value(table, "id", self%id, error, 'compiler_t') + if (allocated(error)) return + call get_value(table, "fc", self%fc) + call get_value(table, "cc", self%cc) + call get_value(table, "cxx", self%cxx) + call get_value(table, "echo", self%echo, error, 'compiler_t') + if (allocated(error)) return + call get_value(table, "verbose", self%verbose, error, 'compiler_t') + if (allocated(error)) return + +end subroutine compiler_load + +!> Return a compiler name string +pure function compiler_name(self) result(name) + !> Instance of the compiler object + class(compiler_t), intent(in) :: self + !> Representation as string + character(len=:), allocatable :: name + + select case (self%id) + case(id_gcc); name = "gfortran" + case(id_f95); name = "f95" + case(id_caf); name = "caf" + case(id_intel_classic_nix); name = "ifort" + case(id_intel_classic_mac); name = "ifort" + case(id_intel_classic_windows); name = "ifort" + case(id_intel_llvm_nix); name = "ifx" + case(id_intel_llvm_windows); name = "ifx" + case(id_intel_llvm_unknown); name = "ifx" + case(id_pgi); name = "pgfortran" + case(id_nvhpc); name = "nvfortran" + case(id_nag); name = "nagfor" + case(id_flang); name = "flang" + case(id_flang_new); name = "flang-new" + case(id_f18); name = "f18" + case(id_ibmxl); name = "xlf90" + case(id_cray); name = "crayftn" + case(id_lahey); name = "lfc" + case(id_lfortran); name = "lFortran" + case default; name = "invalid/unknown" + end select +end function compiler_name + +!> Run a single-source Fortran program using the current compiler +!> Compile a Fortran object +logical function check_fortran_source_runs(self, input) result(success) + !> Instance of the compiler object + class(compiler_t), intent(in) :: self + !> Program Source + character(len=*), intent(in) :: input + + integer :: stat,unit + character(:), allocatable :: source,object,logf,exe + + success = .false. + + !> Create temporary source file + exe = get_temp_filename() + source = exe//'.f90' + object = exe//'.o' + logf = exe//'.log' + open(newunit=unit, file=source, action='readwrite', iostat=stat) + if (stat/=0) return + + !> Write contents + write(unit,*) input + close(unit) + + !> Compile and link program + call self%compile_fortran(source, object, self%get_default_flags(release=.false.), logf, stat) + if (stat==0) & + call self%link(exe, self%get_default_flags(release=.false.)//" "//object, logf, stat) + + !> Run and retrieve exit code + if (stat==0) & + call run(exe,echo=.false., exitstat=stat, verbose=.false., redirect=logf) + + !> Successful exit on 0 exit code + success = stat==0 + + !> Delete files + open(newunit=unit, file=source, action='readwrite', iostat=stat) + close(unit,status='delete') + open(newunit=unit, file=object, action='readwrite', iostat=stat) + close(unit,status='delete') + open(newunit=unit, file=logf, action='readwrite', iostat=stat) + close(unit,status='delete') + open(newunit=unit, file=exe, action='readwrite', iostat=stat) + close(unit,status='delete') + +end function check_fortran_source_runs + +!> Check if the current compiler supports 128-bit real precision +logical function with_qp(self) + !> Instance of the compiler object + class(compiler_t), intent(in) :: self + with_qp = self%check_fortran_source_runs & + ('if (selected_real_kind(33) == -1) stop 1; end') +end function with_qp + +!> Check if the current compiler supports 80-bit "extended" real precision +logical function with_xdp(self) + !> Instance of the compiler object + class(compiler_t), intent(in) :: self + with_xdp = self%check_fortran_source_runs & + ('if (any(selected_real_kind(18) == [-1, selected_real_kind(33)])) stop 1; end') +end function with_xdp + +end module fpm_compiler + +!>>>>> ././src/fpm/dependency.f90 + +!> # Dependency management +!> +!> ## Fetching dependencies and creating a dependency tree +!> +!> Dependencies on the top-level can be specified from: +!> +!> - `package%dependencies` +!> - `package%dev_dependencies` +!> - `package%executable(:)%dependencies` +!> - `package%test(:)%dependencies` +!> +!> Each dependency is fetched in some way and provides a path to its package +!> manifest. +!> The `package%dependencies` of the dependencies are resolved recursively. +!> +!> To initialize the dependency tree all dependencies are recursively fetched +!> and stored in a flat data structure to avoid retrieving a package twice. +!> The data structure used to store this information should describe the current +!> status of the dependency tree. Important information are: +!> +!> - name of the package +!> - version of the package +!> - path to the package root +!> +!> Additionally, for version controlled dependencies the following should be +!> stored along with the package: +!> +!> - the upstream url +!> - the current checked out revision +!> +!> Fetching a remote (version controlled) dependency turns it for our purpose +!> into a local path dependency which is handled by the same means. +!> +!> ## Updating dependencies +!> +!> For a given dependency tree all top-level dependencies can be updated. +!> We have two cases to consider, a remote dependency and a local dependency, +!> again, remote dependencies turn into local dependencies by fetching. +!> Therefore we will update remote dependencies by simply refetching them. +!> +!> For remote dependencies we have to refetch if the revision in the manifest +!> changes or the upstream HEAD has changed (for branches _and_ tags). +!> +!> @Note For our purpose a tag is just a fancy branch name. Tags can be delete and +!> modified afterwards, therefore they do not differ too much from branches +!> from our perspective. +!> +!> For the latter case we only know if we actually fetch from the upstream URL. +!> +!> In case of local (and fetched remote) dependencies we have to read the package +!> manifest and compare its dependencies against our dependency tree, any change +!> requires updating the respective dependencies as well. +!> +!> ## Handling dependency compatibilties +!> +!> Currenly ignored. First come, first serve. +module fpm_dependency + use, intrinsic :: iso_fortran_env, only: output_unit + use fpm_environment, only: get_os_type, OS_WINDOWS, os_is_unix + use fpm_error, only: error_t, fatal_error + use fpm_filesystem, only: exists, join_path, mkdir, canon_path, windows_path, list_files, is_dir, basename, & + os_delete_dir, get_temp_filename + use fpm_git, only: git_target_revision, git_target_default, git_revision, serializable_t + use fpm_manifest, only: package_config_t, dependency_config_t, get_package_data + use fpm_manifest_dependency, only: manifest_has_changed, dependency_destroy + use fpm_manifest_preprocess, only: operator(==) + use fpm_strings, only: string_t, operator(.in.) + use fpm_toml, only: toml_table, toml_key, toml_error, toml_serialize, & + get_value, set_value, add_table, toml_load, toml_stat, set_string + use fpm_versioning, only: version_t, new_version + use fpm_settings, only: fpm_global_settings, get_global_settings, official_registry_base_url + use fpm_downloader, only: downloader_t + use jonquil, only: json_object + use fpm_strings, only: str + implicit none + private + + public :: dependency_tree_t, new_dependency_tree, dependency_node_t, new_dependency_node, resize, & + & check_and_read_pkg_data, destroy_dependency_node + + !> Overloaded reallocation interface + interface resize + module procedure :: resize_dependency_node + end interface resize + + !> Dependency node in the projects dependency tree + type, extends(dependency_config_t) :: dependency_node_t + !> Actual version of this dependency + type(version_t), allocatable :: version + !> Installation prefix of this dependencies + character(len=:), allocatable :: proj_dir + !> Checked out revision of the version control system + character(len=:), allocatable :: revision + !> Dependency is handled + logical :: done = .false. + !> Dependency should be updated + logical :: update = .false. + !> Dependency was loaded from a cache + logical :: cached = .false. + contains + !> Update dependency from project manifest. + procedure :: register + !> Get dependency from the registry. + procedure :: get_from_registry + procedure, private :: get_from_local_registry + !> Print information on this instance + procedure :: info + + !> Serialization interface + procedure :: serializable_is_same => dependency_node_is_same + procedure :: dump_to_toml => node_dump_to_toml + procedure :: load_from_toml => node_load_from_toml + + end type dependency_node_t + + !> Respresentation of a projects dependencies + !> + !> The dependencies are stored in a simple array for now, this can be replaced + !> with a binary-search tree or a hash table in the future. + type, extends(serializable_t) :: dependency_tree_t + !> Unit for IO + integer :: unit = output_unit + !> Verbosity of printout + integer :: verbosity = 1 + !> Installation prefix for dependencies + character(len=:), allocatable :: dep_dir + !> Number of currently registered dependencies + integer :: ndep = 0 + !> Flattend list of all dependencies + type(dependency_node_t), allocatable :: dep(:) + !> Cache file + character(len=:), allocatable :: cache + + contains + + !> Overload procedure to add new dependencies to the tree + generic :: add => add_project, add_project_dependencies, add_dependencies, & + add_dependency, add_dependency_node + !> Main entry point to add a project + procedure, private :: add_project + !> Add a project and its dependencies to the dependency tree + procedure, private :: add_project_dependencies + !> Add a list of dependencies to the dependency tree + procedure, private :: add_dependencies + !> Add a single dependency to the dependency tree + procedure, private :: add_dependency + !> Add a single dependency node to the dependency tree + procedure, private :: add_dependency_node + !> Resolve dependencies + generic :: resolve => resolve_dependencies, resolve_dependency + !> Resolve dependencies + procedure, private :: resolve_dependencies + !> Resolve dependency + procedure, private :: resolve_dependency + !> True if entity can be found + generic :: has => has_dependency + !> True if dependency is part of the tree + procedure, private :: has_dependency + !> Find a dependency in the tree + generic :: find => find_name + !> Find a dependency by its name + procedure, private :: find_name + !> Depedendncy resolution finished + procedure :: finished + !> Reading of dependency tree + generic :: load_cache => load_cache_from_file, load_cache_from_unit, load_cache_from_toml + !> Read dependency tree from file + procedure, private :: load_cache_from_file + !> Read dependency tree from formatted unit + procedure, private :: load_cache_from_unit + !> Read dependency tree from TOML data structure + procedure, private :: load_cache_from_toml + !> Writing of dependency tree + generic :: dump_cache => dump_cache_to_file, dump_cache_to_unit, dump_cache_to_toml + !> Write dependency tree to file + procedure, private :: dump_cache_to_file + !> Write dependency tree to formatted unit + procedure, private :: dump_cache_to_unit + !> Write dependency tree to TOML data structure + procedure, private :: dump_cache_to_toml + !> Update dependency tree + generic :: update => update_dependency, update_tree + !> Update a list of dependencies + procedure, private :: update_dependency + !> Update all dependencies in the tree + procedure, private :: update_tree + + !> Serialization interface + procedure :: serializable_is_same => dependency_tree_is_same + procedure :: dump_to_toml => tree_dump_to_toml + procedure :: load_from_toml => tree_load_from_toml + + end type dependency_tree_t + + !> Common output format for writing to the command line + character(len=*), parameter :: out_fmt = '("#", *(1x, g0))' + +contains + + !> Create a new dependency tree + subroutine new_dependency_tree(self, verbosity, cache) + !> Instance of the dependency tree + type(dependency_tree_t), intent(out) :: self + !> Verbosity of printout + integer, intent(in), optional :: verbosity + !> Name of the cache file + character(len=*), intent(in), optional :: cache + + call resize(self%dep) + self%dep_dir = join_path("build", "dependencies") + + if (present(verbosity)) self%verbosity = verbosity + + if (present(cache)) self%cache = cache + + end subroutine new_dependency_tree + + !> Create a new dependency node from a configuration + subroutine new_dependency_node(self, dependency, version, proj_dir, update) + !> Instance of the dependency node + type(dependency_node_t), intent(out) :: self + !> Dependency configuration data + type(dependency_config_t), intent(in) :: dependency + !> Version of the dependency + type(version_t), intent(in), optional :: version + !> Installation prefix of the dependency + character(len=*), intent(in), optional :: proj_dir + !> Dependency should be updated + logical, intent(in), optional :: update + + self%dependency_config_t = dependency + + if (present(version)) then + self%version = version + end if + + if (present(proj_dir)) then + self%proj_dir = proj_dir + end if + + if (present(update)) then + self%update = update + end if + + end subroutine new_dependency_node + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the dependency configuration + class(dependency_node_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + !> Call base object info + call self%dependency_config_t%info(unit, pr) + + if (allocated(self%version)) then + write (unit, fmt) "- version", self%version%s() + end if + + if (allocated(self%proj_dir)) then + write (unit, fmt) "- dir", self%proj_dir + end if + + if (allocated(self%revision)) then + write (unit, fmt) "- revision", self%revision + end if + + write (unit, fmt) "- done", merge('YES', 'NO ', self%done) + write (unit, fmt) "- update", merge('YES', 'NO ', self%update) + + end subroutine info + + !> Add project dependencies, each depth level after each other. + !> + !> We implement this algorithm in an interative rather than a recursive fashion + !> as a choice of design. + subroutine add_project(self, package, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Project configuration to add + type(package_config_t), intent(in) :: package + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(dependency_config_t) :: dependency + type(dependency_tree_t) :: cached + character(len=*), parameter :: root = '.' + integer :: id + + if (.not. exists(self%dep_dir)) then + call mkdir(self%dep_dir) + end if + + ! Create this project as the first dependency node (depth 0) + dependency%name = package%name + dependency%path = root + call self%add(dependency, error) + if (allocated(error)) return + + ! Resolve the root project + call self%resolve(root, error) + if (allocated(error)) return + + ! Add the root project dependencies (depth 1) + call self%add(package, root, .true., error) + if (allocated(error)) return + + ! After resolving all dependencies, check if we have cached ones to avoid updates + if (allocated(self%cache)) then + call new_dependency_tree(cached, verbosity=self%verbosity,cache=self%cache) + call cached%load_cache(self%cache, error) + if (allocated(error)) return + + ! Skip root node + do id = 2, cached%ndep + cached%dep(id)%cached = .true. + call self%add(cached%dep(id), error) + if (allocated(error)) return + end do + end if + + ! Now decent into the dependency tree, level for level + do while (.not. self%finished()) + call self%resolve(root, error) + if (allocated(error)) exit + end do + if (allocated(error)) return + + if (allocated(self%cache)) then + call self%dump_cache(self%cache, error) + if (allocated(error)) return + end if + + end subroutine add_project + + !> Add a project and its dependencies to the dependency tree + recursive subroutine add_project_dependencies(self, package, root, main, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Project configuration to add + type(package_config_t), intent(in) :: package + !> Current project root directory + character(len=*), intent(in) :: root + !> Is the main project + logical, intent(in) :: main + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ii + + if (allocated(package%dependency)) then + call self%add(package%dependency, error) + if (allocated(error)) return + end if + + if (main) then + if (allocated(package%dev_dependency)) then + call self%add(package%dev_dependency, error) + if (allocated(error)) return + end if + + if (allocated(package%executable)) then + do ii = 1, size(package%executable) + if (allocated(package%executable(ii)%dependency)) then + call self%add(package%executable(ii)%dependency, error) + if (allocated(error)) exit + end if + end do + if (allocated(error)) return + end if + + if (allocated(package%example)) then + do ii = 1, size(package%example) + if (allocated(package%example(ii)%dependency)) then + call self%add(package%example(ii)%dependency, error) + if (allocated(error)) exit + end if + end do + if (allocated(error)) return + end if + + if (allocated(package%test)) then + do ii = 1, size(package%test) + if (allocated(package%test(ii)%dependency)) then + call self%add(package%test(ii)%dependency, error) + if (allocated(error)) exit + end if + end do + if (allocated(error)) return + end if + end if + + !> Ensure allocation fits + call resize(self%dep,self%ndep) + + end subroutine add_project_dependencies + + !> Add a list of dependencies to the dependency tree + subroutine add_dependencies(self, dependency, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Dependency configuration to add + type(dependency_config_t), intent(in) :: dependency(:) + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ii, ndep + + ndep = size(self%dep) + if (ndep < size(dependency) + self%ndep) then + call resize(self%dep, ndep + ndep/2 + size(dependency)) + end if + + do ii = 1, size(dependency) + call self%add(dependency(ii), error) + if (allocated(error)) exit + end do + if (allocated(error)) return + + !> Ensure allocation fits ndep + call resize(self%dep,self%ndep) + + end subroutine add_dependencies + + !> Add a single dependency node to the dependency tree + !> Dependency nodes contain additional information (version, git, revision) + subroutine add_dependency_node(self, dependency, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Dependency configuration to add + type(dependency_node_t), intent(in) :: dependency + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: id + + if (self%has_dependency(dependency)) then + ! A dependency with this same name is already in the dependency tree. + ! Check if it needs to be updated + id = self%find(dependency%name) + + ! If this dependency was in the cache, and we're now requesting a different version + ! in the manifest, ensure it is marked for update. Otherwise, if we're just querying + ! the same dependency from a lower branch of the dependency tree, the existing one from + ! the manifest has priority + if (dependency%cached) then + if (dependency_has_changed(dependency, self%dep(id), self%verbosity, self%unit)) then + if (self%verbosity > 0) write (self%unit, out_fmt) "Dependency change detected:", dependency%name + self%dep(id)%update = .true. + else + ! Store the cached one + self%dep(id) = dependency + self%dep(id)%update = .false. + end if + end if + else + + !> Safety: reallocate if necessary + if (size(self%dep)==self%ndep) call resize(self%dep,self%ndep+1) + + ! New dependency: add from scratch + self%ndep = self%ndep + 1 + self%dep(self%ndep) = dependency + self%dep(self%ndep)%update = .false. + end if + + end subroutine add_dependency_node + + !> Add a single dependency to the dependency tree + subroutine add_dependency(self, dependency, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Dependency configuration to add + type(dependency_config_t), intent(in) :: dependency + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + + call new_dependency_node(node, dependency) + call add_dependency_node(self, node, error) + + end subroutine add_dependency + + !> Update dependency tree + subroutine update_dependency(self, name, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Name of the dependency to update + character(len=*), intent(in) :: name + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: id + character(len=:), allocatable :: proj_dir, root + + id = self%find(name) + root = "." + + if (id <= 0) then + call fatal_error(error, "Cannot update dependency '"//name//"'") + return + end if + + associate (dep => self%dep(id)) + if (allocated(dep%git) .and. dep%update) then + if (self%verbosity > 0) write (self%unit, out_fmt) "Update:", dep%name + proj_dir = join_path(self%dep_dir, dep%name) + call dep%git%checkout(proj_dir, error) + if (allocated(error)) return + + ! Unset dependency and remove updatable attribute + dep%done = .false. + dep%update = .false. + + ! Now decent into the dependency tree, level for level + do while (.not. self%finished()) + call self%resolve(root, error) + if (allocated(error)) exit + end do + if (allocated(error)) return + end if + end associate + + end subroutine update_dependency + + !> Update whole dependency tree + subroutine update_tree(self, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: i + + ! Update dependencies where needed + do i = 1, self%ndep + call self%update(self%dep(i)%name, error) + if (allocated(error)) return + end do + + end subroutine update_tree + + !> Resolve all dependencies in the tree + subroutine resolve_dependencies(self, root, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Current installation prefix + character(len=*), intent(in) :: root + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(fpm_global_settings) :: global_settings + integer :: ii + + call get_global_settings(global_settings, error) + if (allocated(error)) return + + do ii = 1, self%ndep + call self%resolve(self%dep(ii), global_settings, root, error) + if (allocated(error)) exit + end do + + if (allocated(error)) return + + end subroutine resolve_dependencies + + !> Resolve a single dependency node + subroutine resolve_dependency(self, dependency, global_settings, root, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Dependency configuration to add + type(dependency_node_t), intent(inout) :: dependency + !> Global configuration settings. + type(fpm_global_settings), intent(in) :: global_settings + !> Current installation prefix + character(len=*), intent(in) :: root + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_config_t) :: package + character(len=:), allocatable :: manifest, proj_dir, revision + logical :: fetch + + if (dependency%done) return + + fetch = .false. + if (allocated(dependency%proj_dir)) then + proj_dir = dependency%proj_dir + else if (allocated(dependency%path)) then + proj_dir = join_path(root, dependency%path) + else if (allocated(dependency%git)) then + proj_dir = join_path(self%dep_dir, dependency%name) + fetch = .not. exists(proj_dir) + if (fetch) then + call dependency%git%checkout(proj_dir, error) + if (allocated(error)) return + end if + else + call dependency%get_from_registry(proj_dir, global_settings, error) + if (allocated(error)) return + end if + + if (allocated(dependency%git)) then + call git_revision(proj_dir, revision, error) + if (allocated(error)) return + end if + + manifest = join_path(proj_dir, "fpm.toml") + call get_package_data(package, manifest, error) + if (allocated(error)) return + + call dependency%register(package, proj_dir, fetch, revision, error) + if (allocated(error)) return + + if (self%verbosity > 1) then + write (self%unit, out_fmt) & + "Dep:", dependency%name, "version", dependency%version%s(), & + "at", dependency%proj_dir + end if + + call self%add(package, proj_dir, .false., error) + if (allocated(error)) return + + end subroutine resolve_dependency + + !> Get a dependency from the registry. Whether the dependency is fetched + !> from a local, a custom remote or the official registry is determined + !> by the global configuration settings. + subroutine get_from_registry(self, target_dir, global_settings, error, downloader_) + + !> Instance of the dependency configuration. + class(dependency_node_t), intent(in) :: self + + !> The target directory of the dependency. + character(:), allocatable, intent(out) :: target_dir + + !> Global configuration settings. + type(fpm_global_settings), intent(in) :: global_settings + + !> Error handling. + type(error_t), allocatable, intent(out) :: error + + !> Downloader instance. + class(downloader_t), optional, intent(in) :: downloader_ + + character(:), allocatable :: cache_path, target_url, tmp_file + type(version_t) :: version + integer :: stat, unit + type(json_object) :: json + class(downloader_t), allocatable :: downloader + + if (present(downloader_)) then + downloader = downloader_ + else + allocate (downloader) + end if + + ! Use local registry if it was specified in the global config file. + if (allocated(global_settings%registry_settings%path)) then + call self%get_from_local_registry(target_dir, global_settings%registry_settings%path, error); return + end if + + ! Include namespace and package name in the cache path. + cache_path = join_path(global_settings%registry_settings%cache_path, self%namespace, self%name) + + ! Check cache before downloading from the remote registry if a specific version was requested. When no specific + ! version was requested, do network request first to check which is the newest version. + if (allocated(self%requested_version)) then + if (exists(join_path(cache_path, self%requested_version%s(), 'fpm.toml'))) then + print *, "Using cached version of '", join_path(self%namespace, self%name, self%requested_version%s()), "'." + target_dir = join_path(cache_path, self%requested_version%s()); return + end if + end if + + tmp_file = get_temp_filename() + open (newunit=unit, file=tmp_file, action='readwrite', iostat=stat) + if (stat /= 0) then + call fatal_error(error, "Error creating temporary file for downloading package '"//self%name//"'."); return + end if + + ! Include namespace and package name in the target url and download package data. + target_url = global_settings%registry_settings%url//'packages/'//self%namespace//'/'//self%name + call downloader%get_pkg_data(target_url, self%requested_version, tmp_file, json, error) + close (unit, status='delete') + if (allocated(error)) return + + ! Verify package data and read relevant information. + call check_and_read_pkg_data(json, self, target_url, version, error) + if (allocated(error)) return + + ! Open new tmp file for downloading the actual package. + open (newunit=unit, file=tmp_file, action='readwrite', iostat=stat) + if (stat /= 0) then + call fatal_error(error, "Error creating temporary file for downloading package '"//self%name//"'."); return + end if + + ! Include version number in the cache path. If no cached version exists, download it. + cache_path = join_path(cache_path, version%s()) + if (.not. exists(join_path(cache_path, 'fpm.toml'))) then + if (is_dir(cache_path)) call os_delete_dir(os_is_unix(), cache_path) + call mkdir(cache_path) + + call downloader%get_file(target_url, tmp_file, error) + if (allocated(error)) then + close (unit, status='delete'); return + end if + + ! Unpack the downloaded package to the final location. + call downloader%unpack(tmp_file, cache_path, error) + close (unit, status='delete') + if (allocated(error)) return + end if + + target_dir = cache_path + + end subroutine get_from_registry + + subroutine check_and_read_pkg_data(json, node, download_url, version, error) + type(json_object), intent(inout) :: json + class(dependency_node_t), intent(in) :: node + character(:), allocatable, intent(out) :: download_url + type(version_t), intent(out) :: version + type(error_t), allocatable, intent(out) :: error + + integer :: code, stat + type(json_object), pointer :: p, q + character(:), allocatable :: version_key, version_str, error_message, namespace, name + + namespace = "" + name = "UNNAMED_NODE" + if (allocated(node%namespace)) namespace = node%namespace + if (allocated(node%name)) name = node%name + + if (.not. json%has_key('code')) then + call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': No status code."); return + end if + + call get_value(json, 'code', code, stat=stat) + if (stat /= 0) then + call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': "// & + & "Failed to read status code."); return + end if + + if (code /= 200) then + if (.not. json%has_key('message')) then + call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': No error message."); return + end if + + call get_value(json, 'message', error_message, stat=stat) + if (stat /= 0) then + call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': "// & + & "Failed to read error message."); return + end if + + call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"'. Status code: '"// & + & str(code)//"'. Error message: '"//error_message//"'."); return + end if + + if (.not. json%has_key('data')) then + call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': No data."); return + end if + + call get_value(json, 'data', p, stat=stat) + if (stat /= 0) then + call fatal_error(error, "Failed to read package data for '"//join_path(namespace, name)//"'."); return + end if + + if (allocated(node%requested_version)) then + version_key = 'version_data' + else + version_key = 'latest_version_data' + end if + + if (.not. p%has_key(version_key)) then + call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': No version data."); return + end if + + call get_value(p, version_key, q, stat=stat) + if (stat /= 0) then + call fatal_error(error, "Failed to retrieve version data for '"//join_path(namespace, name)//"'."); return + end if + + if (.not. q%has_key('download_url')) then + call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': No download url."); return + end if + + call get_value(q, 'download_url', download_url, stat=stat) + if (stat /= 0) then + call fatal_error(error, "Failed to read download url for '"//join_path(namespace, name)//"'."); return + end if + + download_url = official_registry_base_url//download_url + + if (.not. q%has_key('version')) then + call fatal_error(error, "Failed to download '"//join_path(namespace, name)//"': No version found."); return + end if + + call get_value(q, 'version', version_str, stat=stat) + if (stat /= 0) then + call fatal_error(error, "Failed to read version data for '"//join_path(namespace, name)//"'."); return + end if + + call new_version(version, version_str, error) + if (allocated(error)) then + call fatal_error(error, "'"//version_str//"' is not a valid version for '"// & + & join_path(namespace, name)//"'."); return + end if + end subroutine + + !> Get the dependency from a local registry. + subroutine get_from_local_registry(self, target_dir, registry_path, error) + + !> Instance of the dependency configuration. + class(dependency_node_t), intent(in) :: self + + !> The target directory to download the dependency to. + character(:), allocatable, intent(out) :: target_dir + + !> The path to the local registry. + character(*), intent(in) :: registry_path + + !> Error handling. + type(error_t), allocatable, intent(out) :: error + + character(:), allocatable :: path_to_name + type(string_t), allocatable :: files(:) + type(version_t), allocatable :: versions(:) + type(version_t) :: version + integer :: i + + path_to_name = join_path(registry_path, self%namespace, self%name) + + if (.not. exists(path_to_name)) then + call fatal_error(error, "Dependency resolution of '"//self%name// & + & "': Directory '"//path_to_name//"' doesn't exist."); return + end if + + call list_files(path_to_name, files) + if (size(files) == 0) then + call fatal_error(error, "No versions of '"//self%name//"' found in '"//path_to_name//"'."); return + end if + + ! Version requested, find it in the cache. + if (allocated(self%requested_version)) then + do i = 1, size(files) + ! Identify directory that matches the version number. + if (files(i)%s == join_path(path_to_name, self%requested_version%s()) .and. is_dir(files(i)%s)) then + if (.not. exists(join_path(files(i)%s, 'fpm.toml'))) then + call fatal_error(error, "'"//files(i)%s//"' is missing an 'fpm.toml' file."); return + end if + target_dir = files(i)%s; return + end if + end do + call fatal_error(error, "Version '"//self%requested_version%s()//"' not found in '"//path_to_name//"'") + return + end if + + ! No specific version requested, therefore collect available versions. + allocate (versions(0)) + do i = 1, size(files) + if (is_dir(files(i)%s)) then + call new_version(version, basename(files(i)%s), error) + if (allocated(error)) return + versions = [versions, version] + end if + end do + + if (size(versions) == 0) then + call fatal_error(error, "No versions found in '"//path_to_name//"'"); return + end if + + ! Find the latest version. + version = versions(1) + do i = 1, size(versions) + if (versions(i) > version) version = versions(i) + end do + + path_to_name = join_path(path_to_name, version%s()) + + if (.not. exists(join_path(path_to_name, 'fpm.toml'))) then + call fatal_error(error, "'"//path_to_name//"' is missing an 'fpm.toml' file."); return + end if + + target_dir = path_to_name + end subroutine get_from_local_registry + + !> True if dependency is part of the tree + pure logical function has_dependency(self, dependency) + !> Instance of the dependency tree + class(dependency_tree_t), intent(in) :: self + !> Dependency configuration to check + class(dependency_node_t), intent(in) :: dependency + + has_dependency = self%find(dependency%name) /= 0 + + end function has_dependency + + !> Find a dependency in the dependency tree + pure function find_name(self, name) result(pos) + !> Instance of the dependency tree + class(dependency_tree_t), intent(in) :: self + !> Dependency configuration to add + character(len=*), intent(in) :: name + !> Index of the dependency + integer :: pos + + integer :: ii + + pos = 0 + do ii = 1, self%ndep + if (name == self%dep(ii)%name) then + pos = ii + exit + end if + end do + + end function find_name + + !> Check if we are done with the dependency resolution + pure function finished(self) + !> Instance of the dependency tree + class(dependency_tree_t), intent(in) :: self + !> All dependencies are updated + logical :: finished + + finished = all(self%dep(:self%ndep)%done) + + end function finished + + !> Update dependency from project manifest + subroutine register(self, package, root, fetch, revision, error) + !> Instance of the dependency node + class(dependency_node_t), intent(inout) :: self + !> Package configuration data + type(package_config_t), intent(in) :: package + !> Project has been fetched + logical, intent(in) :: fetch + !> Root directory of the project + character(len=*), intent(in) :: root + !> Git revision of the project + character(len=*), intent(in), optional :: revision + !> Error handling + type(error_t), allocatable, intent(out) :: error + + logical :: update + + update = .false. + if (self%name /= package%name) then + call fatal_error(error, "Dependency name '"//package%name// & + & "' found, but expected '"//self%name//"' instead") + end if + + self%version = package%version + self%proj_dir = root + + if (allocated(self%git) .and. present(revision)) then + self%revision = revision + if (.not. fetch) then + ! Change in revision ID was checked already. Only update if ALL git information is missing + update = .not. allocated(self%git%url) + end if + end if + + if (update) self%update = update + self%done = .true. + + end subroutine register + + !> Read dependency tree from file + subroutine load_cache_from_file(self, file, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> File name + character(len=*), intent(in) :: file + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + logical :: exist + + inquire (file=file, exist=exist) + if (.not. exist) return + + open (file=file, newunit=unit) + call self%load_cache(unit, error) + close (unit) + end subroutine load_cache_from_file + + !> Read dependency tree from file + subroutine load_cache_from_unit(self, unit, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> File name + integer, intent(in) :: unit + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_error), allocatable :: parse_error + type(toml_table), allocatable :: table + + call toml_load(table, unit, error=parse_error) + + if (allocated(parse_error)) then + allocate (error) + call move_alloc(parse_error%message, error%message) + return + end if + + call self%load_cache(table, error) + if (allocated(error)) return + + end subroutine load_cache_from_unit + + !> Read dependency tree from TOML data structure + subroutine load_cache_from_toml(self, table, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Data structure + type(toml_table), intent(inout) :: table + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ndep, ii + logical :: is_unix + character(len=:), allocatable :: version, url, obj, rev, proj_dir + type(toml_key), allocatable :: list(:) + type(toml_table), pointer :: ptr + + call table%get_keys(list) + + ndep = size(self%dep) + if (ndep < size(list) + self%ndep) then + call resize(self%dep, ndep + ndep/2 + size(list)) + end if + + is_unix = get_os_type() /= OS_WINDOWS + + do ii = 1, size(list) + call get_value(table, list(ii)%key, ptr) + call get_value(ptr, "version", version) + call get_value(ptr, "proj-dir", proj_dir) + call get_value(ptr, "git", url) + call get_value(ptr, "obj", obj) + call get_value(ptr, "rev", rev) + if (.not. allocated(proj_dir)) cycle + self%ndep = self%ndep + 1 + associate (dep => self%dep(self%ndep)) + dep%name = list(ii)%key + if (is_unix) then + dep%proj_dir = proj_dir + else + dep%proj_dir = windows_path(proj_dir) + end if + dep%done = .false. + if (allocated(version)) then + if (.not. allocated(dep%version)) allocate (dep%version) + call new_version(dep%version, version, error) + if (allocated(error)) exit + end if + if (allocated(url)) then + if (allocated(obj)) then + dep%git = git_target_revision(url, obj) + else + dep%git = git_target_default(url) + end if + if (allocated(rev)) then + dep%revision = rev + end if + else + dep%path = proj_dir + end if + end associate + end do + if (allocated(error)) return + + self%ndep = size(list) + end subroutine load_cache_from_toml + + !> Write dependency tree to file + subroutine dump_cache_to_file(self, file, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> File name + character(len=*), intent(in) :: file + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + + open (file=file, newunit=unit) + call self%dump_cache(unit, error) + close (unit) + if (allocated(error)) return + + end subroutine dump_cache_to_file + + !> Write dependency tree to file + subroutine dump_cache_to_unit(self, unit, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Formatted unit + integer, intent(in) :: unit + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + + table = toml_table() + call self%dump_cache(table, error) + + write (unit, '(a)') toml_serialize(table) + + end subroutine dump_cache_to_unit + + !> Write dependency tree to TOML datastructure + subroutine dump_cache_to_toml(self, table, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Data structure + type(toml_table), intent(inout) :: table + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ii + type(toml_table), pointer :: ptr + character(len=:), allocatable :: proj_dir + + do ii = 1, self%ndep + associate (dep => self%dep(ii)) + call add_table(table, dep%name, ptr) + if (.not. associated(ptr)) then + call fatal_error(error, "Cannot create entry for "//dep%name) + exit + end if + if (allocated(dep%version)) then + call set_value(ptr, "version", dep%version%s()) + end if + proj_dir = canon_path(dep%proj_dir) + call set_value(ptr, "proj-dir", proj_dir) + if (allocated(dep%git)) then + call set_value(ptr, "git", dep%git%url) + if (allocated(dep%git%object)) then + call set_value(ptr, "obj", dep%git%object) + end if + if (allocated(dep%revision)) then + call set_value(ptr, "rev", dep%revision) + end if + end if + end associate + end do + if (allocated(error)) return + + end subroutine dump_cache_to_toml + + !> Reallocate a list of dependencies + pure subroutine resize_dependency_node(var, n) + !> Instance of the array to be resized + type(dependency_node_t), allocatable, intent(inout) :: var(:) + !> Dimension of the final array size + integer, intent(in), optional :: n + + type(dependency_node_t), allocatable :: tmp(:) + integer :: this_size, new_size + integer, parameter :: initial_size = 16 + + if (allocated(var)) then + this_size = size(var, 1) + call move_alloc(var, tmp) + else + this_size = initial_size + end if + + if (present(n)) then + new_size = n + else + new_size = this_size + this_size/2 + 1 + end if + + allocate (var(new_size)) + + if (allocated(tmp)) then + this_size = min(size(tmp, 1), size(var, 1)) + var(:this_size) = tmp(:this_size) + deallocate (tmp) + end if + + end subroutine resize_dependency_node + + !> Check if a dependency node has changed + logical function dependency_has_changed(cached, manifest, verbosity, iunit) result(has_changed) + !> Two instances of the same dependency to be compared + type(dependency_node_t), intent(in) :: cached, manifest + + !> Log verbosity + integer, intent(in) :: verbosity, iunit + + integer :: ip + + has_changed = .true. + + !> All the following entities must be equal for the dependency to not have changed + if (manifest_has_changed(cached=cached, manifest=manifest, verbosity=verbosity, iunit=iunit)) return + + !> For now, only perform the following checks if both are available. A dependency in cache.toml + !> will always have this metadata; a dependency from fpm.toml which has not been fetched yet + !> may not have it + if (allocated(cached%version) .and. allocated(manifest%version)) then + if (cached%version /= manifest%version) then + if (verbosity > 1) write (iunit, out_fmt) "VERSION has changed: "//cached%version%s()//" vs. "//manifest%version%s() + return + end if + else + if (verbosity > 1) write (iunit, out_fmt) "VERSION has changed presence " + end if + if (allocated(cached%revision) .and. allocated(manifest%revision)) then + if (cached%revision /= manifest%revision) then + if (verbosity > 1) write (iunit, out_fmt) "REVISION has changed: "//cached%revision//" vs. "//manifest%revision + return + end if + else + if (verbosity > 1) write (iunit, out_fmt) "REVISION has changed presence " + end if + if (allocated(cached%proj_dir) .and. allocated(manifest%proj_dir)) then + if (cached%proj_dir /= manifest%proj_dir) then + if (verbosity > 1) write (iunit, out_fmt) "PROJECT DIR has changed: "//cached%proj_dir//" vs. "//manifest%proj_dir + return + end if + else + if (verbosity > 1) write (iunit, out_fmt) "PROJECT DIR has changed presence " + end if + if (allocated(cached%preprocess) .eqv. allocated(manifest%preprocess)) then + if (allocated(cached%preprocess)) then + if (size(cached%preprocess) /= size(manifest%preprocess)) then + if (verbosity > 1) write (iunit, out_fmt) "PREPROCESS has changed size" + return + end if + do ip=1,size(cached%preprocess) + if (.not.(cached%preprocess(ip) == manifest%preprocess(ip))) then + if (verbosity > 1) write (iunit, out_fmt) "PREPROCESS config has changed" + return + end if + end do + endif + else + if (verbosity > 1) write (iunit, out_fmt) "PREPROCESS has changed presence " + return + end if + + !> All checks passed: the two dependencies have no differences + has_changed = .false. + + end function dependency_has_changed + + !> Check that two dependency nodes are equal + logical function dependency_node_is_same(this,that) + class(dependency_node_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + dependency_node_is_same = .false. + + select type (other=>that) + type is (dependency_node_t) + + ! Base class must match + if (.not.(this%dependency_config_t==other%dependency_config_t)) return + + ! Extension must match + if (.not.(this%done .eqv.other%done)) return + if (.not.(this%update.eqv.other%update)) return + if (.not.(this%cached.eqv.other%cached)) return + if (.not.(this%proj_dir==other%proj_dir)) return + if (.not.(this%revision==other%revision)) return + + if (.not.(allocated(this%version).eqv.allocated(other%version))) return + if (allocated(this%version)) then + if (.not.(this%version==other%version)) return + endif + + class default + ! Not the same type + return + end select + + !> All checks passed! + dependency_node_is_same = .true. + + end function dependency_node_is_same + + !> Dump dependency to toml table + subroutine node_dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(dependency_node_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr + + ! Dump parent class + call self%dependency_config_t%dump_to_toml(table, error) + if (allocated(error)) return + + if (allocated(self%version)) then + call set_string(table, "version", self%version%s(), error,'dependency_node_t') + if (allocated(error)) return + endif + call set_string(table, "proj-dir", self%proj_dir, error, 'dependency_node_t') + if (allocated(error)) return + call set_string(table, "revision", self%revision, error, 'dependency_node_t') + if (allocated(error)) return + call set_value(table, "done", self%done, error, 'dependency_node_t') + if (allocated(error)) return + call set_value(table, "update", self%update, error, 'dependency_node_t') + if (allocated(error)) return + call set_value(table, "cached", self%cached, error, 'dependency_node_t') + if (allocated(error)) return + + end subroutine node_dump_to_toml + + !> Read dependency from toml table (no checks made at this stage) + subroutine node_load_from_toml(self, table, error) + + !> Instance of the serializable object + class(dependency_node_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + character(len=:), allocatable :: version + integer :: ierr + + call destroy_dependency_node(self) + + ! Load parent class + call self%dependency_config_t%load_from_toml(table, error) + if (allocated(error)) return + + call get_value(table, "done", self%done, error, 'dependency_node_t') + if (allocated(error)) return + call get_value(table, "update", self%update, error, 'dependency_node_t') + if (allocated(error)) return + call get_value(table, "cached", self%cached, error, 'dependency_node_t') + if (allocated(error)) return + + call get_value(table, "proj-dir", self%proj_dir) + call get_value(table, "revision", self%revision) + + call get_value(table, "version", version) + if (allocated(version)) then + allocate(self%version) + call new_version(self%version, version, error) + if (allocated(error)) then + error%message = 'dependency_node_t: version error from TOML table - '//error%message + return + endif + end if + + end subroutine node_load_from_toml + + !> Destructor + elemental subroutine destroy_dependency_node(self) + + class(dependency_node_t), intent(inout) :: self + + integer :: ierr + + call dependency_destroy(self) + + deallocate(self%version,stat=ierr) + deallocate(self%proj_dir,stat=ierr) + deallocate(self%revision,stat=ierr) + self%done = .false. + self%update = .false. + self%cached = .false. + + end subroutine destroy_dependency_node + + !> Check that two dependency trees are equal + logical function dependency_tree_is_same(this,that) + class(dependency_tree_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + integer :: ii + + dependency_tree_is_same = .false. + + select type (other=>that) + type is (dependency_tree_t) + + if (.not.(this%unit==other%unit)) return + if (.not.(this%verbosity==other%verbosity)) return + if (.not.(this%dep_dir==other%dep_dir)) return + if (.not.(this%ndep==other%ndep)) return + if (.not.(allocated(this%dep).eqv.allocated(other%dep))) return + if (allocated(this%dep)) then + if (.not.(size(this%dep)==size(other%dep))) return + do ii = 1, size(this%dep) + if (.not.(this%dep(ii)==other%dep(ii))) return + end do + endif + if (.not.(this%cache==other%cache)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + dependency_tree_is_same = .true. + + end function dependency_tree_is_same + + !> Dump dependency to toml table + subroutine tree_dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(dependency_tree_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr, ii + type(toml_table), pointer :: ptr_deps,ptr + character(27) :: unnamed + + call set_value(table, "unit", self%unit, error, 'dependency_tree_t') + if (allocated(error)) return + call set_value(table, "verbosity", self%verbosity, error, 'dependency_tree_t') + if (allocated(error)) return + call set_string(table, "dep-dir", self%dep_dir, error, 'dependency_tree_t') + if (allocated(error)) return + call set_string(table, "cache", self%cache, error, 'dependency_tree_t') + if (allocated(error)) return + call set_value(table, "ndep", self%ndep, error, 'dependency_tree_t') + if (allocated(error)) return + + if (allocated(self%dep)) then + + ! Create dependency table + call add_table(table, "dependencies", ptr_deps) + if (.not. associated(ptr_deps)) then + call fatal_error(error, "dependency_tree_t cannot create dependency table ") + return + end if + + do ii = 1, size(self%dep) + associate (dep => self%dep(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(dep%name)==0) then + write(unnamed,1) ii + call add_table(ptr_deps, trim(unnamed), ptr) + else + call add_table(ptr_deps, dep%name, ptr) + end if + if (.not. associated(ptr)) then + call fatal_error(error, "dependency_tree_t cannot create entry for dependency "//dep%name) + return + end if + call dep%dump_to_toml(ptr, error) + if (allocated(error)) return + end associate + end do + + endif + + 1 format('UNNAMED_DEPENDENCY_',i0) + + end subroutine tree_dump_to_toml + + !> Read dependency from toml table (no checks made at this stage) + subroutine tree_load_from_toml(self, table, error) + + !> Instance of the serializable object + class(dependency_tree_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + type(toml_key), allocatable :: keys(:),dep_keys(:) + type(toml_table), pointer :: ptr_deps,ptr + integer :: ii, jj, ierr + + call table%get_keys(keys) + + call get_value(table, "unit", self%unit, error, 'dependency_tree_t') + if (allocated(error)) return + call get_value(table, "verbosity", self%verbosity, error, 'dependency_tree_t') + if (allocated(error)) return + call get_value(table, "ndep", self%ndep, error, 'dependency_tree_t') + if (allocated(error)) return + call get_value(table, "dep-dir", self%dep_dir) + call get_value(table, "cache", self%cache) + + find_deps_table: do ii = 1, size(keys) + if (keys(ii)%key=="dependencies") then + + call get_value(table, keys(ii), ptr_deps) + if (.not.associated(ptr_deps)) then + call fatal_error(error,'dependency_tree_t: error retrieving dependency table from TOML table') + return + end if + + !> Read all dependencies + call ptr_deps%get_keys(dep_keys) + call resize(self%dep, size(dep_keys)) + + do jj = 1, size(dep_keys) + + call get_value(ptr_deps, dep_keys(jj), ptr) + call self%dep(jj)%load_from_toml(ptr, error) + if (allocated(error)) return + + end do + + exit find_deps_table + + endif + end do find_deps_table + + end subroutine tree_load_from_toml + +end module fpm_dependency + +!>>>>> ././src/fpm_model.f90 + +!># The fpm package model +!> +!> Defines the fpm model data types which encapsulate all information +!> required to correctly build a package and its dependencies. +!> +!> The process (see `[[build_model(subroutine)]]`) for generating a valid `[[fpm_model]]` involves +!> source files discovery ([[fpm_sources]]) and parsing ([[fpm_source_parsing]]). +!> +!> Once a valid `[[fpm_model]]` has been constructed, it may be passed to `[[fpm_targets:targets_from_sources]]` to +!> generate a list of build targets for the backend. +!> +!>### Enumerations +!> +!> __Source type:__ `FPM_UNIT_*` +!> Describes the type of source file — determines build target generation +!> +!> The logical order of precedence for assigning `unit_type` is as follows: +!> +!>``` +!> if source-file contains program then +!> unit_type = FPM_UNIT_PROGRAM +!> else if source-file contains non-module subroutine/function then +!> unit_type = FPM_UNIT_SUBPROGRAM +!> else if source-file contains submodule then +!> unit_type = FPM_UNIT_SUBMODULE +!> else if source-file contains module then +!> unit_type = FPM_UNIT_MODULE +!> end if +!>``` +!> +!> @note A source file is only designated `FPM_UNIT_MODULE` if it **only** contains modules - no non-module subprograms. +!> (This allows tree-shaking/pruning of build targets based on unused module dependencies.) +!> +!> __Source scope:__ `FPM_SCOPE_*` +!> Describes the scoping rules for using modules — controls module dependency resolution +!> +module fpm_model +use iso_fortran_env, only: int64 +use fpm_compiler, only: compiler_t, archiver_t, debug +use fpm_dependency, only: dependency_tree_t +use fpm_strings, only: string_t, str, len_trim, upper, operator(==) +use fpm_toml, only: serializable_t, toml_table, toml_stat, set_value, set_list, get_value, & + & get_list, add_table, toml_key, add_array, set_string +use fpm_error, only: error_t, fatal_error +use fpm_manifest_preprocess, only: preprocess_config_t +implicit none + +private +public :: fpm_model_t, srcfile_t, show_model, fortran_features_t, package_t + +public :: FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, & + FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, & + FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST, & + FPM_UNIT_CPPSOURCE, FPM_SCOPE_NAME, FPM_UNIT_NAME + +!> Source type unknown +integer, parameter :: FPM_UNIT_UNKNOWN = -1 +!> Source contains a fortran program +integer, parameter :: FPM_UNIT_PROGRAM = 1 +!> Source **only** contains one or more fortran modules +integer, parameter :: FPM_UNIT_MODULE = 2 +!> Source contains one or more fortran submodules +integer, parameter :: FPM_UNIT_SUBMODULE = 3 +!> Source contains one or more fortran subprogram not within modules +integer, parameter :: FPM_UNIT_SUBPROGRAM = 4 +!> Source type is c source file +integer, parameter :: FPM_UNIT_CSOURCE = 5 +!> Source type is c header file +integer, parameter :: FPM_UNIT_CHEADER = 6 +!> Souce type is c++ source file. +integer, parameter :: FPM_UNIT_CPPSOURCE = 7 + +!> Source has no module-use scope +integer, parameter :: FPM_SCOPE_UNKNOWN = -1 +!> Module-use scope is library/dependency modules only +integer, parameter :: FPM_SCOPE_LIB = 1 +!> Module-use scope is library/dependency modules only +integer, parameter :: FPM_SCOPE_DEP = 2 +!> Module-use scope is library/dependency and app modules +integer, parameter :: FPM_SCOPE_APP = 3 +!> Module-use scope is library/dependency and test modules +integer, parameter :: FPM_SCOPE_TEST = 4 +integer, parameter :: FPM_SCOPE_EXAMPLE = 5 + +!> Enabled Fortran language features +type, extends(serializable_t) :: fortran_features_t + + !> Use default implicit typing + logical :: implicit_typing = .false. + + !> Use implicit external interface + logical :: implicit_external = .false. + + !> Form to use for all Fortran sources + character(:), allocatable :: source_form + + contains + + !> Serialization interface + procedure :: serializable_is_same => fft_is_same + procedure :: dump_to_toml => fft_dump_to_toml + procedure :: load_from_toml => fft_load_from_toml + +end type fortran_features_t + +!> Type for describing a source file +type, extends(serializable_t) :: srcfile_t + !> File path relative to cwd + character(:), allocatable :: file_name + + !> Name of executable for FPM_UNIT_PROGRAM + character(:), allocatable :: exe_name + + !> Target module-use scope + integer :: unit_scope = FPM_SCOPE_UNKNOWN + + !> Modules provided by this source file (lowerstring) + type(string_t), allocatable :: modules_provided(:) + + !> Type of source unit + integer :: unit_type = FPM_UNIT_UNKNOWN + + !> Parent modules (submodules only) + type(string_t), allocatable :: parent_modules(:) + + !> Modules USEd by this source file (lowerstring) + type(string_t), allocatable :: modules_used(:) + + !> Files INCLUDEd by this source file + type(string_t), allocatable :: include_dependencies(:) + + !> Native libraries to link against + type(string_t), allocatable :: link_libraries(:) + + !> Current hash + integer(int64) :: digest + + contains + + !> Serialization interface + procedure :: serializable_is_same => srcfile_is_same + procedure :: dump_to_toml => srcfile_dump_to_toml + procedure :: load_from_toml => srcfile_load_from_toml + +end type srcfile_t + +!> Type for describing a single package +type, extends(serializable_t) :: package_t + + !> Name of package + character(:), allocatable :: name + + !> Array of sources + type(srcfile_t), allocatable :: sources(:) + + !> List of macros. + type(preprocess_config_t) :: preprocess + + !> Package version number. + character(:), allocatable :: version + + !> Module naming conventions + logical :: enforce_module_names = .false. + + !> Prefix for all module names + type(string_t) :: module_prefix + + !> Language features + type(fortran_features_t) :: features + + contains + + !> Serialization interface + procedure :: serializable_is_same => package_is_same + procedure :: dump_to_toml => package_dump_to_toml + procedure :: load_from_toml => package_load_from_toml + +end type package_t + +!> Type describing everything required to build +!> the root package and its dependencies. +type, extends(serializable_t) :: fpm_model_t + + !> Name of root package + character(:), allocatable :: package_name + + !> Array of packages (including the root package) + type(package_t), allocatable :: packages(:) + + !> Compiler object + type(compiler_t) :: compiler + + !> Archiver object + type(archiver_t) :: archiver + + !> Command line flags passed to fortran for compilation + character(:), allocatable :: fortran_compile_flags + + !> Command line flags passed to C for compilation + character(:), allocatable :: c_compile_flags + + !> Command line flags passed to C++ for compilation + character(:), allocatable :: cxx_compile_flags + + !> Command line flags passed to the linker + character(:), allocatable :: link_flags + + !> Base directory for build + character(:), allocatable :: build_prefix + + !> Include directories + type(string_t), allocatable :: include_dirs(:) + + !> Native libraries to link against + type(string_t), allocatable :: link_libraries(:) + + !> External modules used + type(string_t), allocatable :: external_modules(:) + + !> Project dependencies + type(dependency_tree_t) :: deps + + !> Whether tests should be added to the build list + logical :: include_tests = .true. + + !> Whether module names should be prefixed with the package name + logical :: enforce_module_names = .false. + + !> Prefix for all module names + type(string_t) :: module_prefix + + contains + + !> Serialization interface + procedure :: serializable_is_same => model_is_same + procedure :: dump_to_toml => model_dump_to_toml + procedure :: load_from_toml => model_load_from_toml + +end type fpm_model_t + +contains + +function info_package(p) result(s) + ! Returns representation of package_t + type(package_t), intent(in) :: p + character(:), allocatable :: s + + integer :: i + + s = s // 'package_t(' + s = s // 'name="' // p%name //'"' + s = s // ', sources=[' + do i = 1, size(p%sources) + s = s // info_srcfile(p%sources(i)) + if (i < size(p%sources)) s = s // ", " + end do + s = s // "]" + + ! Print module naming convention + s = s // ', enforce_module_names="' // merge('T','F',p%enforce_module_names) // '"' + + ! Print custom prefix + if (p%enforce_module_names .and. len_trim(p%module_prefix)>0) & + s = s // ', custom_prefix="' // p%module_prefix%s // '"' + + s = s // ")" + +end function info_package + +function info_srcfile(source) result(s) + type(srcfile_t), intent(in) :: source + character(:), allocatable :: s + integer :: i + !type srcfile_t + s = "srcfile_t(" + ! character(:), allocatable :: file_name + s = s // 'file_name="' // source%file_name // '"' + ! character(:), allocatable :: exe_name + s = s // ', exe_name="' // source%exe_name // '"' + ! integer :: unit_scope = FPM_SCOPE_UNKNOWN + s = s // ', unit_scope="' // FPM_SCOPE_NAME(source%unit_scope) // '"' + ! type(string_t), allocatable :: modules_provided(:) + s = s // ", modules_provided=[" + do i = 1, size(source%modules_provided) + s = s // '"' // source%modules_provided(i)%s // '"' + if (i < size(source%modules_provided)) s = s // ", " + end do + s = s // "]" + s = s // ", parent_modules=[" + do i = 1, size(source%parent_modules) + s = s // '"' // source%parent_modules(i)%s // '"' + if (i < size(source%parent_modules)) s = s // ", " + end do + s = s // "]" + ! integer :: unit_type = FPM_UNIT_UNKNOWN + s = s // ', unit_type="' // FPM_UNIT_NAME(source%unit_type) // '"' + ! type(string_t), allocatable :: modules_used(:) + s = s // ", modules_used=[" + do i = 1, size(source%modules_used) + s = s // '"' // source%modules_used(i)%s // '"' + if (i < size(source%modules_used)) s = s // ", " + end do + s = s // "]" + ! type(string_t), allocatable :: include_dependencies(:) + s = s // ", include_dependencies=[" + do i = 1, size(source%include_dependencies) + s = s // '"' // source%include_dependencies(i)%s // '"' + if (i < size(source%include_dependencies)) s = s // ", " + end do + s = s // "]" + ! type(string_t), allocatable :: link_libraries(:) + s = s // ", link_libraries=[" + do i = 1, size(source%link_libraries) + s = s // '"' // source%link_libraries(i)%s // '"' + if (i < size(source%link_libraries)) s = s // ", " + end do + s = s // "]" + ! integer(int64) :: digest + s = s // ", digest=" // str(source%digest) + !end type srcfile_t + s = s // ")" +end function info_srcfile + +function info_srcfile_short(source) result(s) + ! Prints a shortened version of srcfile_t + type(srcfile_t), intent(in) :: source + character(:), allocatable :: s + s = "srcfile_t(" + s = s // 'file_name="' // source%file_name // '"' + s = s // ", ...)" +end function info_srcfile_short + +function info_model(model) result(s) + type(fpm_model_t), intent(in) :: model + character(:), allocatable :: s + integer :: i + !type :: fpm_model_t + s = "fpm_model_t(" + ! character(:), allocatable :: package_name + s = s // 'package_name="' // model%package_name // '"' + ! type(srcfile_t), allocatable :: sources(:) + s = s // ", packages=[" + do i = 1, size(model%packages) + s = s // info_package(model%packages(i)) + if (i < size(model%packages)) s = s // ", " + end do + s = s // "]" + s = s // ', compiler=(' // debug(model%compiler) // ')' + s = s // ', archiver=(' // debug(model%archiver) // ')' + ! character(:), allocatable :: fortran_compile_flags + s = s // ', fortran_compile_flags="' // model%fortran_compile_flags // '"' + s = s // ', c_compile_flags="' // model%c_compile_flags // '"' + s = s // ', cxx_compile_flags="' // model%cxx_compile_flags // '"' + s = s // ', link_flags="' // model%link_flags // '"' + s = s // ', build_prefix="' // model%build_prefix // '"' + ! type(string_t), allocatable :: link_libraries(:) + s = s // ", link_libraries=[" + do i = 1, size(model%link_libraries) + s = s // '"' // model%link_libraries(i)%s // '"' + if (i < size(model%link_libraries)) s = s // ", " + end do + s = s // "]" + ! type(string_t), allocatable :: external_modules(:) + s = s // ", external_modules=[" + do i = 1, size(model%external_modules) + s = s // '"' // model%external_modules(i)%s // '"' + if (i < size(model%external_modules)) s = s // ", " + end do + s = s // "]" + ! type(dependency_tree_t) :: deps + ! TODO: print `dependency_tree_t` properly, which should become part of the + ! model, not imported from another file + s = s // ", deps=dependency_tree_t(...)" + + ! Print module naming convention + s = s // ', enforce_module_names="' // merge('T','F',model%enforce_module_names) // '"' + + ! Print custom prefix + if (model%enforce_module_names .and. len_trim(model%module_prefix)>0) & + s = s // ', custom_prefix="' // model%module_prefix%s // '"' + + !end type fpm_model_t + s = s // ")" +end function info_model + +subroutine show_model(model) + ! Prints a human readable representation of the Model + type(fpm_model_t), intent(in) :: model + print *, info_model(model) +end subroutine show_model + +!> Return the character name of a scope flag +function FPM_SCOPE_NAME(flag) result(name) + integer, intent(in) :: flag + character(len=:), allocatable :: name + + select case (flag) + case (FPM_SCOPE_UNKNOWN); name = "FPM_SCOPE_UNKNOWN" + case (FPM_SCOPE_LIB); name = "FPM_SCOPE_LIB" + case (FPM_SCOPE_DEP); name = "FPM_SCOPE_DEP" + case (FPM_SCOPE_APP); name = "FPM_SCOPE_APP" + case (FPM_SCOPE_TEST); name = "FPM_SCOPE_TEST" + case (FPM_SCOPE_EXAMPLE); name = "FPM_SCOPE_EXAMPLE" + case default; name = "INVALID" + end select +end function FPM_SCOPE_NAME + +!> Parse git FPM_SCOPE identifier from a string +integer function parse_scope(name) result(scope) + character(len=*), intent(in) :: name + + character(len=len(name)) :: uppercase + + !> Make it Case insensitive + uppercase = upper(name) + + select case (trim(uppercase)) + case ("FPM_SCOPE_UNKNOWN"); scope = FPM_SCOPE_UNKNOWN + case ("FPM_SCOPE_LIB"); scope = FPM_SCOPE_LIB + case ("FPM_SCOPE_DEP"); scope = FPM_SCOPE_DEP + case ("FPM_SCOPE_APP"); scope = FPM_SCOPE_APP + case ("FPM_SCOPE_TEST"); scope = FPM_SCOPE_TEST + case ("FPM_SCOPE_EXAMPLE"); scope = FPM_SCOPE_EXAMPLE + case default; scope = -9999 + end select + +end function parse_scope + +!> Return the character name of a unit flag +function FPM_UNIT_NAME(flag) result(name) + integer, intent(in) :: flag + character(len=:), allocatable :: name + + select case (flag) + case (FPM_UNIT_UNKNOWN); name = "FPM_UNIT_UNKNOWN" + case (FPM_UNIT_PROGRAM); name = "FPM_UNIT_PROGRAM" + case (FPM_UNIT_MODULE); name = "FPM_UNIT_MODULE" + case (FPM_UNIT_SUBMODULE); name = "FPM_UNIT_SUBMODULE" + case (FPM_UNIT_SUBPROGRAM); name = "FPM_UNIT_SUBPROGRAM" + case (FPM_UNIT_CSOURCE); name = "FPM_UNIT_CSOURCE" + case (FPM_UNIT_CPPSOURCE); name = "FPM_UNIT_CPPSOURCE" + case (FPM_UNIT_CHEADER); name = "FPM_UNIT_CHEADER" + case default; name = "INVALID" + end select +end function FPM_UNIT_NAME + +!> Parse git FPM_UNIT identifier from a string +integer function parse_unit(name) result(unit) + character(len=*), intent(in) :: name + + character(len=len(name)) :: uppercase + + !> Make it Case insensitive + uppercase = upper(name) + + select case (trim(uppercase)) + case ("FPM_UNIT_UNKNOWN"); unit = FPM_UNIT_UNKNOWN + case ("FPM_UNIT_PROGRAM"); unit = FPM_UNIT_PROGRAM + case ("FPM_UNIT_MODULE"); unit = FPM_UNIT_MODULE + case ("FPM_UNIT_SUBMODULE"); unit = FPM_UNIT_SUBMODULE + case ("FPM_UNIT_SUBPROGRAM"); unit = FPM_UNIT_SUBPROGRAM + case ("FPM_UNIT_CSOURCE"); unit = FPM_UNIT_CSOURCE + case ("FPM_UNIT_CPPSOURCE"); unit = FPM_UNIT_CPPSOURCE + case ("FPM_UNIT_CHEADER"); unit = FPM_UNIT_CHEADER + case default; unit = -9999 + end select + +end function parse_unit + +!> Check that two source files are equal +logical function srcfile_is_same(this,that) + class(srcfile_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + srcfile_is_same = .false. + + select type (other=>that) + type is (srcfile_t) + + if (.not.(this%file_name==other%file_name)) return + if (.not.(this%exe_name==other%exe_name)) return + if (.not.(this%unit_scope==other%unit_scope)) return + if (.not.(this%modules_provided==other%modules_provided)) return + if (.not.(this%unit_type==other%unit_type)) return + if (.not.(this%parent_modules==other%parent_modules)) return + if (.not.(this%modules_used==other%modules_used)) return + if (.not.(this%include_dependencies==other%include_dependencies)) return + if (.not.(this%link_libraries==other%link_libraries)) return + if (.not.(this%digest==other%digest)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + srcfile_is_same = .true. + +end function srcfile_is_same + +!> Dump dependency to toml table +subroutine srcfile_dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(srcfile_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr + + call set_string(table, "file-name", self%file_name, error, 'srcfile_t') + if (allocated(error)) return + call set_string(table, "exe-name", self%exe_name, error, 'srcfile_t') + if (allocated(error)) return + call set_value(table, "digest", self%digest, error, 'srcfile_t') + if (allocated(error)) return + + ! unit_scope and unit_type are saved as strings so the output is independent + ! of the internal representation + call set_string(table,"unit-scope",FPM_SCOPE_NAME(self%unit_scope), error, 'srcfile_t') + if (allocated(error)) return + call set_string(table,"unit-type",FPM_UNIT_NAME(self%unit_type), error, 'srcfile_t') + if (allocated(error)) return + call set_list(table, "modules-provided",self%modules_provided, error) + if (allocated(error)) return + call set_list(table, "parent-modules",self%parent_modules, error) + if (allocated(error)) return + call set_list(table, "modules-used",self%modules_used, error) + if (allocated(error)) return + call set_list(table, "include-dependencies",self%include_dependencies, error) + if (allocated(error)) return + call set_list(table, "link-libraries",self%link_libraries, error) + if (allocated(error)) return + +end subroutine srcfile_dump_to_toml + +!> Read dependency from toml table (no checks made at this stage) +subroutine srcfile_load_from_toml(self, table, error) + + !> Instance of the serializable object + class(srcfile_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: flag + integer :: ierr + + call get_value(table, "file-name", self%file_name) + call get_value(table, "exe-name", self%exe_name) + call get_value(table, "digest", self%digest, error, 'srcfile_t') + if (allocated(error)) return + + ! unit_scope and unit_type are saved as strings so the output is independent + ! of the internal representation + call get_value(table, "unit-scope", flag) + if (allocated(flag)) self%unit_scope = parse_scope(flag) + call get_value(table, "unit-type", flag) + if (allocated(flag)) self%unit_type = parse_unit(flag) + + call get_list(table,"modules-provided",self%modules_provided, error) + if (allocated(error)) return + + call get_list(table,"parent-modules",self%parent_modules, error) + if (allocated(error)) return + + call get_list(table,"modules-used",self%modules_used, error) + if (allocated(error)) return + + call get_list(table,"include-dependencies",self%include_dependencies, error) + if (allocated(error)) return + + call get_list(table,"link-libraries",self%link_libraries, error) + if (allocated(error)) return + +end subroutine srcfile_load_from_toml + +!> Check that two fortran feature objects are equal +logical function fft_is_same(this,that) + class(fortran_features_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + fft_is_same = .false. + + select type (other=>that) + type is (fortran_features_t) + + if (.not.(this%implicit_typing.eqv.other%implicit_typing)) return + if (.not.(this%implicit_external.eqv.other%implicit_external)) return + if (.not.(this%source_form==other%source_form)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + fft_is_same = .true. + +end function fft_is_same + +!> Dump fortran features to toml table +subroutine fft_dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(fortran_features_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_value(table, "implicit-typing", self%implicit_typing, error, 'fortran_features_t') + if (allocated(error)) return + call set_value(table, "implicit-external", self%implicit_external, error, 'fortran_features_t') + if (allocated(error)) return + call set_string(table, "source-form", self%source_form, error, 'fortran_features_t') + if (allocated(error)) return + +end subroutine fft_dump_to_toml + +!> Read dependency from toml table (no checks made at this stage) +subroutine fft_load_from_toml(self, table, error) + + !> Instance of the serializable object + class(fortran_features_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr + + call get_value(table, "implicit-typing", self%implicit_typing, error, 'fortran_features_t') + if (allocated(error)) return + call get_value(table, "implicit-external", self%implicit_external, error, 'fortran_features_t') + if (allocated(error)) return + ! Return unallocated value if not present + call get_value(table, "source-form", self%source_form) + +end subroutine fft_load_from_toml + +!> Check that two package objects are equal +logical function package_is_same(this,that) + class(package_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + integer :: ii + + package_is_same = .false. + + select type (other=>that) + type is (package_t) + + if (.not.(this%name==other%name)) return + if (.not.(allocated(this%sources).eqv.allocated(other%sources))) return + if (allocated(this%sources)) then + if (.not.(size(this%sources)==size(other%sources))) return + do ii = 1, size(this%sources) + if (.not.(this%sources(ii)==other%sources(ii))) return + end do + end if + + if (.not.(this%preprocess==other%preprocess)) return + if (.not.(this%version==other%version)) return + + !> Module naming + if (.not.(this%enforce_module_names.eqv.other%enforce_module_names)) return + if (.not.(this%module_prefix==other%module_prefix)) return + + !> Fortran features + if (.not.(this%features==other%features)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + package_is_same = .true. + +end function package_is_same + +!> Dump dependency to toml table +subroutine package_dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(package_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr, ii + type(toml_table), pointer :: ptr,this_source + character(16) :: src_name + + call set_string(table, "name", self%name, error, 'package_t') + if (allocated(error)) return + + call set_string(table, "version", self%version, error, 'package_t') + if (allocated(error)) return + + call set_value(table, "module-naming", self%enforce_module_names, error, 'package_t') + if (allocated(error)) return + + call set_string(table, "module-prefix", self%module_prefix, error, 'package_t') + if (allocated(error)) return + + !> Create a preprocessor table + call add_table(table, "preprocess", ptr, error, 'package_t') + if (allocated(error)) return + call self%preprocess%dump_to_toml(ptr, error) + if (allocated(error)) return + + !> Create a fortran table + call add_table(table, "fortran", ptr, error, 'package_t') + if (allocated(error)) return + call self%features%dump_to_toml(ptr, error) + if (allocated(error)) return + + !> Create a sources table + if (allocated(self%sources)) then + + call add_table(table, "sources", ptr, error, 'package_t') + if (allocated(error)) return + + do ii = 1, size(self%sources) + + write(src_name,1) ii + call add_table(ptr, trim(src_name), this_source, error, 'package_t[source]') + if (allocated(error)) return + call self%sources(ii)%dump_to_toml(this_source,error) + if (allocated(error)) return + + end do + + end if + + 1 format('src_',i0) + +end subroutine package_dump_to_toml + +!> Read dependency from toml table (no checks made at this stage) +subroutine package_load_from_toml(self, table, error) + + !> Instance of the serializable object + class(package_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr,ii,jj + type(toml_key), allocatable :: keys(:),src_keys(:) + type(toml_table), pointer :: ptr_sources,ptr,ptr_fortran,ptr_preprocess + type(error_t), allocatable :: new_error + + call get_value(table, "name", self%name) + call get_value(table, "version", self%version) + + call get_value(table, "module-naming", self%enforce_module_names, error, 'package_t') + if (allocated(error)) return + + ! Return unallocated value if not present + call get_value(table, "module-prefix", self%module_prefix%s) + + ! Sources + call table%get_keys(keys) + + find_others: do ii = 1, size(keys) + select case (keys(ii)%key) + case ("fortran") + + call get_value(table, keys(ii), ptr_fortran) + if (.not.associated(ptr_fortran)) then + call fatal_error(error,'package_t: error retrieving fortran table from TOML table') + return + end if + + call self%features%load_from_toml(ptr_fortran,error) + if (allocated(error)) return + + case ("preprocess") + + call get_value(table, keys(ii), ptr_preprocess) + if (.not.associated(ptr_preprocess)) then + call fatal_error(error,'package_t: error retrieving preprocess table from TOML table') + return + end if + + call self%preprocess%load_from_toml(ptr_preprocess,error) + if (allocated(error)) return + + case ("sources") + + call get_value(table, keys(ii), ptr_sources) + if (.not.associated(ptr_sources)) then + call fatal_error(error,'package_t: error retrieving sources table from TOML table') + return + end if + + !> Read all dependencies + call ptr_sources%get_keys(src_keys) + allocate(self%sources(size(src_keys))) + + do jj = 1, size(src_keys) + call get_value(ptr_sources, src_keys(jj), ptr) + call self%sources(jj)%load_from_toml(ptr, error) + if (allocated(error)) return + end do + + case default + cycle find_others + end select + end do find_others + +end subroutine package_load_from_toml + +!> Check that two model objects are equal +logical function model_is_same(this,that) + class(fpm_model_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + type(fpm_model_t), pointer :: other + + integer :: ii + + model_is_same = .false. + + select type (other=>that) + type is (fpm_model_t) + + if (.not.(this%package_name==other%package_name)) return + if (.not.(allocated(this%packages).eqv.allocated(other%packages))) return + if (allocated(this%packages)) then + if (.not.(size(this%packages)==size(other%packages))) return + do ii = 1, size(this%packages) + if (.not.(this%packages(ii)==other%packages(ii))) return + end do + end if + + if (.not.(this%compiler==other%compiler)) return + if (.not.(this%archiver==other%archiver)) return + if (.not.(this%fortran_compile_flags==other%fortran_compile_flags)) return + if (.not.(this%c_compile_flags==other%c_compile_flags)) return + if (.not.(this%cxx_compile_flags==other%cxx_compile_flags)) return + if (.not.(this%link_flags==other%link_flags)) return + if (.not.(this%build_prefix==other%build_prefix)) return + if (.not.(this%include_dirs==other%include_dirs)) return + if (.not.(this%link_libraries==other%link_libraries)) return + if (.not.(this%external_modules==other%external_modules)) return + if (.not.(this%deps==other%deps)) return + if (.not.(this%include_tests.eqv.other%include_tests)) return + if (.not.(this%enforce_module_names.eqv.other%enforce_module_names)) return + if (.not.(this%module_prefix==other%module_prefix)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + model_is_same = .true. + +end function model_is_same + +!> Dump dependency to toml table +subroutine model_dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(fpm_model_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr, ii + type(toml_table), pointer :: ptr,ptr_pkg + character(27) :: unnamed + + call set_string(table, "package-name", self%package_name, error, 'fpm_model_t') + if (allocated(error)) return + + call add_table(table, "compiler", ptr, error, 'fpm_model_t') + if (allocated(error)) return + call self%compiler%dump_to_toml(ptr, error) + if (allocated(error)) return + + call add_table(table, "archiver", ptr, error, 'fpm_model_t') + if (allocated(error)) return + call self%archiver%dump_to_toml(ptr, error) + if (allocated(error)) return + + call set_string(table, "fortran-flags", self%fortran_compile_flags, error, 'fpm_model_t') + if (allocated(error)) return + call set_string(table, "c-flags", self%c_compile_flags, error, 'fpm_model_t') + if (allocated(error)) return + call set_string(table, "cxx-flags", self%cxx_compile_flags, error, 'fpm_model_t') + if (allocated(error)) return + call set_string(table, "link-flags", self%link_flags, error, 'fpm_model_t') + if (allocated(error)) return + call set_string(table, "build-prefix", self%build_prefix, error, 'fpm_model_t') + if (allocated(error)) return + call set_list(table, "include-dirs", self%include_dirs, error) + if (allocated(error)) return + call set_list(table, "link-libraries", self%link_libraries, error) + if (allocated(error)) return + call set_list(table, "external-modules", self%external_modules, error) + if (allocated(error)) return + + call set_value(table, "include-tests", self%include_tests, error, 'fpm_model_t') + if (allocated(error)) return + call set_value(table, "module-naming", self%enforce_module_names, error, 'fpm_model_t') + if (allocated(error)) return + call set_string(table, "module-prefix", self%module_prefix, error, 'fpm_model_t') + if (allocated(error)) return + + call add_table(table, "deps", ptr, error, 'fpm_model_t') + if (allocated(error)) return + call self%deps%dump_to_toml(ptr, error) + if (allocated(error)) return + + !> Array of packages (including the root package) + if (allocated(self%packages)) then + + ! Create packages table + call add_table(table, "packages", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, "fpm_model_t cannot create dependency table ") + return + end if + + do ii = 1, size(self%packages) + + associate (pkg => self%packages(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, 'fpm_model_t[package]') + else + call add_table(ptr_pkg, pkg%name, ptr, error, 'fpm_model_t[package]') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + 1 format('UNNAMED_PACKAGE_',i0) + +end subroutine model_dump_to_toml + +!> Read dependency from toml table (no checks made at this stage) +subroutine model_load_from_toml(self, table, error) + + !> Instance of the serializable object + class(fpm_model_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: keys(:),pkg_keys(:) + integer :: ierr, ii, jj + type(toml_table), pointer :: ptr,ptr_pkg + + call table%get_keys(keys) + + call get_value(table, "package-name", self%package_name) + call get_value(table, "fortran-flags", self%fortran_compile_flags) + call get_value(table, "c-flags", self%c_compile_flags) + call get_value(table, "cxx-flags", self%cxx_compile_flags) + call get_value(table, "link-flags", self%link_flags) + call get_value(table, "build-prefix", self%build_prefix) + + if (allocated(self%packages)) deallocate(self%packages) + sub_deps: do ii = 1, size(keys) + + select case (keys(ii)%key) + case ("compiler") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,'fpm_model_t: error retrieving compiler table') + return + end if + + call self%compiler%load_from_toml(ptr, error) + if (allocated(error)) return + + case ("archiver") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,'fpm_model_t: error retrieving archiver table') + return + end if + + call self%archiver%load_from_toml(ptr, error) + if (allocated(error)) return + + case ("deps") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,'fpm_model_t: error retrieving dependency tree table') + return + end if + + call self%deps%load_from_toml(ptr, error) + if (allocated(error)) return + + case ("packages") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,'fpm_model_t: error retrieving packages table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%packages(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%packages(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + + end do + + case default + cycle sub_deps + end select + + end do sub_deps + + call get_list(table, "include-dirs", self%include_dirs, error) + if (allocated(error)) return + call get_list(table, "link-libraries", self%link_libraries, error) + if (allocated(error)) return + call get_list(table, "external-modules", self%external_modules, error) + if (allocated(error)) return + call get_value(table, "include-tests", self%include_tests, error, 'fpm_model_t') + if (allocated(error)) return + call get_value(table, "module-naming", self%enforce_module_names, error, 'fpm_model_t') + if (allocated(error)) return + call get_value(table, "module-prefix", self%module_prefix%s) + +end subroutine model_load_from_toml + +end module fpm_model + +!>>>>> ././src/fpm/cmd/update.f90 + +module fpm_cmd_update + use fpm_command_line, only : fpm_update_settings + use fpm_dependency, only : dependency_tree_t, new_dependency_tree + use fpm_error, only : error_t, fpm_stop + use fpm_filesystem, only : exists, mkdir, join_path, delete_file, filewrite + use fpm_manifest, only : package_config_t, get_package_data + use fpm_toml, only: name_is_json + implicit none + private + public :: cmd_update + +contains + + !> Entry point for the update subcommand + subroutine cmd_update(settings) + !> Representation of the command line arguments + type(fpm_update_settings), intent(in) :: settings + + type(package_config_t) :: package + type(dependency_tree_t) :: deps + type(error_t), allocatable :: error + integer :: ii + character(len=:), allocatable :: cache + + call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) + call handle_error(error) + + if (.not. exists("build")) then + call mkdir("build") + call filewrite(join_path("build", ".gitignore"),["*"]) + end if + + cache = join_path("build", "cache.toml") + if (settings%clean) call delete_file(cache) + + call new_dependency_tree(deps, cache=cache, & + verbosity=merge(2, 1, settings%verbose)) + + call deps%add(package, error) + call handle_error(error) + + ! Force-update all dependencies if `--clean` + if (settings%clean) then + do ii = 1, deps%ndep + deps%dep(ii)%update = .true. + end do + end if + + if (settings%fetch_only) return + + if (size(settings%name) == 0) then + call deps%update(error) + call handle_error(error) + else + do ii = 1, size(settings%name) + call deps%update(trim(settings%name(ii)), error) + call handle_error(error) + end do + end if + + if (len_trim(settings%dump)>0) then + call deps%dump(trim(settings%dump), error, json=name_is_json(trim(settings%dump))) + call handle_error(error) + end if + + end subroutine cmd_update + + !> Error handling for this command + subroutine handle_error(error) + !> Potential error + type(error_t), intent(in), optional :: error + if (present(error)) then + call fpm_stop(1, '*cmd_update* error: '//error%message) + end if + end subroutine handle_error + +end module fpm_cmd_update + +!>>>>> ././src/fpm_meta.f90 + +!># The fpm meta-package model +!> +!> This is a wrapper data type that encapsulate all pre-processing information +!> (compiler flags, linker libraries, etc.) required to correctly enable a package +!> to use a core library. +!> +!> +!>### Available core libraries +!> +!> - OpenMP +!> - MPI +!> - HDF5 +!> - fortran-lang stdlib +!> - fortran-lang minpack +!> +!> +!> @note Core libraries are enabled in the [build] section of the fpm.toml manifest +!> +!> +module fpm_meta +use fpm_strings, only: string_t, len_trim, remove_newline_characters, str_begins_with_str, & + str_ends_with +use fpm_error, only: error_t, fatal_error, syntax_error, fpm_stop +use fpm_compiler +use fpm_model +use fpm_command_line +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,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 + +implicit none + +private + +public :: resolve_metapackages + +!> Type for describing a source file +type, public :: metapackage_t + + !> Package version (if supported) + type(version_t), allocatable :: version + + logical :: has_link_libraries = .false. + logical :: has_link_flags = .false. + logical :: has_build_flags = .false. + logical :: has_fortran_flags = .false. + logical :: has_c_flags = .false. + logical :: has_cxx_flags = .false. + logical :: has_include_dirs = .false. + logical :: has_dependencies = .false. + logical :: has_run_command = .false. + logical :: has_external_modules = .false. + + !> List of compiler flags and options to be added + type(string_t) :: flags + type(string_t) :: fflags + type(string_t) :: cflags + type(string_t) :: cxxflags + type(string_t) :: link_flags + type(string_t) :: run_command + type(string_t), allocatable :: incl_dirs(:) + type(string_t), allocatable :: link_libs(:) + type(string_t), allocatable :: external_modules(:) + + !> Special fortran features + type(fortran_features_t), allocatable :: fortran + + !> List of Development dependency meta data. + !> Metapackage dependencies are never exported from the model + type(dependency_config_t), allocatable :: dependency(:) + + contains + + !> Clean metapackage structure + procedure :: destroy + + !> Initialize the metapackage structure from its given name + procedure :: new => init_from_name + + !> Add metapackage dependencies to the model + procedure, private :: resolve_cmd + procedure, private :: resolve_model + procedure, private :: resolve_package_config + generic :: resolve => resolve_cmd,resolve_model,resolve_package_config + +end type metapackage_t + +interface resolve_metapackages + module procedure resolve_metapackage_model +end interface resolve_metapackages + +integer, parameter :: MPI_TYPE_NONE = 0 +integer, parameter :: MPI_TYPE_OPENMPI = 1 +integer, parameter :: MPI_TYPE_MPICH = 2 +integer, parameter :: MPI_TYPE_INTEL = 3 +integer, parameter :: MPI_TYPE_MSMPI = 4 +public :: MPI_TYPE_NAME + +!> Debugging information +logical, parameter, private :: verbose = .false. + +integer, parameter, private :: LANG_FORTRAN = 1 +integer, parameter, private :: LANG_C = 2 +integer, parameter, private :: LANG_CXX = 3 + +character(*), parameter :: LANG_NAME(*) = [character(7) :: 'Fortran','C','C++'] + +contains + +!> Return a name for the MPI library +pure function MPI_TYPE_NAME(mpilib) result(name) + integer, intent(in) :: mpilib + character(len=:), allocatable :: name + select case (mpilib) + case (MPI_TYPE_NONE); name = "none" + case (MPI_TYPE_OPENMPI); name = "OpenMPI" + case (MPI_TYPE_MPICH); name = "MPICH" + case (MPI_TYPE_INTEL); name = "INTELMPI" + case (MPI_TYPE_MSMPI); name = "MS-MPI" + case default; name = "UNKNOWN" + end select +end function MPI_TYPE_NAME + +!> Clean the metapackage structure +elemental subroutine destroy(this) + class(metapackage_t), intent(inout) :: this + + this%has_link_libraries = .false. + this%has_link_flags = .false. + this%has_build_flags = .false. + this%has_fortran_flags = .false. + this%has_c_flags = .false. + this%has_cxx_flags = .false. + this%has_include_dirs = .false. + this%has_dependencies = .false. + this%has_run_command = .false. + this%has_external_modules = .false. + + if (allocated(this%fortran)) deallocate(this%fortran) + if (allocated(this%version)) deallocate(this%version) + if (allocated(this%flags%s)) deallocate(this%flags%s) + if (allocated(this%fflags%s)) deallocate(this%fflags%s) + if (allocated(this%cflags%s)) deallocate(this%cflags%s) + if (allocated(this%cxxflags%s)) deallocate(this%cxxflags%s) + if (allocated(this%link_flags%s)) deallocate(this%link_flags%s) + if (allocated(this%run_command%s)) deallocate(this%run_command%s) + if (allocated(this%link_libs)) deallocate(this%link_libs) + if (allocated(this%dependency)) deallocate(this%dependency) + if (allocated(this%incl_dirs)) deallocate(this%incl_dirs) + if (allocated(this%external_modules)) deallocate(this%external_modules) + +end subroutine destroy + +!> Initialize a metapackage from the given name +subroutine init_from_name(this,name,compiler,error) + class(metapackage_t), intent(inout) :: this + character(*), intent(in) :: name + type(compiler_t), intent(in) :: compiler + type(error_t), allocatable, intent(out) :: error + + !> Initialize metapackage by name + select case(name) + case("openmp"); call init_openmp (this,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 + end select + +end subroutine init_from_name + +!> Initialize OpenMP metapackage for the current system +subroutine init_openmp(this,compiler,error) + class(metapackage_t), intent(inout) :: this + type(compiler_t), intent(in) :: compiler + type(error_t), allocatable, intent(out) :: error + + !> Cleanup + call destroy(this) + + !> OpenMP has compiler flags + this%has_build_flags = .true. + this%has_link_flags = .true. + + !> OpenMP flags should be added to + which_compiler: select case (compiler%id) + case (id_gcc,id_f95) + this%flags = string_t(flag_gnu_openmp) + this%link_flags = string_t(flag_gnu_openmp) + + case (id_intel_classic_windows,id_intel_llvm_windows) + this%flags = string_t(flag_intel_openmp_win) + this%link_flags = string_t(flag_intel_openmp_win) + + case (id_intel_classic_nix,id_intel_classic_mac,& + id_intel_llvm_nix) + this%flags = string_t(flag_intel_openmp) + this%link_flags = string_t(flag_intel_openmp) + + case (id_pgi,id_nvhpc) + this%flags = string_t(flag_pgi_openmp) + this%link_flags = string_t(flag_pgi_openmp) + + case (id_ibmxl) + this%flags = string_t(" -qsmp=omp") + this%link_flags = string_t(" -qsmp=omp") + + case (id_nag) + this%flags = string_t(flag_nag_openmp) + this%link_flags = string_t(flag_nag_openmp) + + case (id_lfortran) + this%flags = string_t(flag_lfortran_openmp) + this%link_flags = string_t(flag_lfortran_openmp) + + case default + + call fatal_error(error,'openmp not supported on compiler '//compiler%name()//' yet') + + end select which_compiler + +end subroutine init_openmp + +!> Initialize minpack metapackage for the current system +subroutine init_minpack(this,compiler,error) + class(metapackage_t), intent(inout) :: this + type(compiler_t), intent(in) :: compiler + type(error_t), allocatable, intent(out) :: error + + !> Cleanup + call destroy(this) + + !> minpack is queried as a dependency from the official repository + this%has_dependencies = .true. + + allocate(this%dependency(1)) + + !> 1) minpack. There are no true releases currently. Fetch HEAD + this%dependency(1)%name = "minpack" + this%dependency(1)%git = git_target_tag("https://github.com/fortran-lang/minpack", "v2.0.0-rc.1") + if (.not.allocated(this%dependency(1)%git)) then + call fatal_error(error,'cannot initialize git repo dependency for minpack metapackage') + return + end if + +end subroutine init_minpack + +!> Initialize stdlib metapackage for the current system +subroutine init_stdlib(this,compiler,error) + class(metapackage_t), intent(inout) :: this + type(compiler_t), intent(in) :: compiler + type(error_t), allocatable, intent(out) :: error + + !> Cleanup + call destroy(this) + + !> Stdlib is queried as a dependency from the official repository + this%has_dependencies = .true. + + allocate(this%dependency(2)) + + !> 1) Test-drive + this%dependency(1)%name = "test-drive" + this%dependency(1)%git = git_target_branch("https://github.com/fortran-lang/test-drive","v0.4.0") + if (.not.allocated(this%dependency(1)%git)) then + call fatal_error(error,'cannot initialize test-drive git dependency for stdlib metapackage') + return + end if + + !> 2) stdlib + this%dependency(2)%name = "stdlib" + this%dependency(2)%git = git_target_branch("https://github.com/fortran-lang/stdlib","stdlib-fpm") + if (.not.allocated(this%dependency(2)%git)) then + call fatal_error(error,'cannot initialize git repo dependency for stdlib metapackage') + return + end if + +end subroutine init_stdlib + +! Resolve metapackage dependencies into the command line settings +subroutine resolve_cmd(self,settings,error) + class(metapackage_t), intent(in) :: self + class(fpm_cmd_settings), intent(inout) :: settings + type(error_t), allocatable, intent(out) :: error + + ! Add customize run commands + if (self%has_run_command) then + + select type (cmd=>settings) + class is (fpm_run_settings) ! includes fpm_test_settings + + ! Only override runner if user has not provided a custom one + if (.not.len_trim(cmd%runner)>0) cmd%runner = self%run_command%s + + end select + + endif + +end subroutine resolve_cmd + +! Resolve metapackage dependencies into the model +subroutine resolve_model(self,model,error) + class(metapackage_t), intent(in) :: self + type(fpm_model_t), intent(inout) :: model + type(error_t), allocatable, intent(out) :: error + + ! Add global build flags, to apply to all sources + if (self%has_build_flags) then + model%fortran_compile_flags = model%fortran_compile_flags//self%flags%s + model%c_compile_flags = model%c_compile_flags//self%flags%s + model%cxx_compile_flags = model%cxx_compile_flags//self%flags%s + endif + + ! Add language-specific flags + if (self%has_fortran_flags) model%fortran_compile_flags = model%fortran_compile_flags//self%fflags%s + if (self%has_c_flags) model%c_compile_flags = model%c_compile_flags//self%cflags%s + 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 + end if + + if (self%has_link_libraries) then + model%link_libraries = [model%link_libraries,self%link_libs] + end if + + if (self%has_include_dirs) then + model%include_dirs = [model%include_dirs,self%incl_dirs] + end if + + if (self%has_external_modules) then + model%external_modules = [model%external_modules,self%external_modules] + end if + +end subroutine resolve_model + +subroutine resolve_package_config(self,package,error) + class(metapackage_t), intent(in) :: self + type(package_config_t), intent(inout) :: package + type(error_t), allocatable, intent(out) :: error + + ! All metapackage dependencies are added as dev-dependencies, + ! as they may change if built upstream + if (self%has_dependencies) then + if (allocated(package%dev_dependency)) then + package%dev_dependency = [package%dev_dependency,self%dependency] + else + package%dev_dependency = self%dependency + end if + end if + + ! Check if there are any special fortran requests which the package does not comply to + if (allocated(self%fortran)) then + + if (self%fortran%implicit_external.neqv.package%fortran%implicit_external) then + call fatal_error(error,'metapackage fortran error: metapackage '// & + dn(self%fortran%implicit_external)//' require implicit-external, main package '//& + dn(package%fortran%implicit_external)) + return + end if + + if (self%fortran%implicit_typing.neqv.package%fortran%implicit_typing) then + call fatal_error(error,'metapackage fortran error: metapackage '// & + dn(self%fortran%implicit_external)//' require implicit-typing, main package '//& + dn(package%fortran%implicit_external)) + return + end if + + end if + + contains + + pure function dn(bool) + logical, intent(in) :: bool + character(len=:), allocatable :: dn + if (bool) then + dn = "does" + else + dn = "does not" + end if + end function dn + +end subroutine resolve_package_config + +! Add named metapackage dependency to the model +subroutine add_metapackage_model(model,package,settings,name,error) + type(fpm_model_t), intent(inout) :: model + type(package_config_t), intent(inout) :: package + class(fpm_cmd_settings), intent(inout) :: settings + character(*), intent(in) :: name + type(error_t), allocatable, intent(out) :: error + + type(metapackage_t) :: meta + + !> Init metapackage + call meta%new(name,model%compiler,error) + if (allocated(error)) return + + !> Add it into the model + call meta%resolve(model,error) + if (allocated(error)) return + + !> Add it into the package + call meta%resolve(package,error) + if (allocated(error)) return + + !> Add it into the settings + call meta%resolve(settings,error) + if (allocated(error)) return + + ! If we need to run executables, there should be an MPI runner + if (name=="mpi") then + select type (settings) + class is (fpm_run_settings) ! run, test + if (.not.meta%has_run_command) & + call fatal_error(error,"cannot find a valid mpi runner on the local host") + end select + endif + +end subroutine add_metapackage_model + +!> Resolve all metapackages into the package config +subroutine resolve_metapackage_model(model,package,settings,error) + type(fpm_model_t), intent(inout) :: model + type(package_config_t), intent(inout) :: package + class(fpm_build_settings), intent(inout) :: settings + type(error_t), allocatable, intent(out) :: error + + ! Dependencies are added to the package config, so they're properly resolved + ! into the dependency tree later. + ! Flags are added to the model (whose compiler needs to be already initialized) + if (model%compiler%is_unknown()) & + write(stdout,'(a)') ' compiler not initialized: metapackages may not be available' + + ! OpenMP + if (package%meta%openmp%on) then + call add_metapackage_model(model,package,settings,"openmp",error) + if (allocated(error)) return + endif + + ! stdlib + if (package%meta%stdlib%on) then + call add_metapackage_model(model,package,settings,"stdlib",error) + if (allocated(error)) return + endif + + ! 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!' + end if + + ! MPI + if (package%meta%mpi%on) then + call add_metapackage_model(model,package,settings,"mpi",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 +subroutine init_mpi(this,compiler,error) + class(metapackage_t), intent(inout) :: this + type(compiler_t), intent(in) :: compiler + type(error_t), allocatable, intent(out) :: error + + type(string_t), allocatable :: c_wrappers(:),cpp_wrappers(:),fort_wrappers(:) + type(string_t) :: output,fwrap,cwrap,cxxwrap + character(256) :: msg_out + character(len=:), allocatable :: tokens(:) + integer :: wcfit(3),mpilib(3),ic,icpp,i + logical :: found + + !> Cleanup + call destroy(this) + + !> Get all candidate MPI wrappers + call mpi_wrappers(compiler,fort_wrappers,c_wrappers,cpp_wrappers) + if (verbose) print 1, size(fort_wrappers),size(c_wrappers),size(cpp_wrappers) + + call wrapper_compiler_fit(fort_wrappers,c_wrappers,cpp_wrappers,compiler,wcfit,mpilib,error) + + if (allocated(error) .or. all(wcfit==0)) then + + !> No wrapper compiler fit. Are we on Windows? use MSMPI-specific search + found = msmpi_init(this,compiler,error) + if (allocated(error)) return + + !> All attempts failed + if (.not.found) then + call fatal_error(error,"cannot find MPI wrappers or libraries for "//compiler%name()//" compiler") + return + endif + + else + + if (wcfit(LANG_FORTRAN)>0) fwrap = fort_wrappers(wcfit(LANG_FORTRAN)) + if (wcfit(LANG_C)>0) cwrap = c_wrappers (wcfit(LANG_C)) + if (wcfit(LANG_CXX)>0) cxxwrap = cpp_wrappers (wcfit(LANG_CXX)) + + !> If there's only an available Fortran wrapper, and the compiler's different than fpm's baseline + !> fortran compiler suite, we still want to enable C language flags as that is most likely being + !> ABI-compatible anyways. However, issues may arise. + !> see e.g. Homebrew with clabng C/C++ and GNU fortran at https://gitlab.kitware.com/cmake/cmake/-/issues/18139 + if (wcfit(LANG_FORTRAN)>0 .and. all(wcfit([LANG_C,LANG_CXX])==0)) then + cwrap = fort_wrappers(wcfit(LANG_FORTRAN)) + cxxwrap = fort_wrappers(wcfit(LANG_FORTRAN)) + end if + + if (verbose) print *, '+ MPI fortran wrapper: ',fwrap%s + if (verbose) print *, '+ MPI c wrapper: ',cwrap%s + if (verbose) print *, '+ MPI c++ wrapper: ',cxxwrap%s + + !> Initialize MPI package from wrapper command + call init_mpi_from_wrappers(this,compiler,mpilib(LANG_FORTRAN),fwrap,cwrap,cxxwrap,error) + if (allocated(error)) return + + !> Request Fortran implicit typing + if (mpilib(LANG_FORTRAN)/=MPI_TYPE_INTEL) then + allocate(this%fortran) + this%fortran%implicit_typing = .true. + this%fortran%implicit_external = .true. + endif + + end if + + !> Not all MPI implementations offer modules mpi and mpi_f08: hence, include them + !> to the list of external modules, so they won't be requested as standard source files + this%has_external_modules = .true. + this%external_modules = [string_t("mpi"),string_t("mpi_f08")] + + 1 format('MPI wrappers found: fortran=',i0,' c=',i0,' c++=',i0) + +end subroutine init_mpi + +!> Check if we're on a 64-bit environment +!> Accept answer from https://stackoverflow.com/questions/49141093/get-system-information-with-fortran +logical function is_64bit_environment() + use iso_c_binding, only: c_intptr_t + integer, parameter :: nbits = bit_size(0_c_intptr_t) + is_64bit_environment = nbits==64 +end function is_64bit_environment + +!> Check if there is a wrapper-compiler fit +subroutine wrapper_compiler_fit(fort_wrappers,c_wrappers,cpp_wrappers,compiler,wrap,mpi,error) + type(string_t), allocatable, intent(in) :: fort_wrappers(:),c_wrappers(:),cpp_wrappers(:) + type(compiler_t), intent(in) :: compiler + type(error_t), allocatable, intent(out) :: error + integer, intent(out), dimension(3) :: wrap, mpi + + type(error_t), allocatable :: wrap_error + + wrap = 0 + mpi = MPI_TYPE_NONE + + if (size(fort_wrappers)>0) & + call mpi_compiler_match(LANG_FORTRAN,fort_wrappers,compiler,wrap(LANG_FORTRAN),mpi(LANG_FORTRAN),wrap_error) + + if (size(c_wrappers)>0) & + call mpi_compiler_match(LANG_C,c_wrappers,compiler,wrap(LANG_C),mpi(LANG_C),wrap_error) + + if (size(cpp_wrappers)>0) & + call mpi_compiler_match(LANG_CXX,cpp_wrappers,compiler,wrap(LANG_CXX),mpi(LANG_CXX),wrap_error) + + !> Find a Fortran wrapper for the current compiler + if (all(wrap==0)) then + call fatal_error(error,'no valid wrappers match current compiler, '//compiler_name(compiler)) + return + end if + +end subroutine wrapper_compiler_fit + +!> Check if a local MS-MPI SDK build is found +logical function msmpi_init(this,compiler,error) result(found) + class(metapackage_t), intent(inout) :: this + type(compiler_t), intent(in) :: compiler + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: incdir,windir,libdir,bindir,post,reall,msysdir + type(version_t) :: ver,ver10 + type(string_t) :: cpath,msys_path,runner_path + logical :: msys2 + + !> Default: not found + found = .false. + + if (get_os_type()==OS_WINDOWS) then + + ! to run MSMPI on Windows, + is_minGW: if (compiler%id==id_gcc) then + + call compiler_get_version(compiler,ver,msys2,error) + if (allocated(error)) return + + endif is_minGW + + ! Check we're on a 64-bit environment + if (is_64bit_environment()) then + libdir = get_env('MSMPI_LIB64') + post = 'x64' + else + libdir = get_env('MSMPI_LIB32') + post = 'x86' + + !> Not working on 32-bit Windows yet + call fatal_error(error,'MS-MPI error: this package requires 64-bit Windows environment') + return + + end if + + ! Check that the runtime is installed + bindir = "" + call get_absolute_path(get_env('MSMPI_BIN'),bindir,error) + if (verbose) print *, '+ %MSMPI_BIN%=',bindir + + ! In some environments, variable %MSMPI_BIN% is missing (i.e. in GitHub Action images). + ! Do a second attempt: search for the default location + if (len_trim(bindir)<=0 .or. allocated(error)) then + if (verbose) print *, '+ %MSMPI_BIN% empty, searching C:\Program Files\Microsoft MPI\Bin\ ...' + call get_absolute_path('C:\Program Files\Microsoft MPI\Bin\mpiexec.exe',bindir,error) + endif + + ! Third attempt for bash-style shell + if (len_trim(bindir)<=0 .or. allocated(error)) then + if (verbose) print *, '+ %MSMPI_BIN% empty, searching /c/Program Files/Microsoft MPI/Bin/ ...' + call get_absolute_path('/c/Program Files/Microsoft MPI/Bin/mpiexec.exe',bindir,error) + endif + + ! Do a fourth attempt: search for mpiexec.exe in PATH location + if (len_trim(bindir)<=0 .or. allocated(error)) then + if (verbose) print *, '+ C:\Program Files\Microsoft MPI\Bin\ not found. searching %PATH%...' + + call get_mpi_runner(runner_path,verbose,error) + + if (.not.allocated(error)) then + if (verbose) print *, '+ mpiexec found: ',runner_path%s + call find_command_location(runner_path%s,bindir,verbose=verbose,error=error) + endif + + endif + + if (allocated(error)) then + call fatal_error(error,'MS-MPI error: MS-MPI Runtime directory is missing. '//& + 'check environment variable %MSMPI_BIN% or that the folder is in %PATH%.') + return + end if + + ! Success! + found = .true. + + ! Init ms-mpi + call destroy(this) + + ! MSYS2 provides a pre-built static msmpi.dll.a library. Use that if possible + use_prebuilt: if (msys2) then + + ! MSYS executables are in %MSYS_ROOT%/bin + call compiler_get_path(compiler,cpath,error) + if (allocated(error)) return + + call get_absolute_path(join_path(cpath%s,'..'),msys_path%s,error) + if (allocated(error)) return + + call get_absolute_path(join_path(msys_path%s,'include'),incdir,error) + if (allocated(error)) return + + call get_absolute_path(join_path(msys_path%s,'lib'),libdir,error) + if (allocated(error)) return + + if (verbose) print 1, 'include',incdir,exists(incdir) + if (verbose) print 1, 'library',libdir,exists(libdir) + + ! Check that the necessary files exist + call get_absolute_path(join_path(libdir,'libmsmpi.dll.a'),post,error) + if (allocated(error)) return + + if (len_trim(post)<=0 .or. .not.exists(post)) then + call fatal_error(error,'MS-MPI available through the MSYS2 system not found. '// & + 'Run '// & + 'or your system-specific version to install.') + return + end if + + ! Add dir cpath + this%has_link_flags = .true. + this%link_flags = string_t(' -L'//get_dos_path(libdir,error)) + + this%has_link_libraries = .true. + this%link_libs = [string_t('msmpi.dll')] + + if (allocated(error)) return + + this%has_include_dirs = .true. + this%incl_dirs = [string_t(get_dos_path(incdir,error))] + if (allocated(error)) return + + else + + call fatal_error(error,'MS-MPI cannot work with non-MSYS2 GNU compilers yet') + return + + ! Add dir path + this%has_link_flags = .true. + this%link_flags = string_t(' -L'//get_dos_path(libdir,error)) + + this%has_link_libraries = .true. + this%link_libs = [string_t('msmpi'),string_t('msmpifec'),string_t('msmpifmc')] + + if (allocated(error)) return + + this%has_include_dirs = .true. + this%incl_dirs = [string_t(get_dos_path(incdir,error)), & + string_t(get_dos_path(incdir//post,error))] + if (allocated(error)) return + + end if use_prebuilt + + !> Request Fortran implicit typing + allocate(this%fortran) + this%fortran%implicit_typing = .true. + this%fortran%implicit_external = .true. + + ! gfortran>=10 is incompatible with the old-style mpif.h MS-MPI headers. + ! If so, add flags to allow old-style BOZ constants in mpif.h + allow_BOZ: if (compiler%id==id_gcc) then + + call new_version(ver10,'10.0.0',error) + if (allocated(error)) return + + if (ver>=ver10) then + this%has_build_flags = .true. + this%flags = string_t(' -fallow-invalid-boz') + end if + + endif allow_BOZ + + !> Add default run command + this%has_run_command = .true. + this%run_command = string_t(join_path(get_dos_path(bindir,error),'mpiexec.exe')//' -np * ') + + else + + !> Not on Windows + found = .false. + + end if + + 1 format('MSMSPI ',a,' directory: PATH=',a,' EXISTS=',l1) + +end function msmpi_init + +!> Check if we're under a WSL bash shell +logical function wsl_shell() + if (get_os_type()==OS_WINDOWS) then + wsl_shell = exists('/proc/sys/fs/binfmt_misc/WSLInterop') + else + wsl_shell = .false. + endif +end function wsl_shell + +!> Find the location of a valid command +subroutine find_command_location(command,path,echo,verbose,error) + character(*), intent(in) :: command + character(len=:), allocatable, intent(out) :: path + logical, optional, intent(in) :: echo,verbose + type(error_t), allocatable, intent(out) :: error + + character(:), allocatable :: tmp_file,screen_output,line,fullpath,search_command + integer :: stat,iunit,ire,length,try + character(*), parameter :: search(2) = ["where ","which "] + + if (len_trim(command)<=0) then + call fatal_error(error,'empty command provided in find_command_location') + return + end if + + tmp_file = get_temp_filename() + + ! On Windows, we try both commands because we may be on WSL + do try=merge(1,2,get_os_type()==OS_WINDOWS),2 + search_command = search(try)//command + call run(search_command, echo=echo, exitstat=stat, verbose=verbose, redirect=tmp_file) + if (stat==0) exit + end do + if (stat/=0) then + call fatal_error(error,'find_command_location failed for '//command) + return + end if + + ! Only read first instance (first line) + allocate(character(len=0) :: screen_output) + open(newunit=iunit,file=tmp_file,status='old',iostat=stat) + if (stat == 0)then + do + call getline(iunit, line, stat) + if (stat /= 0) exit + if (len(screen_output)>0) then + screen_output = screen_output//new_line('a')//line + else + screen_output = line + endif + end do + ! Close and delete file + close(iunit,status='delete') + else + call fatal_error(error,'cannot read temporary file from successful find_command_location') + return + endif + + ! Only use the first instance + length = index(screen_output,new_line('a')) + + multiline: if (length>1) then + fullpath = screen_output(1:length-1) + else + fullpath = screen_output + endif multiline + if (len_trim(fullpath)<1) then + call fatal_error(error,'no paths found to command ('//command//')') + return + end if + + ! Extract path only + length = index(fullpath,command,BACK=.true.) + if (length<=0) then + call fatal_error(error,'full path to command ('//command//') does not include command name') + return + elseif (length==1) then + ! Compiler is in the current folder + path = '.' + else + path = fullpath(1:length-1) + end if + if (allocated(error)) return + + ! On Windows, be sure to return a path with no spaces + if (get_os_type()==OS_WINDOWS) path = get_dos_path(path,error) + + if (allocated(error) .or. .not.is_dir(path)) then + call fatal_error(error,'full path ('//path//') to command ('//command//') is not a directory') + return + end if + +end subroutine find_command_location + +!> Get MPI runner in $PATH +subroutine get_mpi_runner(command,verbose,error) + type(string_t), intent(out) :: command + logical, intent(in) :: verbose + type(error_t), allocatable, intent(out) :: error + + character(*), parameter :: try(*) = ['mpiexec ','mpirun ','mpiexec.exe','mpirun.exe '] + character(:), allocatable :: bindir + integer :: itri + logical :: success + + ! Try several commands + do itri=1,size(try) + call find_command_location(trim(try(itri)),command%s,verbose=verbose,error=error) + if (allocated(error)) cycle + + ! Success! + success = len_trim(command%s)>0 + if (success) then + if (verbose) print *, '+ runner folder found: '//command%s + command%s = join_path(command%s,trim(try(itri))) + return + endif + end do + + ! On windows, also search in %MSMPI_BIN% + if (get_os_type()==OS_WINDOWS) then + ! Check that the runtime is installed + bindir = "" + call get_absolute_path(get_env('MSMPI_BIN'),bindir,error) + if (verbose) print *, '+ %MSMPI_BIN%=',bindir + ! In some environments, variable %MSMPI_BIN% is missing (i.e. in GitHub Action images). + ! Do a second attempt: search for the default location + if (len_trim(bindir)<=0 .or. allocated(error)) then + if (verbose) print *, '+ %MSMPI_BIN% empty, searching C:\Program Files\Microsoft MPI\Bin\ ...' + call get_absolute_path('C:\Program Files\Microsoft MPI\Bin\mpiexec.exe',bindir,error) + endif + if (len_trim(bindir)>0 .and. .not.allocated(error)) then + ! MSMPI_BIN directory found + command%s = join_path(bindir,'mpiexec.exe') + return + endif + endif + + ! No valid command found + call fatal_error(error,'cannot find a valid mpi runner command') + return + +end subroutine get_mpi_runner + +!> Return compiler path +subroutine compiler_get_path(self,path,error) + type(compiler_t), intent(in) :: self + type(string_t), intent(out) :: path + type(error_t), allocatable, intent(out) :: error + + call find_command_location(self%fc,path%s,self%echo,self%verbose,error) + +end subroutine compiler_get_path + +!> Return compiler version +subroutine compiler_get_version(self,version,is_msys2,error) + type(compiler_t), intent(in) :: self + type(version_t), intent(out) :: version + logical, intent(out) :: is_msys2 + type(error_t), allocatable, intent(out) :: error + + character(:), allocatable :: tmp_file,screen_output,line + type(string_t) :: ver + integer :: stat,iunit,ire,length + + is_msys2 = .false. + + select case (self%id) + case (id_gcc) + + tmp_file = get_temp_filename() + + call run(self%fc // " --version ", echo=self%echo, verbose=self%verbose, redirect=tmp_file, exitstat=stat) + if (stat/=0) then + call fatal_error(error,'compiler_get_version failed for '//self%fc) + return + end if + + allocate(character(len=0) :: screen_output) + open(newunit=iunit,file=tmp_file,status='old',iostat=stat) + if (stat == 0)then + do + call getline(iunit, line, stat) + if (stat /= 0) exit + screen_output = screen_output//' '//line//' ' + end do + ! Close and delete file + close(iunit,status='delete') + else + call fatal_error(error,'cannot read temporary file from successful compiler_get_version') + return + endif + + ! Check if this gcc is from the MSYS2 project + is_msys2 = index(screen_output,'MSYS2')>0 + + ver = regex_version_from_text(screen_output,self%fc//' compiler',error) + if (allocated(error)) return + + ! Extract version + call new_version(version,ver%s,error) + + case default + call fatal_error(error,'compiler_get_version not yet implemented for compiler '//self%fc) + return + end select + +end subroutine compiler_get_version + +!> Initialize an MPI metapackage from a valid wrapper command ('mpif90', etc...) +subroutine init_mpi_from_wrappers(this,compiler,mpilib,fort_wrapper,c_wrapper,cxx_wrapper,error) + class(metapackage_t), intent(inout) :: this + type(compiler_t), intent(in) :: compiler + integer, intent(in) :: mpilib + type(string_t), intent(in) :: fort_wrapper,c_wrapper,cxx_wrapper + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: version + type(error_t), allocatable :: runner_error + + ! Cleanup structure + call destroy(this) + + ! Get linking flags + this%link_flags = mpi_wrapper_query(mpilib,fort_wrapper,'link',verbose,error) + if (allocated(error)) return + + ! Remove useless/dangerous flags + call filter_link_arguments(compiler,this%link_flags) + + this%has_link_flags = len_trim(this%link_flags)>0 + + ! Request to use libs in arbitrary order + if (this%has_link_flags .and. compiler%is_gnu() .and. os_is_unix() .and. get_os_type()/=OS_MACOS) then + this%link_flags = string_t(' -Wl,--start-group '//this%link_flags%s) + end if + + ! Add language-specific flags + call set_language_flags(compiler,mpilib,fort_wrapper,this%has_fortran_flags,this%fflags,verbose,error) + if (allocated(error)) return + call set_language_flags(compiler,mpilib,c_wrapper,this%has_c_flags,this%cflags,verbose,error) + if (allocated(error)) return + call set_language_flags(compiler,mpilib,cxx_wrapper,this%has_cxx_flags,this%cxxflags,verbose,error) + if (allocated(error)) return + + ! Get library version + version = mpi_version_get(mpilib,fort_wrapper,error) + if (allocated(error)) then + return + else + allocate(this%version,source=version) + end if + + !> Add default run command, if present + this%run_command = mpi_wrapper_query(mpilib,fort_wrapper,'runner',verbose,runner_error) + this%has_run_command = (len_trim(this%run_command)>0) .and. .not.allocated(runner_error) + + contains + + subroutine set_language_flags(compiler,mpilib,wrapper,has_flags,flags,verbose,error) + type(compiler_t), intent(in) :: compiler + integer, intent(in) :: mpilib + type(string_t), intent(in) :: wrapper + logical, intent(inout) :: has_flags + type(string_t), intent(inout) :: flags + logical, intent(in) :: verbose + type(error_t), allocatable, intent(out) :: error + + ! Get build flags for each language + if (len_trim(wrapper)>0) then + flags = mpi_wrapper_query(mpilib,wrapper,'flags',verbose,error) + + if (allocated(error)) return + has_flags = len_trim(flags)>0 + + ! Add heading space + flags = string_t(' '//flags%s) + + if (verbose) print *, '+ MPI language flags from wrapper <',wrapper%s,'>: flags=',flags%s + + call filter_build_arguments(compiler,flags) + + endif + + end subroutine set_language_flags + +end subroutine init_mpi_from_wrappers + +!> Match one of the available compiler wrappers with the current compiler +subroutine mpi_compiler_match(language,wrappers,compiler,which_one,mpilib,error) + integer, intent(in) :: language + type(string_t), intent(in) :: wrappers(:) + type(compiler_t), intent(in) :: compiler + integer, intent(out) :: which_one, mpilib + type(error_t), allocatable, intent(out) :: error + + integer :: i, same_vendor, vendor_mpilib + type(string_t) :: screen + character(128) :: msg_out + type(compiler_t) :: mpi_compiler + + which_one = 0 + same_vendor = 0 + mpilib = MPI_TYPE_NONE + + if (verbose) print *, '+ Trying to match available ',LANG_NAME(language),' MPI wrappers to ',compiler%fc,'...' + + do i=1,size(wrappers) + + mpilib = which_mpi_library(wrappers(i),compiler,verbose=.false.) + + screen = mpi_wrapper_query(mpilib,wrappers(i),'compiler',verbose=.false.,error=error) + if (allocated(error)) return + + if (verbose) print *, ' Wrapper ',wrappers(i)%s,' lib=',MPI_TYPE_NAME(mpilib),' uses ',screen%s + + select case (language) + case (LANG_FORTRAN) + ! Build compiler type. The ID is created based on the Fortran name + call new_compiler(mpi_compiler,screen%s,'','',echo=.true.,verbose=.false.) + + ! Fortran match found! + if (mpi_compiler%id == compiler%id) then + which_one = i + return + end if + case (LANG_C) + ! For other languages, we can only hope that the name matches the expected one + if (screen%s==compiler%cc .or. screen%s==compiler%fc) then + which_one = i + return + end if + case (LANG_CXX) + if (screen%s==compiler%cxx .or. screen%s==compiler%fc) then + which_one = i + return + end if + end select + + ! Because the intel mpi library does not support llvm_ compiler wrappers yet, + ! we must check for that manually + if (is_intel_classic_option(language,same_vendor,screen,compiler,mpi_compiler)) then + same_vendor = i + vendor_mpilib = mpilib + end if + end do + + ! Intel compiler: if an exact match is not found, attempt closest wrapper + if (which_one==0 .and. same_vendor>0) then + which_one = same_vendor + mpilib = vendor_mpilib + end if + + ! None of the available wrappers matched the current Fortran compiler + write(msg_out,1) size(wrappers),compiler%fc + call fatal_error(error,trim(msg_out)) + 1 format(' None out of ',i0,' valid MPI wrappers matches compiler ',a) + +end subroutine mpi_compiler_match + +!> Because the Intel mpi library does not support llvm_ compiler wrappers yet, +!> we must save the Intel-classic option and later manually replace it +logical function is_intel_classic_option(language,same_vendor_ID,screen_out,compiler,mpi_compiler) + integer, intent(in) :: language,same_vendor_ID + type(string_t), intent(in) :: screen_out + type(compiler_t), intent(in) :: compiler,mpi_compiler + + if (same_vendor_ID/=0) then + is_intel_classic_option = .false. + else + select case (language) + case (LANG_FORTRAN) + is_intel_classic_option = mpi_compiler%is_intel() .and. compiler%is_intel() + case (LANG_C) + is_intel_classic_option = screen_out%s=='icc' .and. compiler%cc=='icx' + case (LANG_CXX) + is_intel_classic_option = screen_out%s=='icpc' .and. compiler%cc=='icpx' + end select + end if + +end function is_intel_classic_option + +!> Return library version from the MPI wrapper command +type(version_t) function mpi_version_get(mpilib,wrapper,error) + integer, intent(in) :: mpilib + type(string_t), intent(in) :: wrapper + type(error_t), allocatable, intent(out) :: error + + type(string_t) :: version_line + + ! Get version string + version_line = mpi_wrapper_query(mpilib,wrapper,'version',error=error) + if (allocated(error)) return + + ! Wrap to object + call new_version(mpi_version_get,version_line%s,error) + +end function mpi_version_get + +!> Return several mpi wrappers, and return +subroutine mpi_wrappers(compiler,fort_wrappers,c_wrappers,cpp_wrappers) + type(compiler_t), intent(in) :: compiler + type(string_t), allocatable, intent(out) :: c_wrappers(:),cpp_wrappers(:),fort_wrappers(:) + + character(len=:), allocatable :: mpi_root,intel_wrap + type(error_t), allocatable :: error + + ! Attempt gathering MPI wrapper names from the environment variables + c_wrappers = [string_t(get_env('MPICC' ,'mpicc'))] + cpp_wrappers = [string_t(get_env('MPICXX','mpic++'))] + fort_wrappers = [string_t(get_env('MPIFC' ,'mpifc' )),& + string_t(get_env('MPIf90','mpif90')),& + string_t(get_env('MPIf77','mpif77'))] + + if (get_os_type()==OS_WINDOWS) then + c_wrappers = [c_wrappers,string_t('mpicc.bat')] + cpp_wrappers = [cpp_wrappers,string_t('mpicxx.bat')] + fort_wrappers = [fort_wrappers,string_t('mpifc.bat')] + endif + + ! Add compiler-specific wrappers + compiler_specific: select case (compiler%id) + case (id_gcc,id_f95) + + c_wrappers = [c_wrappers,string_t('mpigcc'),string_t('mpgcc')] + cpp_wrappers = [cpp_wrappers,string_t('mpig++'),string_t('mpg++')] + fort_wrappers = [fort_wrappers,string_t('mpigfortran'),string_t('mpgfortran'),& + string_t('mpig77'),string_t('mpg77')] + + case (id_intel_classic_windows,id_intel_llvm_windows, & + id_intel_classic_nix,id_intel_classic_mac,id_intel_llvm_nix,id_intel_llvm_unknown) + + c_wrappers = [string_t(get_env('I_MPI_CC','mpiicc'))] + cpp_wrappers = [string_t(get_env('I_MPI_CXX','mpiicpc'))] + fort_wrappers = [string_t(get_env('I_MPI_F90','mpiifort'))] + + ! Also search MPI wrappers via the base MPI folder + mpi_root = get_env('I_MPI_ROOT') + if (mpi_root/="") then + + mpi_root = join_path(mpi_root,'bin') + + intel_wrap = join_path(mpi_root,'mpiifort') + if (get_os_type()==OS_WINDOWS) intel_wrap = get_dos_path(intel_wrap,error) + if (intel_wrap/="") fort_wrappers = [fort_wrappers,string_t(intel_wrap)] + + intel_wrap = join_path(mpi_root,'mpiicc') + if (get_os_type()==OS_WINDOWS) intel_wrap = get_dos_path(intel_wrap,error) + if (intel_wrap/="") c_wrappers = [c_wrappers,string_t(intel_wrap)] + + intel_wrap = join_path(mpi_root,'mpiicpc') + if (get_os_type()==OS_WINDOWS) intel_wrap = get_dos_path(intel_wrap,error) + if (intel_wrap/="") cpp_wrappers = [cpp_wrappers,string_t(intel_wrap)] + + end if + + case (id_pgi,id_nvhpc) + + c_wrappers = [c_wrappers,string_t('mpipgicc'),string_t('mpgcc')] + cpp_wrappers = [cpp_wrappers,string_t('mpipgic++')] + fort_wrappers = [fort_wrappers,string_t('mpipgifort'),string_t('mpipgf90')] + + case (id_cray) + + c_wrappers = [c_wrappers,string_t('cc')] + cpp_wrappers = [cpp_wrappers,string_t('CC')] + fort_wrappers = [fort_wrappers,string_t('ftn')] + + end select compiler_specific + + call assert_mpi_wrappers(fort_wrappers,compiler) + call assert_mpi_wrappers(c_wrappers,compiler) + call assert_mpi_wrappers(cpp_wrappers,compiler) + +end subroutine mpi_wrappers + +!> Filter out invalid/unavailable mpi wrappers +subroutine assert_mpi_wrappers(wrappers,compiler,verbose) + type(string_t), allocatable, intent(inout) :: wrappers(:) + type(compiler_t), intent(in) :: compiler + logical, optional, intent(in) :: verbose + + integer :: i + integer, allocatable :: works(:) + + allocate(works(size(wrappers))) + + do i=1,size(wrappers) + if (present(verbose)) then + if (verbose) print *, '+ MPI test wrapper <',wrappers(i)%s,'>' + endif + works(i) = which_mpi_library(wrappers(i),compiler,verbose) + end do + + ! Filter out non-working wrappers + wrappers = pack(wrappers,works/=MPI_TYPE_NONE) + +end subroutine assert_mpi_wrappers + +!> Get MPI library type from the wrapper command. Currently, only OpenMPI is supported +integer function which_mpi_library(wrapper,compiler,verbose) + type(string_t), intent(in) :: wrapper + type(compiler_t), intent(in) :: compiler + logical, intent(in), optional :: verbose + + logical :: is_mpi_wrapper + integer :: stat + + ! Init as currently unsupported library + which_mpi_library = MPI_TYPE_NONE + + if (len_trim(wrapper)<=0) return + + ! Run mpi wrapper first + call run_wrapper(wrapper,verbose=verbose,cmd_success=is_mpi_wrapper) + + if (is_mpi_wrapper) then + + if (compiler%is_intel()) then + which_mpi_library = MPI_TYPE_INTEL + return + end if + + ! Attempt to decipher which library this wrapper comes from. + + ! OpenMPI responds to '--showme' calls + call run_wrapper(wrapper,[string_t('--showme')],verbose,& + exitcode=stat,cmd_success=is_mpi_wrapper) + if (stat==0 .and. is_mpi_wrapper) then + which_mpi_library = MPI_TYPE_OPENMPI + return + endif + + ! MPICH responds to '-show' calls + call run_wrapper(wrapper,[string_t('-show')],verbose,& + exitcode=stat,cmd_success=is_mpi_wrapper) + if (stat==0 .and. is_mpi_wrapper) then + which_mpi_library = MPI_TYPE_MPICH + return + endif + + end if + +end function which_mpi_library + +!> Test if an MPI wrapper works +type(string_t) function mpi_wrapper_query(mpilib,wrapper,command,verbose,error) result(screen) + integer, intent(in) :: mpilib + type(string_t), intent(in) :: wrapper + character(*), intent(in) :: command + logical, intent(in), optional :: verbose + type(error_t), allocatable, intent(out) :: error + + logical :: success + character(:), allocatable :: redirect_str,tokens(:),unsupported_msg + type(string_t) :: cmdstr + type(compiler_t) :: mpi_compiler + integer :: stat,cmdstat,ire,length + + unsupported_msg = 'the MPI library of wrapper '//wrapper%s//' does not support task '//trim(command) + + select case (command) + + ! Get MPI compiler name + case ('compiler') + + select case (mpilib) + case (MPI_TYPE_OPENMPI); cmdstr = string_t('--showme:command') + case (MPI_TYPE_MPICH); cmdstr = string_t('-compile-info') + case (MPI_TYPE_INTEL); cmdstr = string_t('-show') + case default + call fatal_error(error,unsupported_msg) + return + end select + + call run_wrapper(wrapper,[cmdstr],verbose=verbose, & + exitcode=stat,cmd_success=success,screen_output=screen) + + if (stat/=0 .or. .not.success) then + call syntax_error(error,'local '//MPI_TYPE_NAME(mpilib)//& + ' library wrapper does not support flag '//cmdstr%s) + return + end if + + ! Take out the first command from the whole line + call remove_newline_characters(screen) + call split(screen%s,tokens,delimiters=' ') + screen%s = trim(adjustl(tokens(1))) + + ! Get a list of additional compiler flags + case ('flags') + + select case (mpilib) + case (MPI_TYPE_OPENMPI); cmdstr = string_t('--showme:compile') + case (MPI_TYPE_MPICH); cmdstr = string_t('-compile-info') + case (MPI_TYPE_INTEL); cmdstr = string_t('-show') + case default + call fatal_error(error,unsupported_msg) + return + end select + + call run_wrapper(wrapper,[cmdstr],verbose=verbose, & + exitcode=stat,cmd_success=success,screen_output=screen) + + if (stat/=0 .or. .not.success) then + call syntax_error(error,'local '//MPI_TYPE_NAME(mpilib)//& + ' library wrapper does not support flag '//cmdstr%s) + return + end if + + ! Post-process output + select case (mpilib) + case (MPI_TYPE_OPENMPI) + ! This library reports the compiler name only + call remove_newline_characters(screen) + case (MPI_TYPE_MPICH,MPI_TYPE_INTEL) + ! These libraries report the full command including the compiler name. Remove it if so + call remove_newline_characters(screen) + call split(screen%s,tokens) + ! Remove trailing compiler name + screen%s = screen%s(len_trim(tokens(1))+1:) + case default + call fatal_error(error,'invalid MPI library type') + return + end select + + ! Get a list of additional linker flags + case ('link') + + select case (mpilib) + case (MPI_TYPE_OPENMPI); cmdstr = string_t('--showme:link') + case (MPI_TYPE_MPICH); cmdstr = string_t('-link-info') + case (MPI_TYPE_INTEL); cmdstr = string_t('-show') + case default + call fatal_error(error,unsupported_msg) + return + end select + + call run_wrapper(wrapper,[cmdstr],verbose=verbose, & + exitcode=stat,cmd_success=success,screen_output=screen) + + if (stat/=0 .or. .not.success) then + call syntax_error(error,'local '//MPI_TYPE_NAME(mpilib)//& + ' library wrapper does not support flag '//cmdstr%s) + return + end if + + select case (mpilib) + case (MPI_TYPE_OPENMPI) + call remove_newline_characters(screen) + case (MPI_TYPE_MPICH,MPI_TYPE_INTEL) + ! MPICH reports the full command including the compiler name. Remove it if so + call remove_newline_characters(screen) + call split(screen%s,tokens) + ! Remove trailing compiler name + screen%s = screen%s(len_trim(tokens(1))+1:) + case default + call fatal_error(error,unsupported_msg) + return + end select + + ! Get a list of MPI library directories + case ('link_dirs') + + select case (mpilib) + case (MPI_TYPE_OPENMPI) + + ! --showme:command returns the build command of this wrapper + call run_wrapper(wrapper,[string_t('--showme:libdirs')],verbose=verbose, & + exitcode=stat,cmd_success=success,screen_output=screen) + + if (stat/=0 .or. .not.success) then + call syntax_error(error,'local OpenMPI library does not support --showme:libdirs') + return + end if + + case default + + call fatal_error(error,unsupported_msg) + return + + end select + + ! Get a list of include directories for the MPI headers/modules + case ('incl_dirs') + + select case (mpilib) + case (MPI_TYPE_OPENMPI) + ! --showme:command returns the build command of this wrapper + call run_wrapper(wrapper,[string_t('--showme:incdirs')],verbose=verbose, & + exitcode=stat,cmd_success=success,screen_output=screen) + if (stat/=0 .or. .not.success) then + call syntax_error(error,'local OpenMPI library does not support --showme:incdirs') + return + end if + case default + call fatal_error(error,unsupported_msg) + return + end select + + call remove_newline_characters(screen) + + ! Retrieve library version + case ('version') + + select case (mpilib) + case (MPI_TYPE_OPENMPI) + + ! --showme:command returns the build command of this wrapper + call run_wrapper(wrapper,[string_t('--showme:version')],verbose=verbose, & + exitcode=stat,cmd_success=success,screen_output=screen) + + if (stat/=0 .or. .not.success) then + call syntax_error(error,'local OpenMPI library does not support --showme:version') + return + else + call remove_newline_characters(screen) + end if + + case (MPI_TYPE_MPICH) + + !> MPICH offers command "mpichversion" in the same system folder as the MPI wrappers. + !> So, attempt to run that first + cmdstr = string_t('mpichversion') + call run_wrapper(cmdstr,verbose=verbose, & + exitcode=stat,cmd_success=success,screen_output=screen) + + ! Second option: run mpich wrapper + "-v" + if (stat/=0 .or. .not.success) then + call run_wrapper(wrapper,[string_t('-v')],verbose=verbose, & + exitcode=stat,cmd_success=success,screen_output=screen) + call remove_newline_characters(screen) + endif + + ! Third option: mpiexec --version + if (stat/=0 .or. .not.success) then + cmdstr = string_t('mpiexec --version') + call run_wrapper(cmdstr,verbose=verbose, & + exitcode=stat,cmd_success=success,screen_output=screen) + endif + + if (stat/=0 .or. .not.success) then + call syntax_error(error,'cannot retrieve MPICH library version from ') + return + end if + + case (MPI_TYPE_INTEL) + + ! --showme:command returns the build command of this wrapper + call run_wrapper(wrapper,[string_t('-v')],verbose=verbose, & + exitcode=stat,cmd_success=success,screen_output=screen) + + if (stat/=0 .or. .not.success) then + call syntax_error(error,'local INTEL MPI library does not support -v') + return + else + call remove_newline_characters(screen) + end if + + case default + + call fatal_error(error,unsupported_msg) + return + + end select + + ! Extract version + screen = regex_version_from_text(screen%s,MPI_TYPE_NAME(mpilib)//' library',error) + if (allocated(error)) return + + ! Get path to the MPI runner command + case ('runner') + + select case (mpilib) + case (MPI_TYPE_OPENMPI,MPI_TYPE_MPICH,MPI_TYPE_MSMPI,MPI_TYPE_INTEL) + call get_mpi_runner(screen,verbose,error) + case default + call fatal_error(error,unsupported_msg) + return + end select + + case default; + call fatal_error(error,'an invalid MPI wrapper command ('//command//& + ') was invoked for wrapper <'//wrapper%s//'>.') + return + end select + +end function mpi_wrapper_query + +!> Check if input is a useful linker argument +logical function is_link_argument(compiler,string) + type(compiler_t), intent(in) :: compiler + character(*), intent(in) :: string + + select case (compiler%id) + case (id_intel_classic_windows,id_intel_llvm_windows) + is_link_argument = string=='/link' & + .or. str_begins_with_str(string,'/LIBPATH')& + .or. str_ends_with(string,'.lib') ! always .lib whether static or dynamic + case default + + ! fix OpenMPI's Fortran wrapper bug (https://github.com/open-mpi/ompi/issues/11636) here + is_link_argument = ( str_begins_with_str(string,'-L') & + .or. str_begins_with_str(string,'-l') & + .or. str_begins_with_str(string,'-Xlinker') & + .or. string=='-pthread' & + .or. (str_begins_with_str(string,'-W') .and. & + (string/='-Wall') .and. (.not.str_begins_with_str(string,'-Werror'))) ) & + .and. .not. ( & + (get_os_type()==OS_MACOS .and. index(string,'-commons,use_dylibs')>0) ) + end select + +end function is_link_argument + +!> From build, remove optimization and other unnecessary flags +subroutine filter_build_arguments(compiler,command) + type(compiler_t), intent(in) :: compiler + type(string_t), intent(inout) :: command + character(len=:), allocatable :: tokens(:) + + integer :: i,n,re_i,re_l + logical, allocatable :: keep(:) + logical :: keep_next + character(len=:), allocatable :: module_flag,include_flag + + if (len_trim(command)<=0) return + + ! Split command into arguments + tokens = shlex_split(command%s) + + module_flag = get_module_flag(compiler,"") + include_flag = get_include_flag(compiler,"") + + n = size(tokens) + allocate(keep(n),source=.false.) + keep_next = .false. + + do i=1,n + + if (get_os_type()==OS_MACOS .and. index(tokens(i),'-commons,use_dylibs')>0) then + keep(i) = .false. + keep_next = .false. + elseif (str_begins_with_str(tokens(i),'-D') .or. & + str_begins_with_str(tokens(i),'-f') .or. & + str_begins_with_str(tokens(i),'-I') .or. & + str_begins_with_str(tokens(i),module_flag) .or. & + str_begins_with_str(tokens(i),include_flag) .or. & + tokens(i)=='-pthread' .or. & + (str_begins_with_str(tokens(i),'-W') .and. tokens(i)/='-Wall' .and. .not.str_begins_with_str(tokens(i),'-Werror')) & + ) then + keep(i) = .true. + if (tokens(i)==module_flag .or. tokens(i)==include_flag .or. tokens(i)=='-I') keep_next = .true. + elseif (keep_next) then + keep(i) = .true. + keep_next = .false. + end if + end do + + ! Backfill + command = string_t("") + do i=1,n + if (.not.keep(i)) cycle + + command%s = command%s//' '//trim(tokens(i)) + end do + +end subroutine filter_build_arguments + +!> From the linker flags, remove optimization and other unnecessary flags +subroutine filter_link_arguments(compiler,command) + type(compiler_t), intent(in) :: compiler + type(string_t), intent(inout) :: command + character(len=:), allocatable :: tokens(:) + + integer :: i,n + logical, allocatable :: keep(:) + logical :: keep_next + + if (len_trim(command)<=0) return + + ! Split command into arguments + tokens = shlex_split(command%s) + + n = size(tokens) + allocate(keep(n),source=.false.) + keep_next = .false. + + do i=1,n + if (is_link_argument(compiler,tokens(i))) then + keep(i) = .true. + if (tokens(i)=='-L' .or. tokens(i)=='-Xlinker') keep_next = .true. + elseif (keep_next) then + keep(i) = .true. + keep_next = .false. + end if + end do + + ! Backfill + command = string_t("") + do i=1,n + if (.not.keep(i)) cycle + command%s = command%s//' '//trim(tokens(i)) + end do + +end subroutine filter_link_arguments + +!> 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' + find_package: do i=1,size(candidates) + if (pkgcfg_has_package(trim(candidates(i)))) then + name = trim(candidates(i)) + exit find_package + end if + end do find_package + + !> some distros put hdf5-1.2.3.pc with version number in .pc filename. + if (name=='NOT_FOUND') then + modules = pkgcfg_list_all(error) + find_global_package: do i=1,size(modules) + if (str_begins_with_str(modules(i)%s,'hdf5')) then + name = modules(i)%s + exit find_global_package + end if + end do find_global_package + end if + + if (name=='NOT_FOUND') then + call fatal_error(error,'pkg-config could not find a suitable hdf5 package.') + return + end if + + !> 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:))] + + 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 + + end if + 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) + if (str_begins_with_str(this%link_libs(j)%s,this%link_libs(i)%s) .and. & + str_ends_with(this%link_libs(j)%s,trim(find_hl(k)))) then + found_hl(k) = .true. + cycle finals + end if + end do + end do finals + + ! For each of the missing ones, if there is a file, add it + add_missing: do k=1,size(find_hl) + if (found_hl(k)) cycle add_missing + + ! Build file name + this_lib%s = join_path(libdir,pref//this%link_libs(i)%s//trim(find_hl(k))//ext) + inquire(file=this_lib%s,exist=found) + + ! File exists, but it is not linked against + if (found) 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 + + !> 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 + +!>>>>> ././src/fpm_source_parsing.f90 + +!># Parsing of package source files +!> +!> This module exposes two functions, `[[parse_f_source]]` and `[[parse_c_source]]`, +!> which perform a rudimentary parsing of fortran and c source files +!> in order to extract information required for module dependency tracking. +!> +!> Both functions additionally calculate and store a file digest (hash) which +!> is used by the backend ([[fpm_backend]]) to skip compilation of unmodified sources. +!> +!> Both functions return an instance of the [[srcfile_t]] type. +!> +!> For more information, please read the documentation for each function: +!> +!> - `[[parse_f_source]]` +!> - `[[parse_c_source]]` +!> +module fpm_source_parsing +use fpm_error, only: error_t, file_parse_error, fatal_error, file_not_found_error +use fpm_strings, only: string_t, string_cat, len_trim, split, lower, str_ends_with, fnv_1a, is_fortran_name +use fpm_model, only: srcfile_t, & + FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, & + FPM_UNIT_CSOURCE, FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, & + FPM_SCOPE_LIB, FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST, & + FPM_UNIT_CPPSOURCE +use fpm_filesystem, only: read_lines, read_lines_expanded, exists +implicit none + +private +public :: parse_f_source, parse_c_source, parse_use_statement + +contains + +!> Parsing of free-form fortran source files +!> +!> The following statements are recognised and parsed: +!> +!> - `Module`/`submodule`/`program` declaration +!> - Module `use` statement +!> - `include` statement +!> +!> @note Intrinsic modules used by sources are not listed in +!> the `modules_used` field of source objects. +!> +!> @note Submodules are treated as normal modules which `use` their +!> corresponding parent modules. +!> +!>### Parsing limitations +!> +!> __Statements must not continued onto another line +!> except for an `only:` list in the `use` statement.__ +!> +!> This is supported: +!> +!>```fortran +!> use my_module, only: & +!> my_var, my_function, my_subroutine +!>``` +!> +!> This is __NOT supported:__ +!> +!>```fortran +!> use & +!> my_module +!>``` +!> +function parse_f_source(f_filename,error) result(f_source) + character(*), intent(in) :: f_filename + type(srcfile_t) :: f_source + type(error_t), allocatable, intent(out) :: error + + logical :: inside_module, inside_interface, using, intrinsic_module + integer :: stat + integer :: fh, n_use, n_include, n_mod, n_parent, i, j, ic, pass + type(string_t), allocatable :: file_lines(:), file_lines_lower(:) + character(:), allocatable :: temp_string, mod_name, string_parts(:) + + if (.not. exists(f_filename)) then + call file_not_found_error(error, f_filename) + return + end if + + f_source%file_name = f_filename + + file_lines = read_lines_expanded(f_filename) + + ! for efficiency in parsing make a lowercase left-adjusted copy of the file + ! Need a copy because INCLUDE (and #include) file arguments are case-sensitive + file_lines_lower=file_lines + do i=1,size(file_lines_lower) + file_lines_lower(i)%s=adjustl(lower(file_lines_lower(i)%s)) + enddo + + ! fnv_1a can only be applied to non-zero-length arrays + if (len_trim(file_lines_lower) > 0) f_source%digest = fnv_1a(file_lines) + + do pass = 1,2 + n_use = 0 + n_include = 0 + n_mod = 0 + n_parent = 0 + inside_module = .false. + inside_interface = .false. + file_loop: do i=1,size(file_lines_lower) + + ! Skip comment lines and preprocessor directives + if (index(file_lines_lower(i)%s,'!') == 1 .or. & + index(file_lines_lower(i)%s,'#') == 1 .or. & + len_trim(file_lines_lower(i)%s) < 1) then + cycle + end if + + ! Detect exported C-API via bind(C) + if (.not.inside_interface .and. & + parse_subsequence(file_lines_lower(i)%s,'bind','(','c')) then + + do j=i,1,-1 + + if (index(file_lines_lower(j)%s,'function') > 0 .or. & + index(file_lines_lower(j)%s,'subroutine') > 0) then + f_source%unit_type = FPM_UNIT_SUBPROGRAM + exit + end if + + if (j>1) then + + ic = index(file_lines_lower(j-1)%s,'!') + if (ic < 1) then + ic = len(file_lines_lower(j-1)%s) + end if + + temp_string = trim(file_lines_lower(j-1)%s(1:ic)) + if (index(temp_string,'&') /= len(temp_string)) then + exit + end if + + end if + + end do + + end if + + ! Skip lines that are continued: not statements + if (i > 1) then + ic = index(file_lines_lower(i-1)%s,'!') + if (ic < 1) then + ic = len(file_lines_lower(i-1)%s) + end if + temp_string = trim(file_lines_lower(i-1)%s(1:ic)) + if (len(temp_string) > 0 .and. index(temp_string,'&') == len(temp_string)) then + cycle + end if + end if + + ! Detect beginning of interface block + if (index(file_lines_lower(i)%s,'interface') == 1 & + .or. parse_sequence(file_lines_lower(i)%s,'abstract','interface')) then + + inside_interface = .true. + cycle + + end if + + ! Detect end of interface block + if (parse_sequence(file_lines_lower(i)%s,'end','interface')) then + + inside_interface = .false. + cycle + + end if + + ! Process 'USE' statements + call parse_use_statement(f_filename,i,file_lines_lower(i)%s,using,intrinsic_module,mod_name,error) + if (allocated(error)) return + + if (using) then + + ! Not a valid module name? + if (.not.is_fortran_name(mod_name)) cycle + + ! Valid intrinsic module: not a dependency + if (intrinsic_module) cycle + + n_use = n_use + 1 + + if (pass == 2) f_source%modules_used(n_use)%s = mod_name + + cycle + + endif + + ! Process 'INCLUDE' statements + ic = index(file_lines_lower(i)%s,'include') + if ( ic == 1 ) then + ic = index(lower(file_lines(i)%s),'include') + if (index(adjustl(file_lines(i)%s(ic+7:)),'"') == 1 .or. & + index(adjustl(file_lines(i)%s(ic+7:)),"'") == 1 ) then + + n_include = n_include + 1 + + if (pass == 2) then + f_source%include_dependencies(n_include)%s = & + & split_n(file_lines(i)%s,n=2,delims="'"//'"',stat=stat) + if (stat /= 0) then + call file_parse_error(error,f_filename, & + 'unable to find include file name',i, & + file_lines(i)%s) + return + end if + end if + + cycle + + end if + end if + + ! Extract name of module if is module + if (index(file_lines_lower(i)%s,'module ') == 1) then + + ! Remove any trailing comments + ic = index(file_lines_lower(i)%s,'!')-1 + if (ic < 1) then + ic = len(file_lines_lower(i)%s) + end if + temp_string = trim(file_lines_lower(i)%s(1:ic)) + + ! R1405 module-stmt := "MODULE" module-name + ! module-stmt has two space-delimited parts only + ! (no line continuations) + call split(temp_string,string_parts,' ') + if (size(string_parts) /= 2) then + cycle + end if + + mod_name = trim(adjustl(string_parts(2))) + if (scan(mod_name,'=(&')>0 ) then + ! Ignore these cases: + ! module & + ! module =* + ! module (i) + cycle + end if + + if (.not.is_fortran_name(mod_name)) then + call file_parse_error(error,f_filename, & + 'empty or invalid name for module',i, & + file_lines_lower(i)%s, index(file_lines_lower(i)%s,mod_name)) + return + end if + + n_mod = n_mod + 1 + + if (pass == 2) then + f_source%modules_provided(n_mod) = string_t(mod_name) + end if + + if (f_source%unit_type == FPM_UNIT_UNKNOWN) then + f_source%unit_type = FPM_UNIT_MODULE + end if + + if (.not.inside_module) then + inside_module = .true. + else + ! Must have missed an end module statement (can't assume a pure module) + if (f_source%unit_type /= FPM_UNIT_PROGRAM) then + f_source%unit_type = FPM_UNIT_SUBPROGRAM + end if + end if + + cycle + + end if + + ! Extract name of submodule if is submodule + if (index(file_lines_lower(i)%s,'submodule') == 1) then + + mod_name = split_n(file_lines_lower(i)%s,n=3,delims='()',stat=stat) + if (stat /= 0) then + call file_parse_error(error,f_filename, & + 'unable to get submodule name',i, & + file_lines_lower(i)%s) + return + end if + if (.not.is_fortran_name(mod_name)) then + call file_parse_error(error,f_filename, & + 'empty or invalid name for submodule',i, & + file_lines_lower(i)%s, index(file_lines_lower(i)%s,mod_name)) + return + end if + + n_mod = n_mod + 1 + + temp_string = split_n(file_lines_lower(i)%s,n=2,delims='()',stat=stat) + if (stat /= 0) then + call file_parse_error(error,f_filename, & + 'unable to get submodule ancestry',i, & + file_lines_lower(i)%s) + return + end if + + if (f_source%unit_type /= FPM_UNIT_PROGRAM) then + f_source%unit_type = FPM_UNIT_SUBMODULE + end if + + n_use = n_use + 1 + + inside_module = .true. + + n_parent = n_parent + 1 + + if (pass == 2) then + + if (index(temp_string,':') > 0) then + + temp_string = temp_string(index(temp_string,':')+1:) + + end if + + if (.not.is_fortran_name(temp_string)) then + call file_parse_error(error,f_filename, & + 'empty or invalid name for submodule parent',i, & + file_lines_lower(i)%s, index(file_lines_lower(i)%s,temp_string)) + return + end if + + f_source%modules_used(n_use)%s = temp_string + f_source%parent_modules(n_parent)%s = temp_string + f_source%modules_provided(n_mod)%s = mod_name + + end if + + cycle + + end if + + ! Detect if contains a program + ! - no modules allowed after program def + ! - program header may be missing (only "end program" statement present) + if (index(file_lines_lower(i)%s,'program ')==1 .or. & + parse_sequence(file_lines_lower(i)%s,'end','program')) then + + temp_string = split_n(file_lines_lower(i)%s,n=2,delims=' ',stat=stat) + if (stat == 0) then + + if (scan(temp_string,'=(')>0 ) then + ! Ignore: + ! program =* + ! program (i) =* + cycle + end if + + end if + + f_source%unit_type = FPM_UNIT_PROGRAM + + cycle + + end if + + ! Parse end module statement + ! (to check for code outside of modules) + if (parse_sequence(file_lines_lower(i)%s,'end','module') .or. & + parse_sequence(file_lines_lower(i)%s,'end','submodule')) then + + inside_module = .false. + cycle + + end if + + ! Any statements not yet parsed are assumed to be other code statements + if (.not.inside_module .and. f_source%unit_type /= FPM_UNIT_PROGRAM) then + + f_source%unit_type = FPM_UNIT_SUBPROGRAM + + end if + + end do file_loop + + ! If unable to parse end of module statement, then can't assume pure module + ! (there could be non-module subprograms present) + if (inside_module .and. f_source%unit_type == FPM_UNIT_MODULE) then + f_source%unit_type = FPM_UNIT_SUBPROGRAM + end if + + if (pass == 1) then + allocate(f_source%modules_used(n_use)) + allocate(f_source%include_dependencies(n_include)) + allocate(f_source%modules_provided(n_mod)) + allocate(f_source%parent_modules(n_parent)) + end if + + end do + +end function parse_f_source + +!> Parsing of c, cpp source files +!> +!> The following statements are recognised and parsed: +!> +!> - `#include` preprocessor statement +!> +function parse_c_source(c_filename,error) result(c_source) + character(*), intent(in) :: c_filename + type(srcfile_t) :: c_source + type(error_t), allocatable, intent(out) :: error + + integer :: fh, n_include, i, pass, stat + type(string_t), allocatable :: file_lines(:) + + c_source%file_name = c_filename + + if (str_ends_with(lower(c_filename), ".c")) then + + c_source%unit_type = FPM_UNIT_CSOURCE + + else if (str_ends_with(lower(c_filename), ".h")) then + + c_source%unit_type = FPM_UNIT_CHEADER + + else if (str_ends_with(lower(c_filename), ".cpp")) then + + c_source%unit_type = FPM_UNIT_CPPSOURCE + + end if + + allocate(c_source%modules_used(0)) + allocate(c_source%modules_provided(0)) + allocate(c_source%parent_modules(0)) + + file_lines = read_lines(c_filename) + + ! Ignore empty files, returned as FPM_UNIT_UNKNOWN + if (len_trim(file_lines) < 1) then + c_source%unit_type = FPM_UNIT_UNKNOWN + return + end if + + c_source%digest = fnv_1a(file_lines) + + do pass = 1,2 + n_include = 0 + file_loop: do i=1,size(file_lines) + + ! Process 'INCLUDE' statements + if (index(adjustl(lower(file_lines(i)%s)),'#include') == 1 .and. & + index(file_lines(i)%s,'"') > 0) then + + n_include = n_include + 1 + + if (pass == 2) then + + c_source%include_dependencies(n_include)%s = & + & split_n(file_lines(i)%s,n=2,delims='"',stat=stat) + if (stat /= 0) then + call file_parse_error(error,c_filename, & + 'unable to get c include file',i, & + file_lines(i)%s,index(file_lines(i)%s,'"')) + return + end if + + end if + + end if + + end do file_loop + + if (pass == 1) then + allocate(c_source%include_dependencies(n_include)) + end if + + end do + +end function parse_c_source + +!> Split a string on one or more delimeters +!> and return the nth substring if it exists +!> +!> n=0 will return the last item +!> n=-1 will return the penultimate item etc. +!> +!> stat = 1 on return if the index +!> is not found +!> +function split_n(string,delims,n,stat) result(substring) + + character(*), intent(in) :: string + character(*), intent(in) :: delims + integer, intent(in) :: n + integer, intent(out) :: stat + character(:), allocatable :: substring + + integer :: i + character(:), allocatable :: string_parts(:) + + call split(string,string_parts,delims) + + if (n<1) then + i = size(string_parts) + n + if (i < 1) then + allocate(character(len=0) :: substring) ! ifort bus error otherwise + stat = 1 + return + end if + else + i = n + end if + + if (i>size(string_parts)) then + allocate(character(len=0) :: substring) ! ifort bus error otherwise + stat = 1 + return + end if + + substring = trim(adjustl(string_parts(i))) + stat = 0 + +end function split_n + +!> Parse a subsequence of blank-separated tokens within a string +!> (see parse_sequence) +function parse_subsequence(string,t1,t2,t3,t4) result(found) + character(*), intent(in) :: string + character(*), intent(in) :: t1 + character(*), intent(in), optional :: t2, t3, t4 + logical :: found + + integer :: offset, i + + found = .false. + offset = 1 + + do + + i = index(string(offset:),t1) + + if (i == 0) return + + offset = offset + i - 1 + + found = parse_sequence(string(offset:),t1,t2,t3,t4) + + if (found) return + + offset = offset + len(t1) + + if (offset > len(string)) return + + end do + +end function parse_subsequence + +!> Helper utility to parse sequences of tokens +!> that may be optionally separated by zero or more spaces +function parse_sequence(string,t1,t2,t3,t4) result(found) + character(*), intent(in) :: string + character(*), intent(in) :: t1 + character(*), intent(in), optional :: t2, t3, t4 + logical :: found + + integer :: post, n, incr, pos, token_n + logical :: match + + n = len(string) + found = .false. + pos = 1 + + do token_n=1,4 + + do while (pos <= n) + if (string(pos:pos) /= ' ') then + exit + end if + pos = pos + 1 + end do + + select case(token_n) + case(1) + incr = len(t1) + if (pos+incr-1>n) return + match = string(pos:pos+incr-1) == t1 + case(2) + if (.not.present(t2)) exit + incr = len(t2) + if (pos+incr-1>n) return + match = string(pos:pos+incr-1) == t2 + case(3) + if (.not.present(t3)) exit + incr = len(t3) + if (pos+incr-1>n) return + match = string(pos:pos+incr-1) == t3 + case(4) + if (.not.present(t4)) exit + incr = len(t4) + if (pos+incr-1>n) return + match = string(pos:pos+incr-1) == t4 + case default + exit + end select + + if (.not.match) then + return + end if + + pos = pos + incr + + end do + + found = .true. + +end function parse_sequence + +! USE [, intrinsic] :: module_name [, only: only_list] +! USE [, non_intrinsic] :: module_name [, only: only_list] +subroutine parse_use_statement(f_filename,i,line,use_stmt,is_intrinsic,module_name,error) + + !> Current file name and line number (for error messaging) + character(*), intent(in) :: f_filename + integer, intent(in) :: i + + !> The line being parsed. MUST BE preprocessed with trim(adjustl() + character(*), intent(in) :: line + + !> Does this line contain a `use` statement? + logical, intent(out) :: use_stmt + + !> Is the module in this statement intrinsic? + logical, intent(out) :: is_intrinsic + + !> used module name + character(:), allocatable, intent(out) :: module_name + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(15), parameter :: INTRINSIC_NAMES(*) = & + ['iso_c_binding ', & + 'iso_fortran_env', & + 'ieee_arithmetic', & + 'ieee_exceptions', & + 'ieee_features ', & + 'omp_lib '] + + character(len=:), allocatable :: temp_string + integer :: colons,intr,nonintr,j,stat + logical :: has_intrinsic_name + + use_stmt = .false. + is_intrinsic = .false. + if (len_trim(line)<=0) return + + ! Quick check that the line is preprocessed + if (line(1:1)==' ') then + call fatal_error(error,'internal_error: source file line is not trim(adjustl()) on input to parse_use_statement') + return + end if + + ! 'use' should be the first string in the adjustl line + use_stmt = index(line,'use ')==1 .or. index(line,'use::')==1 .or. index(line,'use,')==1 + if (.not.use_stmt) return + colons = index(line,'::') + nonintr = 0 + intr = 0 + + have_colons: if (colons>3) then + + ! there may be an intrinsic/non-intrinsic spec + nonintr = index(line(1:colons-1),'non_intrinsic') + if (nonintr==0) intr = index(line(1:colons-1),'intrinsic') + + temp_string = split_n(line,delims=':',n=2,stat=stat) + if (stat /= 0) then + call file_parse_error(error,f_filename, & + 'unable to find used module name',i, & + line,colons) + return + end if + + module_name = split_n(temp_string,delims=' ,',n=1,stat=stat) + if (stat /= 0) then + call file_parse_error(error,f_filename, & + 'unable to find used module name',i, & + line) + return + end if + + else + + module_name = split_n(line,n=2,delims=' ,',stat=stat) + if (stat /= 0) then + call file_parse_error(error,f_filename, & + 'unable to find used module name',i, & + line) + return + end if + + end if have_colons + + ! If declared intrinsic, check that it is true + has_intrinsic_name = any([(index(module_name,trim(INTRINSIC_NAMES(j)))>0, & + j=1,size(INTRINSIC_NAMES))]) + if (intr>0 .and. .not.has_intrinsic_name) then + + ! An intrinsic module was not found. Its name could be in the next line, + ! in which case, we just skip this check. The compiler will do the job if the name is invalid. + + ! Module name was not read: it's in the next line + if (index(module_name,'&')<=0) then + call file_parse_error(error,f_filename, & + 'module '//module_name//' is declared intrinsic but it is not ',i, & + line) + return + endif + endif + + ! Should we treat this as an intrinsic module + is_intrinsic = nonintr==0 .and. & ! not declared non-intrinsic + (intr>0 .or. has_intrinsic_name) + +end subroutine parse_use_statement + +end module fpm_source_parsing + +!>>>>> ././src/fpm_sources.f90 + +!># Discovery of sources +!> +!> This module implements subroutines for building a list of +!> `[[srcfile_t]]` objects by looking for source files in the filesystem. +!> +module fpm_sources +use fpm_error, only: error_t +use fpm_model, only: srcfile_t, FPM_UNIT_PROGRAM +use fpm_filesystem, only: basename, canon_path, dirname, join_path, list_files, is_hidden_file +use fpm_environment, only: get_os_type,OS_WINDOWS +use fpm_strings, only: lower, str_ends_with, string_t, operator(.in.) +use fpm_source_parsing, only: parse_f_source, parse_c_source +use fpm_manifest_executable, only: executable_config_t +implicit none + +private +public :: add_sources_from_dir, add_executable_sources +public :: get_exe_name_with_suffix + +character(4), parameter :: fortran_suffixes(2) = [".f90", & + ".f "] +character(4), parameter :: c_suffixes(4) = [".c ", ".h ", ".cpp", ".hpp"] + +contains + +!> Wrapper to source parsing routines. +!> Selects parsing routine based on source file name extension +function parse_source(source_file_path,custom_f_ext,error) result(source) + character(*), intent(in) :: source_file_path + type(string_t), optional, intent(in) :: custom_f_ext(:) + type(error_t), allocatable, intent(out) :: error + type(srcfile_t) :: source + type(string_t), allocatable :: f_ext(:) + + call list_fortran_suffixes(f_ext,custom_f_ext) + + if (str_ends_with(lower(source_file_path), f_ext)) then + + source = parse_f_source(source_file_path, error) + + if (source%unit_type == FPM_UNIT_PROGRAM) then + source%exe_name = basename(source_file_path,suffix=.false.) + end if + + else if (str_ends_with(lower(source_file_path), c_suffixes)) then + + source = parse_c_source(source_file_path,error) + + endif + + if (allocated(error)) then + return + end if + +end function parse_source + +!> List fortran suffixes, including optional ones +subroutine list_fortran_suffixes(suffixes,with_f_ext) + type(string_t), allocatable, intent(out) :: suffixes(:) + !> Additional user-defined (preprocessor) extensions that should be treated as Fortran sources + type(string_t), intent(in), optional :: with_f_ext(:) + + integer :: ndefault,nuser,i + + ndefault = size(fortran_suffixes) + nuser = 0; if (present(with_f_ext)) nuser = size(with_f_ext) + + allocate(suffixes(ndefault + nuser)) + do i=1,ndefault + suffixes(i) = string_t(fortran_suffixes(i)) + end do + if (present(with_f_ext)) then + do i=1,nuser + suffixes(ndefault+i) = string_t(with_f_ext(i)%s) + end do + endif + +end subroutine list_fortran_suffixes + +!> Add to `sources` by looking for source files in `directory` +subroutine add_sources_from_dir(sources,directory,scope,with_executables,with_f_ext,recurse,error) + !> List of `[[srcfile_t]]` objects to append to. Allocated if not allocated + type(srcfile_t), allocatable, intent(inout), target :: sources(:) + !> Directory in which to search for source files + character(*), intent(in) :: directory + !> Scope to apply to the discovered sources, see [[fpm_model]] for enumeration + integer, intent(in) :: scope + !> Executable sources (fortran `program`s) are ignored unless `with_executables=.true.` + logical, intent(in), optional :: with_executables + !> Additional user-defined (preprocessor) extensions that should be treated as Fortran sources + type(string_t), intent(in), optional :: with_f_ext(:) + !> Whether to recursively search subdirectories, default is `.true.` + logical, intent(in), optional :: recurse + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: i + logical, allocatable :: is_source(:), exclude_source(:) + logical :: recurse_ + type(string_t), allocatable :: file_names(:) + type(string_t), allocatable :: src_file_names(:),f_ext(:) + type(string_t), allocatable :: existing_src_files(:) + type(srcfile_t), allocatable :: dir_sources(:) + + recurse_ = .true. + if (present(recurse)) recurse_ = recurse + ! Scan directory for sources + call list_files(directory, file_names,recurse=recurse_) + + if (allocated(sources)) then + allocate(existing_src_files(size(sources))) + do i=1,size(sources) + existing_src_files(i)%s = canon_path(sources(i)%file_name) + end do + else + allocate(existing_src_files(0)) + end if + + ! Get legal fortran suffixes + call list_fortran_suffixes(f_ext,with_f_ext) + + is_source = [(.not.(is_hidden_file(basename(file_names(i)%s))) .and. & + .not.(canon_path(file_names(i)%s) .in. existing_src_files) .and. & + (str_ends_with(lower(file_names(i)%s), f_ext) .or. & + str_ends_with(lower(file_names(i)%s), c_suffixes) ),i=1,size(file_names))] + + src_file_names = pack(file_names,is_source) + + allocate(dir_sources(size(src_file_names))) + allocate(exclude_source(size(src_file_names))) + + do i = 1, size(src_file_names) + + dir_sources(i) = parse_source(src_file_names(i)%s,with_f_ext,error) + if (allocated(error)) return + + dir_sources(i)%unit_scope = scope + allocate(dir_sources(i)%link_libraries(0)) + + ! Exclude executables unless specified otherwise + exclude_source(i) = (dir_sources(i)%unit_type == FPM_UNIT_PROGRAM) + if (dir_sources(i)%unit_type == FPM_UNIT_PROGRAM .and. & + & present(with_executables)) then + if (with_executables) then + + exclude_source(i) = .false. + + end if + end if + + end do + + if (.not.allocated(sources)) then + sources = pack(dir_sources,.not.exclude_source) + else + sources = [sources, pack(dir_sources,.not.exclude_source)] + end if + +end subroutine add_sources_from_dir + +!> Add to `sources` using the executable and test entries in the manifest and +!> applies any executable-specific overrides such as `executable%name`. +!> Adds all sources (including modules) from each `executable%source_dir` +subroutine add_executable_sources(sources,executables,scope,auto_discover,with_f_ext,error) + !> List of `[[srcfile_t]]` objects to append to. Allocated if not allocated + type(srcfile_t), allocatable, intent(inout), target :: sources(:) + !> List of `[[executable_config_t]]` entries from manifest + class(executable_config_t), intent(in) :: executables(:) + !> Scope to apply to the discovered sources: either `FPM_SCOPE_APP` or `FPM_SCOPE_TEST`, see [[fpm_model]] + integer, intent(in) :: scope + !> If `.false.` only executables and tests specified in the manifest are added to `sources` + logical, intent(in) :: auto_discover + !> Additional user-defined (preprocessor) extensions that should be treated as Fortran sources + type(string_t), intent(in), optional :: with_f_ext(:) + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: i, j + + type(string_t), allocatable :: exe_dirs(:) + type(srcfile_t) :: exe_source + + call get_executable_source_dirs(exe_dirs,executables) + + do i=1,size(exe_dirs) + call add_sources_from_dir(sources,exe_dirs(i)%s, scope, & + with_executables=auto_discover, with_f_ext=with_f_ext,recurse=.false., error=error) + + if (allocated(error)) then + return + end if + end do + + exe_loop: do i=1,size(executables) + + ! Check if executable already discovered automatically + ! and apply any overrides + do j=1,size(sources) + + !> Compare lowercase strings to allow auto-discovery of pre-processed extensions + if (lower(basename(sources(j)%file_name,suffix=.true.)) == lower(executables(i)%main) .and.& + canon_path(dirname(sources(j)%file_name)) == & + canon_path(executables(i)%source_dir) ) then + + sources(j)%exe_name = executables(i)%name + if (allocated(executables(i)%link)) then + sources(j)%link_libraries = executables(i)%link + end if + sources(j)%unit_type = FPM_UNIT_PROGRAM + cycle exe_loop + + end if + + end do + + ! Add if not already discovered (auto_discovery off) + associate(exe => executables(i)) + exe_source = parse_source(join_path(exe%source_dir,exe%main),with_f_ext,error) + exe_source%exe_name = exe%name + if (allocated(exe%link)) then + exe_source%link_libraries = exe%link + end if + exe_source%unit_type = FPM_UNIT_PROGRAM + exe_source%unit_scope = scope + end associate + + if (allocated(error)) return + + if (.not.allocated(sources)) then + sources = [exe_source] + else + sources = [sources, exe_source] + end if + + end do exe_loop + +end subroutine add_executable_sources + +!> Build a list of unique source directories +!> from executables specified in manifest +subroutine get_executable_source_dirs(exe_dirs,executables) + type(string_t), allocatable, intent(inout) :: exe_dirs(:) + class(executable_config_t), intent(in) :: executables(:) + + type(string_t) :: dirs_temp(size(executables)) + + integer :: i, n + + n = 0 + + do i=1,size(executables) + dirs_temp(i)%s=' ' + enddo + + do i=1,size(executables) + if (.not.(executables(i)%source_dir .in. dirs_temp)) then + + n = n + 1 + dirs_temp(n)%s = executables(i)%source_dir + + end if + end do + + if (.not.allocated(exe_dirs)) then + exe_dirs = dirs_temp(1:n) + else + exe_dirs = [exe_dirs,dirs_temp(1:n)] + end if + +end subroutine get_executable_source_dirs + +!> Build an executable name with suffix. Safe routine that always returns an allocated string +function get_exe_name_with_suffix(source) result(suffixed) + type(srcfile_t), intent(in) :: source + character(len=:), allocatable :: suffixed + + if (allocated(source%exe_name)) then + if (get_os_type() == OS_WINDOWS) then + suffixed = source%exe_name//'.exe' + else + suffixed = source%exe_name + end if + else + suffixed = "" + endif + +end function get_exe_name_with_suffix + +end module fpm_sources + +!>>>>> ././src/fpm_targets.f90 + +!># Build target handling +!> +!> This module handles the construction of the build target list +!> from the sources list (`[[targets_from_sources]]`), the +!> resolution of module-dependencies between build targets +!> (`[[resolve_module_dependencies]]`), and the enumeration of +!> objects required for link targets (`[[resolve_target_linking]]`). +!> +!> A build target (`[[build_target_t]]`) is a file to be generated +!> by the backend (compilation and linking). +!> +!> @note The current implementation is ignorant to the existence of +!> module files (`.mod`,`.smod`). Dependencies arising from modules +!> are based on the corresponding object files (`.o`) only. +!> +!> For more information, please read the documentation for the procedures: +!> +!> - `[[build_target_list]]` +!> - `[[resolve_module_dependencies]]` +!> +!>### Enumerations +!> +!> __Target type:__ `FPM_TARGET_*` +!> Describes the type of build target — determines backend build rules +!> +module fpm_targets +use iso_fortran_env, only: int64 +use fpm_error, only: error_t, fatal_error, fpm_stop +use fpm_model +use fpm_compiler, only : compiler_t +use fpm_environment, only: get_os_type, OS_WINDOWS, OS_MACOS +use fpm_filesystem, only: dirname, join_path, canon_path +use fpm_strings, only: string_t, operator(.in.), string_cat, fnv_1a, resize, lower, str_ends_with +use fpm_compiler, only: get_macros +use fpm_sources, only: get_exe_name_with_suffix +use fpm_manifest_preprocess, only: preprocess_config_t +implicit none + +private + +public FPM_TARGET_UNKNOWN, FPM_TARGET_EXECUTABLE, & + FPM_TARGET_ARCHIVE, FPM_TARGET_OBJECT, & + FPM_TARGET_C_OBJECT, FPM_TARGET_CPP_OBJECT, & + FPM_TARGET_NAME +public build_target_t, build_target_ptr +public targets_from_sources, resolve_module_dependencies +public add_target, add_dependency +public filter_library_targets, filter_executable_targets, filter_modules + +!> Target type is unknown (ignored) +integer, parameter :: FPM_TARGET_UNKNOWN = -1 +!> Target type is executable +integer, parameter :: FPM_TARGET_EXECUTABLE = 1 +!> Target type is library archive +integer, parameter :: FPM_TARGET_ARCHIVE = 2 +!> Target type is compiled object +integer, parameter :: FPM_TARGET_OBJECT = 3 +!> Target type is c compiled object +integer, parameter :: FPM_TARGET_C_OBJECT = 4 +!> Target type is cpp compiled object +integer, parameter :: FPM_TARGET_CPP_OBJECT = 5 + +!> Wrapper type for constructing arrays of `[[build_target_t]]` pointers +type build_target_ptr + + type(build_target_t), pointer :: ptr => null() + +end type build_target_ptr + +!> Type describing a generated build target +type build_target_t + + !> File path of build target object relative to cwd + character(:), allocatable :: output_file + + !> File path of build target object relative to output_dir + character(:), allocatable :: output_name + + !> File path of output directory + character(:), allocatable :: output_dir + + !> File path of build log file relative to cwd + character(:), allocatable :: output_log_file + + !> Name of parent package + character(:), allocatable :: package_name + + !> Primary source for this build target + type(srcfile_t), allocatable :: source + + !> Resolved build dependencies + type(build_target_ptr), allocatable :: dependencies(:) + + !> Target type + integer :: target_type = FPM_TARGET_UNKNOWN + + !> Native libraries to link against + type(string_t), allocatable :: link_libraries(:) + + !> Objects needed to link this target + type(string_t), allocatable :: link_objects(:) + + !> Link flags for this build target + character(:), allocatable :: link_flags + + !> Compile flags for this build target + character(:), allocatable :: compile_flags + + !> Flag set when first visited to check for circular dependencies + logical :: touched = .false. + + !> Flag set if build target is sorted for building + logical :: sorted = .false. + + !> Flag set if build target will be skipped (not built) + logical :: skip = .false. + + !> Language features + type(fortran_features_t) :: features + + !> Targets in the same schedule group are guaranteed to be independent + integer :: schedule = -1 + + !> Previous source file hash + integer(int64), allocatable :: digest_cached + + !> List of macros + type(string_t), allocatable :: macros(:) + + !> Version number + character(:), allocatable :: version + + contains + + procedure :: is_executable_target + +end type build_target_t + +contains + +!> Target type name +pure function FPM_TARGET_NAME(type) result(msg) + integer, intent(in) :: type + character(:), allocatable :: msg + + select case (type) + case (FPM_TARGET_ARCHIVE); msg = 'Archive' + case (FPM_TARGET_CPP_OBJECT); msg = 'C++ object' + case (FPM_TARGET_C_OBJECT); msg = 'C Object' + case (FPM_TARGET_EXECUTABLE); msg = 'Executable' + case (FPM_TARGET_OBJECT); msg = 'Object' + case default; msg = 'Unknown' + end select + +end function FPM_TARGET_NAME + +!> High-level wrapper to generate build target information +subroutine targets_from_sources(targets,model,prune,error) + + !> The generated list of build targets + type(build_target_ptr), intent(out), allocatable :: targets(:) + + !> The package model from which to construct the target list + type(fpm_model_t), intent(inout), target :: model + + !> Enable tree-shaking/pruning of module dependencies + logical, intent(in) :: prune + + !> Error structure + type(error_t), intent(out), allocatable :: error + + call build_target_list(targets,model) + + call collect_exe_link_dependencies(targets) + + call resolve_module_dependencies(targets,model%external_modules,error) + if (allocated(error)) return + + if (prune) then + call prune_build_targets(targets,root_package=model%package_name) + end if + + call resolve_target_linking(targets,model) + +end subroutine targets_from_sources + +!> Constructs a list of build targets from a list of source files +!> +!>### Source-target mapping +!> +!> One compiled object target (`FPM_TARGET_OBJECT`) is generated for each +!> non-executable source file (`FPM_UNIT_MODULE`,`FPM_UNIT_SUBMODULE`, +!> `FPM_UNIT_SUBPROGRAM`,`FPM_UNIT_CSOURCE`). +!> +!> If any source file has scope `FPM_SCOPE_LIB` (*i.e.* there are library sources) +!> then the first target in the target list will be a library archive target +!> (`FPM_TARGET_ARCHIVE`). The archive target will have a dependency on every +!> compiled object target corresponding to a library source file. +!> +!> One compiled object target (`FPM_TARGET_OBJECT`) and one executable target (`FPM_TARGET_EXECUTABLE`) is +!> generated for each exectuable source file (`FPM_UNIT_PROGRAM`). The exectuble target +!> always has a dependency on the corresponding compiled object target. If there +!> is a library, then the executable target has an additional dependency on the library +!> archive target. +!> +subroutine build_target_list(targets,model) + + !> The generated list of build targets + type(build_target_ptr), intent(out), allocatable :: targets(:) + + !> The package model from which to construct the target list + type(fpm_model_t), intent(inout), target :: model + + integer :: i, j, n_source, exe_type + character(:), allocatable :: exe_dir, compile_flags + logical :: with_lib + + ! Initialize targets + allocate(targets(0)) + + ! Check for empty build (e.g. header-only lib) + n_source = sum([(size(model%packages(j)%sources), & + j=1,size(model%packages))]) + + if (n_source < 1) return + + with_lib = any([((model%packages(j)%sources(i)%unit_scope == FPM_SCOPE_LIB, & + i=1,size(model%packages(j)%sources)), & + j=1,size(model%packages))]) + + if (with_lib) call add_target(targets,package=model%package_name,type = FPM_TARGET_ARCHIVE,& + output_name = join_path(& + model%package_name,'lib'//model%package_name//'.a')) + + do j=1,size(model%packages) + + associate(sources=>model%packages(j)%sources) + + do i=1,size(sources) + + if (.not. model%include_tests) then + if (sources(i)%unit_scope == FPM_SCOPE_TEST) cycle + end if + + select case (sources(i)%unit_type) + case (FPM_UNIT_MODULE,FPM_UNIT_SUBMODULE,FPM_UNIT_SUBPROGRAM,FPM_UNIT_CSOURCE) + + call add_target(targets,package=model%packages(j)%name,source = sources(i), & + type = merge(FPM_TARGET_C_OBJECT,FPM_TARGET_OBJECT,& + sources(i)%unit_type==FPM_UNIT_CSOURCE), & + output_name = get_object_name(sources(i)), & + features = model%packages(j)%features, & + preprocess = model%packages(j)%preprocess, & + version = model%packages(j)%version) + + if (with_lib .and. sources(i)%unit_scope == FPM_SCOPE_LIB) then + ! Archive depends on object + call add_dependency(targets(1)%ptr, targets(size(targets))%ptr) + end if + + case (FPM_UNIT_CPPSOURCE) + + call add_target(targets,package=model%packages(j)%name,source = sources(i), & + type = FPM_TARGET_CPP_OBJECT, & + output_name = get_object_name(sources(i)), & + preprocess = model%packages(j)%preprocess, & + version = model%packages(j)%version) + + if (with_lib .and. sources(i)%unit_scope == FPM_SCOPE_LIB) then + ! Archive depends on object + call add_dependency(targets(1)%ptr, targets(size(targets))%ptr) + end if + + !> Add stdc++ as a linker flag. If not already there. + if (.not. ("stdc++" .in. model%link_libraries)) then + + if (get_os_type() == OS_MACOS) then + model%link_libraries = [model%link_libraries, string_t("c++")] + else + model%link_libraries = [model%link_libraries, string_t("stdc++")] + end if + + end if + + case (FPM_UNIT_PROGRAM) + + if (str_ends_with(lower(sources(i)%file_name), [".c"])) then + exe_type = FPM_TARGET_C_OBJECT + else if (str_ends_with(lower(sources(i)%file_name), [".cpp", ".cc "])) then + exe_type = FPM_TARGET_CPP_OBJECT + else ! Default to a Fortran object + exe_type = FPM_TARGET_OBJECT + end if + + call add_target(targets,package=model%packages(j)%name,type = exe_type,& + output_name = get_object_name(sources(i)), & + source = sources(i), & + features = model%packages(j)%features, & + preprocess = model%packages(j)%preprocess & + ) + + if (sources(i)%unit_scope == FPM_SCOPE_APP) then + + exe_dir = 'app' + + else if (sources(i)%unit_scope == FPM_SCOPE_EXAMPLE) then + + exe_dir = 'example' + + else + + exe_dir = 'test' + + end if + + call add_target(targets,package=model%packages(j)%name,type = FPM_TARGET_EXECUTABLE,& + link_libraries = sources(i)%link_libraries, & + output_name = join_path(exe_dir,get_exe_name_with_suffix(sources(i)))) + + associate(target => targets(size(targets))%ptr) + + ! Linker-only flags are necessary on some compilers for codes with non-Fortran main + select case (exe_type) + case (FPM_TARGET_C_OBJECT) + call model%compiler%get_main_flags("c",compile_flags) + case (FPM_TARGET_CPP_OBJECT) + call model%compiler%get_main_flags("c++",compile_flags) + case default + compile_flags = "" + end select + target%compile_flags = target%compile_flags//' '//compile_flags + + ! Executable depends on object + call add_dependency(target, targets(size(targets)-1)%ptr) + + if (with_lib) then + ! Executable depends on library + call add_dependency(target, targets(1)%ptr) + end if + + endassociate + + end select + + end do + + end associate + + end do + + contains + + function get_object_name(source) result(object_file) + ! Generate object target path from source name and model params + ! + ! + type(srcfile_t), intent(in) :: source + character(:), allocatable :: object_file + + integer :: i + character(1), parameter :: filesep = '/' + + object_file = canon_path(source%file_name) + + ! Convert any remaining directory separators to underscores + i = index(object_file,filesep) + do while(i > 0) + object_file(i:i) = '_' + i = index(object_file,filesep) + end do + + object_file = join_path(model%package_name,object_file)//'.o' + + end function get_object_name + +end subroutine build_target_list + +!> Add non-library non-module dependencies for executable targets +!> +!> Executable targets will link to any non-program non-module source files that +!> are in the same directory or in a subdirectory. +!> +!> (Note: Fortran module dependencies are handled separately in +!> `resolve_module_dependencies` and `resolve_target_linking`.) +!> +subroutine collect_exe_link_dependencies(targets) + type(build_target_ptr), intent(inout) :: targets(:) + + integer :: i, j + character(:), allocatable :: exe_source_dir + + ! Add non-module dependencies for executables + do j=1,size(targets) + + if (targets(j)%ptr%target_type == FPM_TARGET_EXECUTABLE) then + + do i=1,size(targets) + + if (i == j) cycle + + associate(exe => targets(j)%ptr, dep => targets(i)%ptr) + + exe_source_dir = dirname(exe%dependencies(1)%ptr%source%file_name) + + if (allocated(dep%source)) then + + if (dep%source%unit_scope /= FPM_SCOPE_LIB .and. & + dep%source%unit_type /= FPM_UNIT_PROGRAM .and. & + dep%source%unit_type /= FPM_UNIT_MODULE .and. & + index(dirname(dep%source%file_name), exe_source_dir) == 1) then + + call add_dependency(exe, dep) + + end if + + end if + + end associate + + end do + + end if + + end do + +end subroutine collect_exe_link_dependencies + +!> Allocate a new target and append to target list +subroutine add_target(targets, package, type, output_name, source, link_libraries, & + & features, preprocess, version) + type(build_target_ptr), allocatable, intent(inout) :: targets(:) + character(*), intent(in) :: package + integer, intent(in) :: type + character(*), intent(in) :: output_name + type(srcfile_t), intent(in), optional :: source + type(string_t), intent(in), optional :: link_libraries(:) + type(fortran_features_t), intent(in), optional :: features + type(preprocess_config_t), intent(in), optional :: preprocess + character(*), intent(in), optional :: version + + integer :: i + type(build_target_t), pointer :: new_target + + if (.not.allocated(targets)) allocate(targets(0)) + + ! Check for duplicate outputs + do i=1,size(targets) + + if (targets(i)%ptr%output_name == output_name) then + + write(*,*) 'Error while building target list: duplicate output object "',& + output_name,'"' + if (present(source)) write(*,*) ' Source file: "',source%file_name,'"' + call fpm_stop(1,' ') + + end if + + end do + + allocate(new_target) + new_target%target_type = type + new_target%output_name = output_name + new_target%package_name = package + if (present(source)) new_target%source = source + if (present(link_libraries)) new_target%link_libraries = link_libraries + if (present(features)) new_target%features = features + if (present(preprocess)) then + if (allocated(preprocess%macros)) new_target%macros = preprocess%macros + endif + if (present(version)) new_target%version = version + allocate(new_target%dependencies(0)) + + targets = [targets, build_target_ptr(new_target)] + +end subroutine add_target + +!> Add pointer to dependeny in target%dependencies +subroutine add_dependency(target, dependency) + type(build_target_t), intent(inout) :: target + type(build_target_t) , intent(in), target :: dependency + + target%dependencies = [target%dependencies, build_target_ptr(dependency)] + +end subroutine add_dependency + +!> Add dependencies to source-based targets (`FPM_TARGET_OBJECT`) +!> based on any modules used by the corresponding source file. +!> +!>### Source file scoping +!> +!> Source files are assigned a scope of either `FPM_SCOPE_LIB`, +!> `FPM_SCOPE_APP` or `FPM_SCOPE_TEST`. The scope controls which +!> modules may be used by the source file: +!> +!> - Library sources (`FPM_SCOPE_LIB`) may only use modules +!> also with library scope. This includes library modules +!> from dependencies. +!> +!> - Executable sources (`FPM_SCOPE_APP`,`FPM_SCOPE_TEST`) may use +!> library modules (including dependencies) as well as any modules +!> corresponding to source files in the same directory or a +!> subdirectory of the executable source file. +!> +!> @warning If a module used by a source file cannot be resolved to +!> a source file in the package of the correct scope, then a __fatal error__ +!> is returned by the procedure and model construction fails. +!> +subroutine resolve_module_dependencies(targets,external_modules,error) + type(build_target_ptr), intent(inout), target :: targets(:) + type(string_t), intent(in) :: external_modules(:) + type(error_t), allocatable, intent(out) :: error + + type(build_target_ptr) :: dep + + integer :: i, j + + do i=1,size(targets) + + if (.not.allocated(targets(i)%ptr%source)) cycle + + do j=1,size(targets(i)%ptr%source%modules_used) + + if (targets(i)%ptr%source%modules_used(j)%s .in. targets(i)%ptr%source%modules_provided) then + ! Dependency satisfied in same file, skip + cycle + end if + + if (targets(i)%ptr%source%modules_used(j)%s .in. external_modules) then + ! Dependency satisfied in system-installed module + cycle + end if + + if (any(targets(i)%ptr%source%unit_scope == & + [FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST])) then + dep%ptr => & + find_module_dependency(targets,targets(i)%ptr%source%modules_used(j)%s, & + include_dir = dirname(targets(i)%ptr%source%file_name)) + else + dep%ptr => & + find_module_dependency(targets,targets(i)%ptr%source%modules_used(j)%s) + end if + + if (.not.associated(dep%ptr)) then + call fatal_error(error, & + 'Unable to find source for module dependency: "' // & + targets(i)%ptr%source%modules_used(j)%s // & + '" used by "'//targets(i)%ptr%source%file_name//'"') + return + end if + + call add_dependency(targets(i)%ptr, dep%ptr) + + end do + + end do + +end subroutine resolve_module_dependencies + +function find_module_dependency(targets,module_name,include_dir) result(target_ptr) + ! Find a module dependency in the library or a dependency library + ! + ! 'include_dir' specifies an allowable non-library search directory + ! (Used for executable dependencies) + ! + type(build_target_ptr), intent(in), target :: targets(:) + character(*), intent(in) :: module_name + character(*), intent(in), optional :: include_dir + type(build_target_t), pointer :: target_ptr + + integer :: k, l + + target_ptr => NULL() + + do k=1,size(targets) + + if (.not.allocated(targets(k)%ptr%source)) cycle + + do l=1,size(targets(k)%ptr%source%modules_provided) + + if (module_name == targets(k)%ptr%source%modules_provided(l)%s) then + select case(targets(k)%ptr%source%unit_scope) + case (FPM_SCOPE_LIB, FPM_SCOPE_DEP) + target_ptr => targets(k)%ptr + exit + case default + if (present(include_dir)) then + if (index(dirname(targets(k)%ptr%source%file_name), include_dir) == 1) then ! source file is within the include_dir or a subdirectory + target_ptr => targets(k)%ptr + exit + end if + end if + end select + end if + + end do + + end do + +end function find_module_dependency + +!> Perform tree-shaking to remove unused module targets +subroutine prune_build_targets(targets, root_package) + + !> Build target list to prune + type(build_target_ptr), intent(inout), allocatable :: targets(:) + + !> Name of root package + character(*), intent(in) :: root_package + + integer :: i, j, nexec + type(string_t), allocatable :: modules_used(:) + logical :: exclude_target(size(targets)) + logical, allocatable :: exclude_from_archive(:) + + if (size(targets) < 1) then + return + end if + + nexec = 0 + allocate(modules_used(0)) + + ! Enumerate modules used by executables, non-module subprograms and their dependencies + do i=1,size(targets) + + if (targets(i)%ptr%target_type == FPM_TARGET_EXECUTABLE) then + + nexec = nexec + 1 + call collect_used_modules(targets(i)%ptr) + + elseif (allocated(targets(i)%ptr%source)) then + + if (targets(i)%ptr%source%unit_type == FPM_UNIT_SUBPROGRAM) then + + call collect_used_modules(targets(i)%ptr) + + end if + + end if + + end do + + ! If there aren't any executables, then prune + ! based on modules used in root package + if (nexec < 1) then + + do i=1,size(targets) + + if (targets(i)%ptr%package_name == root_package .and. & + targets(i)%ptr%target_type /= FPM_TARGET_ARCHIVE) then + + call collect_used_modules(targets(i)%ptr) + + end if + + end do + + end if + + call reset_target_flags(targets) + + exclude_target(:) = .false. + + ! Exclude purely module targets if they are not used anywhere + do i=1,size(targets) + associate(target=>targets(i)%ptr) + + if (allocated(target%source)) then + if (target%source%unit_type == FPM_UNIT_MODULE) then + + exclude_target(i) = .true. + target%skip = .true. + + do j=1,size(target%source%modules_provided) + + if (target%source%modules_provided(j)%s .in. modules_used) then + + exclude_target(i) = .false. + target%skip = .false. + + end if + + end do + + elseif (target%source%unit_type == FPM_UNIT_SUBMODULE) then + ! Remove submodules if their parents are not used + + exclude_target(i) = .true. + target%skip = .true. + do j=1,size(target%source%parent_modules) + + if (target%source%parent_modules(j)%s .in. modules_used) then + + exclude_target(i) = .false. + target%skip = .false. + + end if + + end do + + end if + end if + + ! (If there aren't any executables then we only prune modules from dependencies) + if (nexec < 1 .and. target%package_name == root_package) then + exclude_target(i) = .false. + target%skip = .false. + end if + + end associate + end do + + targets = pack(targets,.not.exclude_target) + + ! Remove unused targets from archive dependency list + if (targets(1)%ptr%target_type == FPM_TARGET_ARCHIVE) then + associate(archive=>targets(1)%ptr) + + allocate(exclude_from_archive(size(archive%dependencies))) + exclude_from_archive(:) = .false. + + do i=1,size(archive%dependencies) + + if (archive%dependencies(i)%ptr%skip) then + + exclude_from_archive(i) = .true. + + end if + + end do + + archive%dependencies = pack(archive%dependencies,.not.exclude_from_archive) + + end associate + end if + + contains + + !> Recursively collect which modules are actually used + recursive subroutine collect_used_modules(target) + type(build_target_t), intent(inout) :: target + + integer :: j, k + + if (target%touched) then + return + else + target%touched = .true. + end if + + if (allocated(target%source)) then + + ! Add modules from this target and from any of it's children submodules + do j=1,size(target%source%modules_provided) + + if (.not.(target%source%modules_provided(j)%s .in. modules_used)) then + + modules_used = [modules_used, target%source%modules_provided(j)] + + end if + + ! Recurse into child submodules + do k=1,size(targets) + if (allocated(targets(k)%ptr%source)) then + if (targets(k)%ptr%source%unit_type == FPM_UNIT_SUBMODULE) then + if (target%source%modules_provided(j)%s .in. targets(k)%ptr%source%parent_modules) then + call collect_used_modules(targets(k)%ptr) + end if + end if + end if + end do + + end do + end if + + ! Recurse into dependencies + do j=1,size(target%dependencies) + + if (target%dependencies(j)%ptr%target_type /= FPM_TARGET_ARCHIVE) then + call collect_used_modules(target%dependencies(j)%ptr) + end if + + end do + + end subroutine collect_used_modules + + !> Reset target flags after recursive search + subroutine reset_target_flags(targets) + type(build_target_ptr), intent(inout) :: targets(:) + + integer :: i + + do i=1,size(targets) + + targets(i)%ptr%touched = .false. + + end do + + end subroutine reset_target_flags + +end subroutine prune_build_targets + +!> Construct the linker flags string for each target +!> `target%link_flags` includes non-library objects and library flags +!> +subroutine resolve_target_linking(targets, model) + type(build_target_ptr), intent(inout), target :: targets(:) + type(fpm_model_t), intent(in) :: model + + integer :: i + character(:), allocatable :: global_link_flags, local_link_flags + character(:), allocatable :: global_include_flags + + if (size(targets) == 0) return + + global_link_flags = "" + if (allocated(model%link_libraries)) then + if (size(model%link_libraries) > 0) then + global_link_flags = model%compiler%enumerate_libraries(global_link_flags, model%link_libraries) + end if + end if + + allocate(character(0) :: global_include_flags) + if (allocated(model%include_dirs)) then + if (size(model%include_dirs) > 0) then + global_include_flags = global_include_flags // & + & " -I" // string_cat(model%include_dirs," -I") + end if + end if + + do i=1,size(targets) + + associate(target => targets(i)%ptr) + + ! If the main program is a C/C++ one, some compilers require additional linking flags, see + ! https://stackoverflow.com/questions/36221612/p3dfft-compilation-ifort-compiler-error-multiple-definiton-of-main + ! In this case, compile_flags were already allocated + if (.not.allocated(target%compile_flags)) allocate(character(len=0) :: target%compile_flags) + + target%compile_flags = target%compile_flags//' ' + + select case (target%target_type) + case (FPM_TARGET_C_OBJECT) + target%compile_flags = target%compile_flags//model%c_compile_flags + case (FPM_TARGET_CPP_OBJECT) + target%compile_flags = target%compile_flags//model%cxx_compile_flags + case default + target%compile_flags = target%compile_flags//model%fortran_compile_flags & + & // get_feature_flags(model%compiler, target%features) + end select + + !> Get macros as flags. + target%compile_flags = target%compile_flags // get_macros(model%compiler%id, & + target%macros, & + target%version) + + if (len(global_include_flags) > 0) then + target%compile_flags = target%compile_flags//global_include_flags + end if + target%output_dir = get_output_dir(model%build_prefix, target%compile_flags) + target%output_file = join_path(target%output_dir, target%output_name) + target%output_log_file = join_path(target%output_dir, target%output_name)//'.log' + end associate + + end do + + call add_include_build_dirs(model, targets) + + do i=1,size(targets) + + associate(target => targets(i)%ptr) + allocate(target%link_objects(0)) + + if (target%target_type == FPM_TARGET_ARCHIVE) then + global_link_flags = target%output_file // global_link_flags + + call get_link_objects(target%link_objects,target,is_exe=.false.) + + allocate(character(0) :: target%link_flags) + + else if (target%target_type == FPM_TARGET_EXECUTABLE) then + + call get_link_objects(target%link_objects,target,is_exe=.true.) + + local_link_flags = "" + if (allocated(model%link_flags)) local_link_flags = model%link_flags + target%link_flags = model%link_flags//" "//string_cat(target%link_objects," ") + + if (allocated(target%link_libraries)) then + if (size(target%link_libraries) > 0) then + target%link_flags = model%compiler%enumerate_libraries(target%link_flags, target%link_libraries) + local_link_flags = model%compiler%enumerate_libraries(local_link_flags, target%link_libraries) + end if + end if + + target%link_flags = target%link_flags//" "//global_link_flags + + target%output_dir = get_output_dir(model%build_prefix, & + & target%compile_flags//local_link_flags) + target%output_file = join_path(target%output_dir, target%output_name) + target%output_log_file = join_path(target%output_dir, target%output_name)//'.log' + end if + + end associate + + end do + +contains + + !> Wrapper to build link object list + !> + !> For libraries: just list dependency objects of lib target + !> + !> For executables: need to recursively discover non-library + !> dependency objects. (i.e. modules in same dir as program) + !> + recursive subroutine get_link_objects(link_objects,target,is_exe) + type(string_t), intent(inout), allocatable :: link_objects(:) + type(build_target_t), intent(in) :: target + logical, intent(in) :: is_exe + + integer :: i + type(string_t) :: temp_str + + if (.not.allocated(target%dependencies)) return + + do i=1,size(target%dependencies) + + associate(dep => target%dependencies(i)%ptr) + + if (.not.allocated(dep%source)) cycle + + ! Skip library dependencies for executable targets + ! since the library archive will always be linked + if (is_exe.and.(dep%source%unit_scope == FPM_SCOPE_LIB)) cycle + + ! Skip if dependency object already listed + if (dep%output_file .in. link_objects) cycle + + ! Add dependency object file to link object list + temp_str%s = dep%output_file + link_objects = [link_objects, temp_str] + + ! For executable objects, also need to include non-library + ! dependencies from dependencies (recurse) + if (is_exe) call get_link_objects(link_objects,dep,is_exe=.true.) + + end associate + + end do + + end subroutine get_link_objects + +end subroutine resolve_target_linking + +subroutine add_include_build_dirs(model, targets) + type(fpm_model_t), intent(in) :: model + type(build_target_ptr), intent(inout), target :: targets(:) + + integer :: i + type(string_t), allocatable :: build_dirs(:) + type(string_t) :: temp + + allocate(build_dirs(0)) + do i = 1, size(targets) + associate(target => targets(i)%ptr) + if (target%target_type /= FPM_TARGET_OBJECT) cycle + if (target%output_dir .in. build_dirs) cycle + temp%s = target%output_dir + build_dirs = [build_dirs, temp] + end associate + end do + + do i = 1, size(targets) + associate(target => targets(i)%ptr) + if (target%target_type /= FPM_TARGET_OBJECT) cycle + + target%compile_flags = target%compile_flags // & + " " // model%compiler%get_module_flag(target%output_dir) // & + " -I" // string_cat(build_dirs, " -I") + end associate + end do + +end subroutine add_include_build_dirs + +function get_output_dir(build_prefix, args) result(path) + character(len=*), intent(in) :: build_prefix + character(len=*), intent(in) :: args + character(len=:), allocatable :: path + + character(len=16) :: build_hash + + write(build_hash, '(z16.16)') fnv_1a(args) + path = build_prefix//"_"//build_hash +end function get_output_dir + +subroutine filter_library_targets(targets, list) + type(build_target_ptr), intent(in) :: targets(:) + type(string_t), allocatable, intent(out) :: list(:) + + integer :: i, n + + n = 0 + call resize(list) + do i = 1, size(targets) + if (targets(i)%ptr%target_type == FPM_TARGET_ARCHIVE) then + if (n >= size(list)) call resize(list) + n = n + 1 + list(n)%s = targets(i)%ptr%output_file + end if + end do + call resize(list, n) +end subroutine filter_library_targets + +subroutine filter_executable_targets(targets, scope, list) + type(build_target_ptr), intent(in) :: targets(:) + integer, intent(in) :: scope + type(string_t), allocatable, intent(out) :: list(:) + + integer :: i, n + + n = 0 + call resize(list) + do i = 1, size(targets) + if (is_executable_target(targets(i)%ptr, scope)) then + if (n >= size(list)) call resize(list) + n = n + 1 + list(n)%s = targets(i)%ptr%output_file + end if + end do + call resize(list, n) +end subroutine filter_executable_targets + +elemental function is_executable_target(target_ptr, scope) result(is_exe) + class(build_target_t), intent(in) :: target_ptr + integer, intent(in) :: scope + logical :: is_exe + is_exe = target_ptr%target_type == FPM_TARGET_EXECUTABLE .and. & + allocated(target_ptr%dependencies) + if (is_exe) then + is_exe = target_ptr%dependencies(1)%ptr%source%unit_scope == scope + end if +end function is_executable_target + +subroutine filter_modules(targets, list) + type(build_target_ptr), intent(in) :: targets(:) + type(string_t), allocatable, intent(out) :: list(:) + + integer :: i, j, n + + n = 0 + call resize(list) + do i = 1, size(targets) + associate(target => targets(i)%ptr) + if (.not.allocated(target%source)) cycle + if (target%source%unit_type == FPM_UNIT_SUBMODULE) cycle + if (n + size(target%source%modules_provided) >= size(list)) call resize(list) + do j = 1, size(target%source%modules_provided) + n = n + 1 + list(n)%s = join_path(target%output_dir, & + target%source%modules_provided(j)%s) + end do + end associate + end do + call resize(list, n) +end subroutine filter_modules + +function get_feature_flags(compiler, features) result(flags) + type(compiler_t), intent(in) :: compiler + type(fortran_features_t), intent(in) :: features + character(:), allocatable :: flags + + flags = "" + if (features%implicit_typing) then + flags = flags // compiler%get_feature_flag("implicit-typing") + else + flags = flags // compiler%get_feature_flag("no-implicit-typing") + end if + + if (features%implicit_external) then + flags = flags // compiler%get_feature_flag("implicit-external") + else + flags = flags // compiler%get_feature_flag("no-implicit-external") + end if + + if (allocated(features%source_form)) then + flags = flags // compiler%get_feature_flag(features%source_form//"-form") + end if +end function get_feature_flags + +end module fpm_targets + +!>>>>> ././src/fpm_backend_output.f90 + +!># Build Backend Progress Output +!> This module provides a derived type `build_progress_t` for printing build status +!> and progress messages to the console while the backend is building the package. +!> +!> The `build_progress_t` type supports two modes: `normal` and `plain` +!> where the former does 'pretty' output and the latter does not. +!> The `normal` mode is intended for typical interactive usage whereas +!> 'plain' mode is used with the `--verbose` flag or when `stdout` is not attached +!> to a terminal (e.g. when piping or redirecting `stdout`). In these cases, +!> the pretty output must be suppressed to avoid control codes being output. + +module fpm_backend_output +use iso_fortran_env, only: stdout=>output_unit +use fpm_filesystem, only: basename +use fpm_targets, only: build_target_ptr +use fpm_backend_console, only: console_t, LINE_RESET, COLOR_RED, COLOR_GREEN, COLOR_YELLOW, COLOR_RESET +implicit none + +private +public build_progress_t + +!> Build progress object +type build_progress_t + !> Console object for updating console lines + type(console_t) :: console + !> Number of completed targets + integer :: n_complete + !> Total number of targets scheduled + integer :: n_target + !> 'Plain' output (no colors or updating) + logical :: plain_mode = .true. + !> Store needed when updating previous console lines + integer, allocatable :: output_lines(:) + !> Queue of scheduled build targets + type(build_target_ptr), pointer :: target_queue(:) +contains + !> Output 'compiling' status for build target + procedure :: compiling_status => output_status_compiling + !> Output 'complete' status for build target + procedure :: completed_status => output_status_complete + !> Output finished status for whole package + procedure :: success => output_progress_success +end type build_progress_t + +!> Constructor for build_progress_t +interface build_progress_t + procedure :: new_build_progress +end interface build_progress_t + +contains + + !> Initialise a new build progress object + function new_build_progress(target_queue,plain_mode) result(progress) + !> The queue of scheduled targets + type(build_target_ptr), intent(in), target :: target_queue(:) + !> Enable 'plain' output for progress object + logical, intent(in), optional :: plain_mode + !> Progress object to initialise + type(build_progress_t) :: progress + + progress%n_target = size(target_queue,1) + progress%target_queue => target_queue + progress%plain_mode = plain_mode + progress%n_complete = 0 + + allocate(progress%output_lines(progress%n_target)) + + end function new_build_progress + + !> Output 'compiling' status for build target and overall percentage progress + subroutine output_status_compiling(progress, queue_index) + !> Progress object + class(build_progress_t), intent(inout) :: progress + !> Index of build target in the target queue + integer, intent(in) :: queue_index + + character(:), allocatable :: target_name + character(100) :: output_string + character(7) :: overall_progress + + associate(target=>progress%target_queue(queue_index)%ptr) + + if (allocated(target%source)) then + target_name = basename(target%source%file_name) + else + target_name = basename(target%output_file) + end if + + write(overall_progress,'(A,I3,A)') '[',100*progress%n_complete/progress%n_target,'%] ' + + if (progress%plain_mode) then ! Plain output + + !$omp critical + write(*,'(A7,A30)') overall_progress,target_name + !$omp end critical + + else ! Pretty output + + write(output_string,'(A,T40,A,A)') target_name, COLOR_YELLOW//'compiling...'//COLOR_RESET + + call progress%console%write_line(trim(output_string),progress%output_lines(queue_index)) + + call progress%console%write_line(overall_progress//'Compiling...',advance=.false.) + + end if + + end associate + + end subroutine output_status_compiling + + !> Output 'complete' status for build target and update overall percentage progress + subroutine output_status_complete(progress, queue_index, build_stat) + !> Progress object + class(build_progress_t), intent(inout) :: progress + !> Index of build target in the target queue + integer, intent(in) :: queue_index + !> Build status flag + integer, intent(in) :: build_stat + + character(:), allocatable :: target_name + character(100) :: output_string + character(7) :: overall_progress + + !$omp critical + progress%n_complete = progress%n_complete + 1 + !$omp end critical + + associate(target=>progress%target_queue(queue_index)%ptr) + + if (allocated(target%source)) then + target_name = basename(target%source%file_name) + else + target_name = basename(target%output_file) + end if + + if (build_stat == 0) then + write(output_string,'(A,T40,A,A)') target_name,COLOR_GREEN//'done.'//COLOR_RESET + else + write(output_string,'(A,T40,A,A)') target_name,COLOR_RED//'failed.'//COLOR_RESET + end if + + write(overall_progress,'(A,I3,A)') '[',100*progress%n_complete/progress%n_target,'%] ' + + if (progress%plain_mode) then ! Plain output + + !$omp critical + write(*,'(A7,A30,A7)') overall_progress,target_name, 'done.' + !$omp end critical + + else ! Pretty output + + call progress%console%update_line(progress%output_lines(queue_index),trim(output_string)) + + call progress%console%write_line(overall_progress//'Compiling...',advance=.false.) + + end if + + end associate + + end subroutine output_status_complete + + !> Output finished status for whole package + subroutine output_progress_success(progress) + class(build_progress_t), intent(inout) :: progress + + if (progress%plain_mode) then ! Plain output + + write(*,'(A)') '[100%] Project compiled successfully.' + + else ! Pretty output + + write(*,'(A)') LINE_RESET//COLOR_GREEN//'[100%] Project compiled successfully.'//COLOR_RESET + + end if + + end subroutine output_progress_success + +end module fpm_backend_output + +!>>>>> ././src/fpm_backend.F90 + +!># Build backend +!> Uses a list of `[[build_target_ptr]]` and a valid `[[fpm_model]]` instance +!> to schedule and execute the compilation and linking of package targets. +!> +!> The package build process (`[[build_package]]`) comprises three steps: +!> +!> 1. __Target sorting:__ topological sort of the target dependency graph (`[[sort_target]]`) +!> 2. __Target scheduling:__ group targets into schedule regions based on the sorting (`[[schedule_targets]]`) +!> 3. __Target building:__ generate targets by compilation or linking +!> +!> @note If compiled with OpenMP, targets will be build in parallel where possible. +!> +!>### Incremental compilation +!> The backend process supports *incremental* compilation whereby targets are not +!> re-compiled if their corresponding dependencies have not been modified. +!> +!> - Source-based targets (*i.e.* objects) are not re-compiled if the corresponding source +!> file is unmodified AND all of the target dependencies are not marked for re-compilation +!> +!> - Link targets (*i.e.* executables and libraries) are not re-compiled if the +!> target output file already exists AND all of the target dependencies are not marked for +!> re-compilation +!> +!> Source file modification is determined by a file digest (hash) which is calculated during +!> the source parsing phase ([[fpm_source_parsing]]) and cached to disk after a target is +!> successfully generated. +!> +module fpm_backend + +use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit +use fpm_error, only : fpm_stop +use fpm_filesystem, only: basename, dirname, join_path, exists, mkdir, run, getline +use fpm_model, only: fpm_model_t +use fpm_strings, only: string_t, operator(.in.) +use fpm_targets, only: build_target_t, build_target_ptr, FPM_TARGET_OBJECT, & + FPM_TARGET_C_OBJECT, FPM_TARGET_ARCHIVE, FPM_TARGET_EXECUTABLE, & + FPM_TARGET_CPP_OBJECT +use fpm_backend_output +implicit none + +private +public :: build_package, sort_target, schedule_targets + +interface + function c_isatty() bind(C, name = 'c_isatty') + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int) :: c_isatty + end function +end interface + +contains + +!> Top-level routine to build package described by `model` +subroutine build_package(targets,model,verbose) + type(build_target_ptr), intent(inout) :: targets(:) + type(fpm_model_t), intent(in) :: model + logical, intent(in) :: verbose + + integer :: i, j + type(build_target_ptr), allocatable :: queue(:) + integer, allocatable :: schedule_ptr(:), stat(:) + logical :: build_failed, skip_current + type(string_t), allocatable :: build_dirs(:) + type(string_t) :: temp + + type(build_progress_t) :: progress + logical :: plain_output + + ! Need to make output directory for include (mod) files + allocate(build_dirs(0)) + do i = 1, size(targets) + associate(target => targets(i)%ptr) + if (target%output_dir .in. build_dirs) cycle + temp%s = target%output_dir + build_dirs = [build_dirs, temp] + end associate + end do + + do i = 1, size(build_dirs) + call mkdir(build_dirs(i)%s,verbose) + end do + + ! Perform depth-first topological sort of targets + do i=1,size(targets) + + call sort_target(targets(i)%ptr) + + end do + + ! Construct build schedule queue + call schedule_targets(queue, schedule_ptr, targets) + + ! Check if queue is empty + if (.not.verbose .and. size(queue) < 1) then + write(stderr, '(a)') 'Project is up to date' + return + end if + + ! Initialise build status flags + allocate(stat(size(queue))) + stat(:) = 0 + build_failed = .false. + + ! Set output mode + + plain_output = (.not.(c_isatty()==1)) .or. verbose + + progress = build_progress_t(queue,plain_output) + + ! Loop over parallel schedule regions + do i=1,size(schedule_ptr)-1 + + ! Build targets in schedule region i + !$omp parallel do default(shared) private(skip_current) schedule(dynamic,1) + do j=schedule_ptr(i),(schedule_ptr(i+1)-1) + + ! Check if build already failed + !$omp atomic read + skip_current = build_failed + + if (.not.skip_current) then + call progress%compiling_status(j) + call build_target(model,queue(j)%ptr,verbose,stat(j)) + call progress%completed_status(j,stat(j)) + end if + + ! Set global flag if this target failed to build + if (stat(j) /= 0) then + !$omp atomic write + build_failed = .true. + end if + + end do + + ! Check if this schedule region failed: exit with message if failed + if (build_failed) then + write(*,*) + do j=1,size(stat) + if (stat(j) /= 0) Then + call print_build_log(queue(j)%ptr) + end if + end do + do j=1,size(stat) + if (stat(j) /= 0) then + write(stderr,'(*(g0:,1x))') ' Compilation failed for object "',basename(queue(j)%ptr%output_file),'"' + end if + end do + call fpm_stop(1,'stopping due to failed compilation') + end if + + end do + + call progress%success() + +end subroutine build_package + +!> Topologically sort a target for scheduling by +!> recursing over its dependencies. +!> +!> Checks disk-cached source hashes to determine if objects are +!> up-to-date. Up-to-date sources are tagged as skipped. +!> +!> On completion, `target` should either be marked as +!> sorted (`target%sorted=.true.`) or skipped (`target%skip=.true.`) +!> +!> If `target` is marked as sorted, `target%schedule` should be an +!> integer greater than zero indicating the region for scheduling +!> +recursive subroutine sort_target(target) + type(build_target_t), intent(inout), target :: target + + integer :: i, fh, stat + + ! Check if target has already been processed (as a dependency) + if (target%sorted .or. target%skip) then + return + end if + + ! Check for a circular dependency + ! (If target has been touched but not processed) + if (target%touched) then + call fpm_stop(1,'(!) Circular dependency found with: '//target%output_file) + else + target%touched = .true. ! Set touched flag + end if + + ! Load cached source file digest if present + if (.not.allocated(target%digest_cached) .and. & + exists(target%output_file) .and. & + exists(target%output_file//'.digest')) then + + allocate(target%digest_cached) + open(newunit=fh,file=target%output_file//'.digest',status='old') + read(fh,*,iostat=stat) target%digest_cached + close(fh) + + if (stat /= 0) then ! Cached digest is not recognized + deallocate(target%digest_cached) + end if + + end if + + if (allocated(target%source)) then + + ! Skip if target is source-based and source file is unmodified + if (allocated(target%digest_cached)) then + if (target%digest_cached == target%source%digest) target%skip = .true. + end if + + elseif (exists(target%output_file)) then + + ! Skip if target is not source-based and already exists + target%skip = .true. + + end if + + ! Loop over target dependencies + target%schedule = 1 + do i=1,size(target%dependencies) + + ! Sort dependency + call sort_target(target%dependencies(i)%ptr) + + if (.not.target%dependencies(i)%ptr%skip) then + + ! Can't skip target if any dependency is not skipped + target%skip = .false. + + ! Set target schedule after all of its dependencies + target%schedule = max(target%schedule,target%dependencies(i)%ptr%schedule+1) + + end if + + end do + + ! Mark flag as processed: either sorted or skipped + target%sorted = .not.target%skip + +end subroutine sort_target + +!> Construct a build schedule from the sorted targets. +!> +!> The schedule is broken into regions, described by `schedule_ptr`, +!> where targets in each region can be compiled in parallel. +!> +subroutine schedule_targets(queue, schedule_ptr, targets) + type(build_target_ptr), allocatable, intent(out) :: queue(:) + integer, allocatable :: schedule_ptr(:) + type(build_target_ptr), intent(in) :: targets(:) + + integer :: i, j + integer :: n_schedule, n_sorted + + n_schedule = 0 ! Number of schedule regions + n_sorted = 0 ! Total number of targets to build + do i=1,size(targets) + + if (targets(i)%ptr%sorted) then + n_sorted = n_sorted + 1 + end if + n_schedule = max(n_schedule, targets(i)%ptr%schedule) + + end do + + allocate(queue(n_sorted)) + allocate(schedule_ptr(n_schedule+1)) + + ! Construct the target queue and schedule region pointer + n_sorted = 1 + schedule_ptr(n_sorted) = 1 + do i=1,n_schedule + + do j=1,size(targets) + + if (targets(j)%ptr%sorted) then + if (targets(j)%ptr%schedule == i) then + + queue(n_sorted)%ptr => targets(j)%ptr + n_sorted = n_sorted + 1 + end if + end if + + end do + + schedule_ptr(i+1) = n_sorted + + end do + +end subroutine schedule_targets + +!> Call compile/link command for a single target. +!> +!> If successful, also caches the source file digest to disk. +!> +subroutine build_target(model,target,verbose,stat) + type(fpm_model_t), intent(in) :: model + type(build_target_t), intent(in), target :: target + logical, intent(in) :: verbose + integer, intent(out) :: stat + + integer :: fh + + !$omp critical + if (.not.exists(dirname(target%output_file))) then + call mkdir(dirname(target%output_file),verbose) + end if + !$omp end critical + + select case(target%target_type) + + case (FPM_TARGET_OBJECT) + call model%compiler%compile_fortran(target%source%file_name, target%output_file, & + & target%compile_flags, target%output_log_file, stat) + + case (FPM_TARGET_C_OBJECT) + call model%compiler%compile_c(target%source%file_name, target%output_file, & + & target%compile_flags, target%output_log_file, stat) + + case (FPM_TARGET_CPP_OBJECT) + call model%compiler%compile_cpp(target%source%file_name, target%output_file, & + & target%compile_flags, target%output_log_file, stat) + + case (FPM_TARGET_EXECUTABLE) + call model%compiler%link(target%output_file, & + & target%compile_flags//" "//target%link_flags, target%output_log_file, stat) + + case (FPM_TARGET_ARCHIVE) + call model%archiver%make_archive(target%output_file, target%link_objects, & + & target%output_log_file, stat) + + end select + + if (stat == 0 .and. allocated(target%source)) then + open(newunit=fh,file=target%output_file//'.digest',status='unknown') + write(fh,*) target%source%digest + close(fh) + end if + +end subroutine build_target + +!> Read and print the build log for target +!> +subroutine print_build_log(target) + type(build_target_t), intent(in), target :: target + + integer :: fh, ios + character(:), allocatable :: line + + if (exists(target%output_log_file)) then + + open(newunit=fh,file=target%output_log_file,status='old') + do + call getline(fh, line, ios) + if (ios /= 0) exit + write(*,'(A)') trim(line) + end do + close(fh) + + else + + write(stderr,'(*(g0:,1x))') ' Unable to find build log "',basename(target%output_log_file),'"' + + end if + +end subroutine print_build_log + +end module fpm_backend + +!>>>>> ././src/fpm.f90 + +module fpm +use fpm_strings, only: string_t, operator(.in.), glob, join, string_cat, & + lower, str_ends_with, is_fortran_name, str_begins_with_str, & + is_valid_module_name, len_trim +use fpm_backend, only: build_package +use fpm_command_line, only: fpm_build_settings, fpm_new_settings, & + fpm_run_settings, fpm_install_settings, fpm_test_settings, & + fpm_clean_settings +use fpm_dependency, only : new_dependency_tree +use fpm_filesystem, only: is_dir, join_path, list_files, exists, & + basename, filewrite, mkdir, run, os_delete_dir +use fpm_model, only: fpm_model_t, srcfile_t, show_model, fortran_features_t, & + FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, FPM_SCOPE_DEP, & + FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST +use fpm_compiler, only: new_compiler, new_archiver, set_cpp_preprocessor_flags + +use fpm_sources, only: add_executable_sources, add_sources_from_dir +use fpm_targets, only: targets_from_sources, build_target_t, build_target_ptr, & + FPM_TARGET_EXECUTABLE, FPM_TARGET_ARCHIVE +use fpm_manifest, only : get_package_data, package_config_t +use fpm_meta, only : resolve_metapackages +use fpm_error, only : error_t, fatal_error, fpm_stop +use fpm_toml, only: name_is_json +use, intrinsic :: iso_fortran_env, only : stdin => input_unit, & + & stdout => output_unit, & + & stderr => error_unit +use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer +use fpm_environment, only: os_is_unix +use fpm_settings, only: fpm_global_settings, get_global_settings + +implicit none +private +public :: cmd_build, cmd_run, cmd_clean +public :: build_model, check_modules_for_duplicates + +contains + +!> Constructs a valid fpm model from command line settings and the toml manifest. +subroutine build_model(model, settings, package, error) + type(fpm_model_t), intent(out) :: model + class(fpm_build_settings), intent(inout) :: settings + type(package_config_t), intent(inout) :: package + type(error_t), allocatable, intent(out) :: error + + integer :: i, j + type(package_config_t) :: dependency + character(len=:), allocatable :: manifest, lib_dir + logical :: has_cpp + logical :: duplicates_found + type(string_t) :: include_dir + + model%package_name = package%name + + allocate(model%include_dirs(0)) + allocate(model%link_libraries(0)) + allocate(model%external_modules(0)) + + call new_compiler(model%compiler, settings%compiler, settings%c_compiler, & + & settings%cxx_compiler, echo=settings%verbose, verbose=settings%verbose) + call new_archiver(model%archiver, settings%archiver, & + & echo=settings%verbose, verbose=settings%verbose) + + if (model%compiler%is_unknown()) then + write(*, '(*(a:,1x))') & + "", "Unknown compiler", model%compiler%fc, "requested!", & + "Defaults for this compiler might be incorrect" + end if + + call new_compiler_flags(model,settings) + model%build_prefix = join_path("build", basename(model%compiler%fc)) + model%include_tests = settings%build_tests + model%enforce_module_names = package%build%module_naming + model%module_prefix = package%build%module_prefix + + ! Resolve meta-dependencies into the package and the model + call resolve_metapackages(model,package,settings,error) + if (allocated(error)) return + + ! Create dependencies + call new_dependency_tree(model%deps, cache=join_path("build", "cache.toml")) + + ! Build and resolve model dependencies + call model%deps%add(package, error) + if (allocated(error)) return + + ! Update dependencies where needed + call model%deps%update(error) + if (allocated(error)) return + + ! build/ directory should now exist + if (.not.exists("build/.gitignore")) then + call filewrite(join_path("build", ".gitignore"),["*"]) + end if + + allocate(model%packages(model%deps%ndep)) + + has_cpp = .false. + do i = 1, model%deps%ndep + associate(dep => model%deps%dep(i)) + manifest = join_path(dep%proj_dir, "fpm.toml") + + call get_package_data(dependency, manifest, error, apply_defaults=.true.) + if (allocated(error)) exit + + model%packages(i)%name = dependency%name + associate(features => model%packages(i)%features) + features%implicit_typing = dependency%fortran%implicit_typing + features%implicit_external = dependency%fortran%implicit_external + features%source_form = dependency%fortran%source_form + end associate + model%packages(i)%version = package%version%s() + + !> Add this dependency's manifest macros + call model%packages(i)%preprocess%destroy() + + if (allocated(dependency%preprocess)) then + do j = 1, size(dependency%preprocess) + call model%packages(i)%preprocess%add_config(dependency%preprocess(j)) + end do + end if + + !> Add this dependency's package-level macros + if (allocated(dep%preprocess)) then + do j = 1, size(dep%preprocess) + call model%packages(i)%preprocess%add_config(dep%preprocess(j)) + end do + end if + + if (model%packages(i)%preprocess%is_cpp()) has_cpp = .true. + + if (.not.allocated(model%packages(i)%sources)) allocate(model%packages(i)%sources(0)) + + if (allocated(dependency%library)) then + + if (allocated(dependency%library%source_dir)) then + lib_dir = join_path(dep%proj_dir, dependency%library%source_dir) + if (is_dir(lib_dir)) then + call add_sources_from_dir(model%packages(i)%sources, lib_dir, FPM_SCOPE_LIB, & + with_f_ext=model%packages(i)%preprocess%suffixes, error=error) + if (allocated(error)) exit + end if + end if + + if (allocated(dependency%library%include_dir)) then + do j=1,size(dependency%library%include_dir) + include_dir%s = join_path(dep%proj_dir, dependency%library%include_dir(j)%s) + if (is_dir(include_dir%s)) then + model%include_dirs = [model%include_dirs, include_dir] + end if + end do + end if + + end if + + if (allocated(dependency%build%link)) then + model%link_libraries = [model%link_libraries, dependency%build%link] + end if + + if (allocated(dependency%build%external_modules)) then + model%external_modules = [model%external_modules, dependency%build%external_modules] + end if + + ! Copy naming conventions from this dependency's manifest + model%packages(i)%enforce_module_names = dependency%build%module_naming + model%packages(i)%module_prefix = dependency%build%module_prefix + + end associate + end do + if (allocated(error)) return + + ! Add optional flags + if (has_cpp) call set_cpp_preprocessor_flags(model%compiler%id, model%fortran_compile_flags) + + ! Add sources from executable directories + if (is_dir('app') .and. package%build%auto_executables) then + call add_sources_from_dir(model%packages(1)%sources,'app', FPM_SCOPE_APP, & + with_executables=.true., with_f_ext=model%packages(1)%preprocess%suffixes,& + error=error) + + if (allocated(error)) then + return + end if + + end if + if (is_dir('example') .and. package%build%auto_examples) then + call add_sources_from_dir(model%packages(1)%sources,'example', FPM_SCOPE_EXAMPLE, & + with_executables=.true., & + with_f_ext=model%packages(1)%preprocess%suffixes,error=error) + + if (allocated(error)) then + return + end if + + end if + if (is_dir('test') .and. package%build%auto_tests) then + call add_sources_from_dir(model%packages(1)%sources,'test', FPM_SCOPE_TEST, & + with_executables=.true., & + with_f_ext=model%packages(1)%preprocess%suffixes,error=error) + + if (allocated(error)) then + return + endif + + end if + if (allocated(package%executable)) then + call add_executable_sources(model%packages(1)%sources, package%executable, FPM_SCOPE_APP, & + auto_discover=package%build%auto_executables, & + with_f_ext=model%packages(1)%preprocess%suffixes, & + error=error) + + if (allocated(error)) then + return + end if + + end if + if (allocated(package%example)) then + call add_executable_sources(model%packages(1)%sources, package%example, FPM_SCOPE_EXAMPLE, & + auto_discover=package%build%auto_examples, & + with_f_ext=model%packages(1)%preprocess%suffixes, & + error=error) + + if (allocated(error)) then + return + end if + + end if + if (allocated(package%test)) then + call add_executable_sources(model%packages(1)%sources, package%test, FPM_SCOPE_TEST, & + auto_discover=package%build%auto_tests, & + with_f_ext=model%packages(1)%preprocess%suffixes, & + error=error) + + if (allocated(error)) then + return + endif + + endif + + if (settings%verbose) then + write(*,*)' BUILD_NAME: ',model%build_prefix + write(*,*)' COMPILER: ',model%compiler%fc + write(*,*)' C COMPILER: ',model%compiler%cc + write(*,*)' CXX COMPILER: ',model%compiler%cxx + write(*,*)' COMPILER OPTIONS: ', model%fortran_compile_flags + write(*,*)' C COMPILER OPTIONS: ', model%c_compile_flags + write(*,*)' CXX COMPILER OPTIONS: ', model%cxx_compile_flags + write(*,*)' LINKER OPTIONS: ', model%link_flags + write(*,*)' INCLUDE DIRECTORIES: [', string_cat(model%include_dirs,','),']' + end if + + ! Check for invalid module names + call check_module_names(model, error) + if (allocated(error)) return + + ! Check for duplicate modules + duplicates_found = .false. + call check_modules_for_duplicates(model, duplicates_found) + if (duplicates_found) then + call fpm_stop(1,'*build_model*:Error: One or more duplicate module names found.') + end if +end subroutine build_model + +!> Initialize model compiler flags +subroutine new_compiler_flags(model,settings) + type(fpm_model_t), intent(inout) :: model + type(fpm_build_settings), intent(in) :: settings + + character(len=:), allocatable :: flags, cflags, cxxflags, ldflags + + if (settings%flag == '') then + flags = model%compiler%get_default_flags(settings%profile == "release") + else + flags = settings%flag + select case(settings%profile) + case("release", "debug") + flags = flags // model%compiler%get_default_flags(settings%profile == "release") + end select + end if + + cflags = trim(settings%cflag) + cxxflags = trim(settings%cxxflag) + ldflags = trim(settings%ldflag) + + model%fortran_compile_flags = flags + model%c_compile_flags = cflags + model%cxx_compile_flags = cxxflags + model%link_flags = ldflags + +end subroutine new_compiler_flags + +! Check for duplicate modules +subroutine check_modules_for_duplicates(model, duplicates_found) + type(fpm_model_t), intent(in) :: model + integer :: maxsize + integer :: i,j,k,l,m,modi + type(string_t), allocatable :: modules(:) + logical :: duplicates_found + ! Initialise the size of array + maxsize = 0 + ! Get number of modules provided by each source file of every package + do i=1,size(model%packages) + do j=1,size(model%packages(i)%sources) + if (allocated(model%packages(i)%sources(j)%modules_provided)) then + maxsize = maxsize + size(model%packages(i)%sources(j)%modules_provided) + end if + end do + end do + ! Allocate array to contain distinct names of modules + allocate(modules(maxsize)) + + ! Initialise index to point at start of the newly allocated array + modi = 1 + + ! Loop through modules provided by each source file of every package + ! Add it to the array if it is not already there + ! Otherwise print out warning about duplicates + do k=1,size(model%packages) + do l=1,size(model%packages(k)%sources) + if (allocated(model%packages(k)%sources(l)%modules_provided)) then + do m=1,size(model%packages(k)%sources(l)%modules_provided) + if (model%packages(k)%sources(l)%modules_provided(m)%s.in.modules(:modi-1)) then + write(stderr, *) "Warning: Module ",model%packages(k)%sources(l)%modules_provided(m)%s, & + " in ",model%packages(k)%sources(l)%file_name," is a duplicate" + duplicates_found = .true. + else + modules(modi) = model%packages(k)%sources(l)%modules_provided(m) + modi = modi + 1 + end if + end do + end if + end do + end do +end subroutine check_modules_for_duplicates + +! Check names of all modules in this package and its dependencies +subroutine check_module_names(model, error) + type(fpm_model_t), intent(in) :: model + type(error_t), allocatable, intent(out) :: error + integer :: k,l,m + logical :: valid,errors_found,enforce_this_file + type(string_t) :: package_name,module_name,package_prefix + + errors_found = .false. + + ! Loop through modules provided by each source file of every package + ! Add it to the array if it is not already there + ! Otherwise print out warning about duplicates + do k=1,size(model%packages) + + package_name = string_t(model%packages(k)%name) + + ! Custom prefix is taken from each dependency's manifest + if (model%packages(k)%enforce_module_names) then + package_prefix = model%packages(k)%module_prefix + else + package_prefix = string_t("") + end if + + ! Warn the user if some of the dependencies have loose naming + if (model%enforce_module_names .and. .not.model%packages(k)%enforce_module_names) then + write(stderr, *) "Warning: Dependency ",package_name%s // & + " does not enforce module naming, but project does. " + end if + + do l=1,size(model%packages(k)%sources) + + ! Module naming is not enforced in test modules + enforce_this_file = model%enforce_module_names .and. & + model%packages(k)%sources(l)%unit_scope/=FPM_SCOPE_TEST + + if (allocated(model%packages(k)%sources(l)%modules_provided)) then + + do m=1,size(model%packages(k)%sources(l)%modules_provided) + + module_name = model%packages(k)%sources(l)%modules_provided(m) + + valid = is_valid_module_name(module_name, & + package_name, & + package_prefix, & + enforce_this_file) + + if (.not.valid) then + + if (enforce_this_file) then + + if (len_trim(package_prefix)>0) then + + write(stderr, *) "ERROR: Module ",module_name%s, & + " in ",model%packages(k)%sources(l)%file_name, & + " does not match its package name ("//package_name%s// & + ") or custom prefix ("//package_prefix%s//")." + else + + write(stderr, *) "ERROR: Module ",module_name%s, & + " in ",model%packages(k)%sources(l)%file_name, & + " does not match its package name ("//package_name%s//")." + + endif + + else + + write(stderr, *) "ERROR: Module ",module_name%s, & + " in ",model%packages(k)%sources(l)%file_name, & + " has an invalid Fortran name. " + + end if + + errors_found = .true. + + end if + end do + end if + end do + end do + + if (errors_found) then + + if (model%enforce_module_names) & + write(stderr, *) " Hint: Try disabling module naming in the manifest: [build] module-naming=false . " + + call fatal_error(error,"The package contains invalid module names. "// & + "Naming conventions "//merge('are','not',model%enforce_module_names)// & + " being requested.") + end if + +end subroutine check_module_names + +subroutine cmd_build(settings) +type(fpm_build_settings), intent(inout) :: settings + +type(package_config_t) :: package +type(fpm_model_t) :: model +type(build_target_ptr), allocatable :: targets(:) +type(error_t), allocatable :: error + +integer :: i + +call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) +if (allocated(error)) then + call fpm_stop(1,'*cmd_build* Package error: '//error%message) +end if + +call build_model(model, settings, package, error) +if (allocated(error)) then + call fpm_stop(1,'*cmd_build* Model error: '//error%message) +end if + +call targets_from_sources(targets, model, settings%prune, error) +if (allocated(error)) then + call fpm_stop(1,'*cmd_build* Target error: '//error%message) +end if + +!> Dump model to file +if (len_trim(settings%dump)>0) then + call model%dump(trim(settings%dump),error,json=name_is_json(trim(settings%dump))) + if (allocated(error)) call fpm_stop(1,'*cmd_build* Model dump error: '//error%message) +endif + +if(settings%list)then + do i=1,size(targets) + write(stderr,*) targets(i)%ptr%output_file + enddo +else if (settings%show_model) then + call show_model(model) +else + call build_package(targets,model,verbose=settings%verbose) +endif + +end subroutine cmd_build + +subroutine cmd_run(settings,test) + class(fpm_run_settings), intent(inout) :: settings + logical, intent(in) :: test + + integer :: i, j, col_width + logical :: found(size(settings%name)) + type(error_t), allocatable :: error + type(package_config_t) :: package + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + type(string_t) :: exe_cmd + type(string_t), allocatable :: executables(:) + type(build_target_t), pointer :: exe_target + type(srcfile_t), pointer :: exe_source + integer :: run_scope,firsterror + integer, allocatable :: stat(:),target_ID(:) + character(len=:),allocatable :: line + + call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) + if (allocated(error)) then + call fpm_stop(1, '*cmd_run* Package error: '//error%message) + end if + + call build_model(model, settings, package, error) + if (allocated(error)) then + call fpm_stop(1, '*cmd_run* Model error: '//error%message) + end if + + call targets_from_sources(targets, model, settings%prune, error) + if (allocated(error)) then + call fpm_stop(1, '*cmd_run* Targets error: '//error%message) + end if + + if (test) then + run_scope = FPM_SCOPE_TEST + else + run_scope = merge(FPM_SCOPE_EXAMPLE, FPM_SCOPE_APP, settings%example) + end if + + ! Enumerate executable targets to run + col_width = -1 + found(:) = .false. + allocate(executables(size(targets)),target_ID(size(targets))) + enumerate: do i=1,size(targets) + exe_target => targets(i)%ptr + if (should_be_run(settings,run_scope,exe_target)) then + + exe_source => exe_target%dependencies(1)%ptr%source + + col_width = max(col_width,len(basename(exe_target%output_file))+2) + + ! Priority by name ID, or 0 if no name present (run first) + j = settings%name_ID(exe_source%exe_name) + target_ID(i) = j + if (j>0) found(j) = .true. + + exe_cmd%s = exe_target%output_file + executables(i) = exe_cmd + + else + target_ID(i) = huge(target_ID(i)) + endif + end do enumerate + + ! sort executables by ascending name ID, resize + call sort_executables(target_ID,executables) + + ! Check if any apps/tests were found + if (col_width < 0) then + if (test) then + call fpm_stop(0,'No tests to run') + else + call fpm_stop(0,'No executables to run') + end if + end if + + ! Check all names are valid + ! or no name and found more than one file + if ( any(.not.found) ) then + line=join(settings%name) + if(line/='.')then ! do not report these special strings + if(any(.not.found))then + write(stderr,'(A)',advance="no")'*cmd_run*:specified names ' + do j=1,size(settings%name) + if (.not.found(j)) write(stderr,'(A)',advance="no") '"'//trim(settings%name(j))//'" ' + end do + write(stderr,'(A)') 'not found.' + write(stderr,*) + else if(settings%verbose)then + write(stderr,'(A)',advance="yes")'when more than one executable is available' + write(stderr,'(A)',advance="yes")' program names must be specified.' + endif + endif + + call compact_list_all() + + if(line=='.' .or. line==' ')then ! do not report these special strings + call fpm_stop(0,'') + else + call fpm_stop(1,'') + endif + + end if + + call build_package(targets,model,verbose=settings%verbose) + + if (settings%list) then + call compact_list() + else + + allocate(stat(size(executables))) + do i=1,size(executables) + if (exists(executables(i)%s)) then + if(settings%runner /= ' ')then + if(.not.allocated(settings%args))then + call run(settings%runner_command()//' '//executables(i)%s, & + echo=settings%verbose, exitstat=stat(i)) + else + call run(settings%runner_command()//' '//executables(i)%s//" "//settings%args, & + echo=settings%verbose, exitstat=stat(i)) + endif + else + if(.not.allocated(settings%args))then + call run(executables(i)%s,echo=settings%verbose, exitstat=stat(i)) + else + call run(executables(i)%s//" "//settings%args,echo=settings%verbose, & + exitstat=stat(i)) + endif + endif + else + call fpm_stop(1,'*cmd_run*:'//executables(i)%s//' not found') + end if + end do + + if (any(stat /= 0)) then + do i=1,size(stat) + if (stat(i) /= 0) then + write(stderr,'(*(g0:,1x))') ' Execution for object "',basename(executables(i)%s),& + '" returned exit code ',stat(i) + end if + end do + firsterror = findloc(stat/=0,value=.true.,dim=1) + call fpm_stop(stat(firsterror),'*cmd_run*:stopping due to failed executions') + end if + + end if + + contains + + subroutine compact_list_all() + integer, parameter :: LINE_WIDTH = 80 + integer :: ii, jj, nCol + jj = 1 + nCol = LINE_WIDTH/col_width + write(stderr,*) 'Available names:' + do ii=1,size(targets) + + exe_target => targets(ii)%ptr + + if (exe_target%target_type == FPM_TARGET_EXECUTABLE .and. & + allocated(exe_target%dependencies)) then + + exe_source => exe_target%dependencies(1)%ptr%source + + if (exe_source%unit_scope == run_scope) then + write(stderr,'(A)',advance=(merge("yes","no ",modulo(jj,nCol)==0))) & + & [character(len=col_width) :: basename(exe_target%output_file, suffix=.false.)] + jj = jj + 1 + end if + end if + end do + write(stderr,*) + end subroutine compact_list_all + + subroutine compact_list() + integer, parameter :: LINE_WIDTH = 80 + integer :: ii, jj, nCol + jj = 1 + nCol = LINE_WIDTH/col_width + write(stderr,*) 'Matched names:' + do ii=1,size(executables) + write(stderr,'(A)',advance=(merge("yes","no ",modulo(jj,nCol)==0))) & + & [character(len=col_width) :: basename(executables(ii)%s, suffix=.false.)] + jj = jj + 1 + end do + write(stderr,*) + end subroutine compact_list + +end subroutine cmd_run + +subroutine delete_skip(is_unix) + !> delete directories in the build folder, skipping dependencies + logical, intent(in) :: is_unix + character(len=:), allocatable :: dir + type(string_t), allocatable :: files(:) + integer :: i + call list_files('build', files, .false.) + do i = 1, size(files) + if (is_dir(files(i)%s)) then + dir = files(i)%s + if (.not.str_ends_with(dir,'dependencies')) call os_delete_dir(is_unix, dir) + end if + end do +end subroutine delete_skip + +!> Delete the build directory including or excluding dependencies. Can be used +!> to clear the registry cache. +subroutine cmd_clean(settings) + !> Settings for the clean command. + class(fpm_clean_settings), intent(in) :: settings + + character :: user_response + type(fpm_global_settings) :: global_settings + type(error_t), allocatable :: error + + ! Clear registry cache + if (settings%registry_cache) then + call get_global_settings(global_settings, error) + if (allocated(error)) return + + call os_delete_dir(os_is_unix(), global_settings%registry_settings%cache_path) + end if + + if (is_dir('build')) then + ! Remove the entire build directory + if (settings%clean_all) then + call os_delete_dir(os_is_unix(), 'build'); return + ! Remove the build directory but skip dependencies + else if (settings%clean_skip) then + call delete_skip(os_is_unix()); return + end if + + ! Prompt to remove the build directory but skip dependencies + write(stdout, '(A)', advance='no') "Delete build, excluding dependencies (y/n)? " + read(stdin, '(A1)') user_response + if (lower(user_response) == 'y') call delete_skip(os_is_unix()) + else + write (stdout, '(A)') "fpm: No build directory found." + end if +end subroutine cmd_clean + +!> Sort executables by namelist ID, and trim unused values +pure subroutine sort_executables(target_ID,executables) + integer, allocatable, intent(inout) :: target_ID(:) + type(string_t), allocatable, intent(inout) :: executables(:) + + integer :: i,j,n,used + + n = size(target_ID) + used = 0 + + sort: do i=1,n + do j=i+1,n + if (target_ID(j)0 .and. used Check if an executable should be run +logical function should_be_run(settings,run_scope,exe_target) + class(fpm_run_settings), intent(in) :: settings + integer, intent(in) :: run_scope + type(build_target_t), intent(in) :: exe_target + + integer :: j + + if (exe_target%is_executable_target(run_scope)) then + + associate(exe_source => exe_target%dependencies(1)%ptr%source) + + if (exe_source%unit_scope/=run_scope) then + + ! Other scope + should_be_run = .false. + + elseif (size(settings%name) == 0 .or. settings%list) then + + ! Run all or list all + should_be_run = .true. + + else + + ! Is found in list + should_be_run = settings%name_ID(exe_source%exe_name)>0 + + end if + + end associate + + else + + !> Invalid target + should_be_run = .false. + + endif + +end function should_be_run + +end module fpm + +!>>>>> ././src/fpm/cmd/export.f90 + +module fpm_cmd_export + use fpm_command_line, only : fpm_export_settings + use fpm_dependency, only : dependency_tree_t, new_dependency_tree + use fpm_error, only : error_t, fpm_stop + use fpm_filesystem, only : join_path + use fpm_manifest, only : package_config_t, get_package_data + use fpm_toml, only: name_is_json + use fpm_model, only: fpm_model_t + use fpm, only: build_model + implicit none + private + public :: cmd_export + +contains + + !> Entry point for the export subcommand + subroutine cmd_export(settings) + !> Representation of the command line arguments + type(fpm_export_settings), intent(inout) :: settings + type(package_config_t) :: package + type(dependency_tree_t) :: deps + type(fpm_model_t) :: model + type(error_t), allocatable :: error + + integer :: ii + character(len=:), allocatable :: filename + + if (len_trim(settings%dump_manifest)<=0 .and. & + len_trim(settings%dump_model)<=0 .and. & + len_trim(settings%dump_dependencies)<=0) then + call fpm_stop(0,'*cmd_export* exiting: no manifest/model/dependencies keyword provided') + end if + + !> Read in manifest + call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) + call handle_error(error) + + !> Export manifest + if (len_trim(settings%dump_manifest)>0) then + filename = trim(settings%dump_manifest) + call package%dump(filename, error, json=name_is_json(filename)) + end if + + !> Export dependency tree + if (len_trim(settings%dump_dependencies)>0) then + + !> Generate dependency tree + filename = join_path("build", "cache.toml") + call new_dependency_tree(deps, cache=filename, verbosity=merge(2, 1, settings%verbose)) + call deps%add(package, error) + call handle_error(error) + + !> Export dependency tree + filename = settings%dump_dependencies + call deps%dump(filename, error, json=name_is_json(filename)) + call handle_error(error) + end if + + !> Export full model + if (len_trim(settings%dump_model)>0) then + + call build_model(model, settings%fpm_build_settings, package, error) + if (allocated(error)) then + call fpm_stop(1,'*cmd_export* Model error: '//error%message) + end if + + filename = settings%dump_model + call model%dump(filename, error, json=name_is_json(filename)) + call handle_error(error) + end if + + end subroutine cmd_export + + !> Error handling for this command + subroutine handle_error(error) + !> Potential error + type(error_t), intent(in), optional :: error + if (present(error)) then + call fpm_stop(1, '*cmd_export* error: '//error%message) + end if + end subroutine handle_error + +end module fpm_cmd_export + +!>>>>> ././src/fpm/cmd/install.f90 + +module fpm_cmd_install + use, intrinsic :: iso_fortran_env, only : output_unit + use fpm, only : build_model + use fpm_backend, only : build_package + use fpm_command_line, only : fpm_install_settings + use fpm_error, only : error_t, fatal_error, fpm_stop + use fpm_filesystem, only : join_path, list_files + use fpm_installer, only : installer_t, new_installer + use fpm_manifest, only : package_config_t, get_package_data + use fpm_model, only : fpm_model_t, FPM_SCOPE_APP, FPM_SCOPE_TEST + use fpm_targets, only: targets_from_sources, build_target_t, & + build_target_ptr, FPM_TARGET_EXECUTABLE, & + filter_library_targets, filter_executable_targets, filter_modules + use fpm_strings, only : string_t, resize + implicit none + private + + public :: cmd_install + +contains + + !> Entry point for the fpm-install subcommand + subroutine cmd_install(settings) + !> Representation of the command line settings + type(fpm_install_settings), intent(inout) :: settings + type(package_config_t) :: package + type(error_t), allocatable :: error + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + type(installer_t) :: installer + type(string_t), allocatable :: list(:) + logical :: installable + integer :: ntargets + + call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) + call handle_error(error) + + call build_model(model, settings, package, error) + call handle_error(error) + + call targets_from_sources(targets, model, settings%prune, error) + call handle_error(error) + + call install_info(output_unit, settings%list, targets, ntargets) + if (settings%list) return + + installable = (allocated(package%library) .and. package%install%library) & + .or. allocated(package%executable) .or. ntargets>0 + + if (.not.installable) then + call fatal_error(error, "Project does not contain any installable targets") + call handle_error(error) + end if + + if (.not.settings%no_rebuild) then + call build_package(targets,model,verbose=settings%verbose) + end if + + call new_installer(installer, prefix=settings%prefix, & + bindir=settings%bindir, libdir=settings%libdir, testdir=settings%testdir, & + includedir=settings%includedir, & + verbosity=merge(2, 1, settings%verbose)) + + if (allocated(package%library) .and. package%install%library) then + call filter_library_targets(targets, list) + + if (size(list) > 0) then + call installer%install_library(list(1)%s, error) + call handle_error(error) + + call install_module_files(installer, targets, error) + call handle_error(error) + end if + end if + + if (allocated(package%executable) .or. ntargets>0) then + call install_executables(installer, targets, error) + call handle_error(error) + end if + + if (allocated(package%test) .and. (package%install%test .or. model%include_tests)) then + + call install_tests(installer, targets, error) + call handle_error(error) + + end if + + end subroutine cmd_install + + subroutine install_info(unit, verbose, targets, ntargets) + integer, intent(in) :: unit + logical, intent(in) :: verbose + type(build_target_ptr), intent(in) :: targets(:) + integer, intent(out) :: ntargets + + integer :: ii + type(string_t), allocatable :: install_target(:), temp(:) + + allocate(install_target(0)) + + call filter_library_targets(targets, temp) + install_target = [install_target, temp] + + call filter_executable_targets(targets, FPM_SCOPE_APP, temp) + install_target = [install_target, temp] + + call filter_executable_targets(targets, FPM_SCOPE_TEST, temp) + install_target = [install_target, temp] + + ntargets = size(install_target) + + if (verbose) then + + write(unit, '("#", *(1x, g0))') & + "total number of installable targets:", ntargets + do ii = 1, ntargets + write(unit, '("-", *(1x, g0))') install_target(ii)%s + end do + + endif + + end subroutine install_info + + subroutine install_module_files(installer, targets, error) + type(installer_t), intent(inout) :: installer + type(build_target_ptr), intent(in) :: targets(:) + type(error_t), allocatable, intent(out) :: error + type(string_t), allocatable :: modules(:) + integer :: ii + + call filter_modules(targets, modules) + + do ii = 1, size(modules) + call installer%install_header(modules(ii)%s//".mod", error) + if (allocated(error)) exit + end do + if (allocated(error)) return + + end subroutine install_module_files + + subroutine install_executables(installer, targets, error) + type(installer_t), intent(inout) :: installer + type(build_target_ptr), intent(in) :: targets(:) + type(error_t), allocatable, intent(out) :: error + integer :: ii + + do ii = 1, size(targets) + if (targets(ii)%ptr%is_executable_target(FPM_SCOPE_APP)) then + call installer%install_executable(targets(ii)%ptr%output_file, error) + if (allocated(error)) exit + end if + end do + if (allocated(error)) return + + end subroutine install_executables + + subroutine install_tests(installer, targets, error) + type(installer_t), intent(inout) :: installer + type(build_target_ptr), intent(in) :: targets(:) + type(error_t), allocatable, intent(out) :: error + integer :: ii + + do ii = 1, size(targets) + if (targets(ii)%ptr%is_executable_target(FPM_SCOPE_TEST)) then + call installer%install_test(targets(ii)%ptr%output_file, error) + if (allocated(error)) exit + end if + end do + if (allocated(error)) return + + end subroutine install_tests + + subroutine handle_error(error) + type(error_t), intent(in), optional :: error + if (present(error)) then + call fpm_stop(1,'*cmd_install* error: '//error%message) + end if + end subroutine handle_error + +end module fpm_cmd_install + +!>>>>> ././src/fpm/cmd/publish.f90 + +!> Upload a package to the registry using the `publish` command. +!> +!> To upload a package you need to provide a token that will be linked to your username and created for a namespace. +!> The token can be obtained from the registry website. It can be used as `fpm publish --token `. +module fpm_cmd_publish + use fpm_command_line, only: fpm_publish_settings + use fpm_manifest, only: package_config_t, get_package_data + use fpm_model, only: fpm_model_t + use fpm_error, only: error_t, fpm_stop + use fpm_versioning, only: version_t + use fpm_filesystem, only: exists, join_path, get_temp_filename, delete_file + use fpm_git, only: git_archive + use fpm_downloader, only: downloader_t + use fpm_strings, only: string_t + use fpm_settings, only: official_registry_base_url + use fpm, only: build_model + + implicit none + private + public :: cmd_publish + +contains + + !> The `publish` command first builds the root package to obtain all the relevant information such as the + !> package version. It then creates a tarball of the package and uploads it to the registry. + subroutine cmd_publish(settings) + type(fpm_publish_settings), intent(inout) :: settings + + type(package_config_t) :: package + type(fpm_model_t) :: model + type(error_t), allocatable :: error + type(version_t), allocatable :: version + type(string_t), allocatable :: upload_data(:) + character(len=:), allocatable :: tmp_file + type(downloader_t) :: downloader + integer :: i + + ! Get package data to determine package version. + call get_package_data(package, 'fpm.toml', error, apply_defaults=.true.) + if (allocated(error)) call fpm_stop(1, '*cmd_build* Package error: '//error%message) + version = package%version + + if (settings%show_package_version) then + print *, version%s(); return + end if + + !> Checks before uploading the package. + if (.not. allocated(package%license)) call fpm_stop(1, 'No license specified in fpm.toml.') + if (.not. package%build%module_naming) call fpm_stop(1, 'The package does not meet the module naming requirements. '// & + & 'Please set "module-naming = true" in fpm.toml [build] or specify a custom module prefix.') + if (.not. allocated(version)) call fpm_stop(1, 'No version specified in fpm.toml.') + if (version%s() == '0') call fpm_stop(1, 'Invalid version: "'//version%s()//'".') + if (.not. exists('fpm.toml')) call fpm_stop(1, "Cannot find 'fpm.toml' file. Are you in the project root?") + + ! Build model to obtain dependency tree. + call build_model(model, settings%fpm_build_settings, package, error) + if (allocated(error)) call fpm_stop(1, '*cmd_build* Model error: '//error%message) + + ! Check if package contains git dependencies. Only publish packages without git dependencies. + do i = 1, model%deps%ndep + if (allocated(model%deps%dep(i)%git)) then + call fpm_stop(1, 'Do not publish packages containing git dependencies. '// & + & "Please upload '"//model%deps%dep(i)%name//"' to the registry first.") + end if + end do + + tmp_file = get_temp_filename() + call git_archive('.', tmp_file, 'HEAD', additional_files=['fpm_model.json'], verbose=settings%verbose, error=error) + if (allocated(error)) call fpm_stop(1, '*cmd_publish* Archive error: '//error%message) + call model%dump('fpm_model.json', error, json=.true.) + if (allocated(error)) call fpm_stop(1, '*cmd_publish* Model dump error: '//error%message) + + upload_data = [ & + & string_t('package_name="'//package%name//'"'), & + & string_t('package_license="'//package%license//'"'), & + & string_t('package_version="'//version%s()//'"'), & + & string_t('tarball=@"'//tmp_file//'"') & + & ] + + if (allocated(settings%token)) upload_data = [upload_data, string_t('upload_token="'//settings%token//'"')] + + if (settings%show_upload_data) then + call print_upload_data(upload_data); return + end if + + ! Make sure a token is provided for publishing. + if (allocated(settings%token)) then + if (settings%token == '') then + call delete_file(tmp_file); call fpm_stop(1, 'No token provided.') + end if + else + call delete_file(tmp_file); call fpm_stop(1, 'No token provided.') + end if + + if (settings%verbose) then + call print_upload_data(upload_data) + print *, '' + end if + + ! Perform network request and validate package, token etc. on the backend once + ! https://github.com/fortran-lang/registry/issues/41 is resolved. + if (settings%is_dry_run) then + print *, 'Dry run successful. Generated tarball: ', tmp_file; return + end if + + call downloader%upload_form(official_registry_base_url//'/packages', upload_data, settings%verbose, error) + call delete_file(tmp_file) + if (allocated(error)) call fpm_stop(1, '*cmd_publish* Upload error: '//error%message) + end + + subroutine print_upload_data(upload_data) + type(string_t), intent(in) :: upload_data(:) + integer :: i + + print *, 'Upload data:' + do i = 1, size(upload_data) + print *, upload_data(i)%s + end do + end +end + +!>>>>> app/main.f90 + +program main +use, intrinsic :: iso_fortran_env, only : error_unit, output_unit +use fpm_command_line, only: & + fpm_cmd_settings, & + fpm_new_settings, & + fpm_build_settings, & + fpm_export_settings, & + fpm_run_settings, & + fpm_test_settings, & + fpm_install_settings, & + fpm_update_settings, & + fpm_clean_settings, & + fpm_publish_settings, & + get_command_line_settings +use fpm_error, only: error_t +use fpm_filesystem, only: exists, parent_dir, join_path +use fpm, only: cmd_build, cmd_run, cmd_clean +use fpm_cmd_install, only: cmd_install +use fpm_cmd_export, only: cmd_export +use fpm_cmd_new, only: cmd_new +use fpm_cmd_update, only : cmd_update +use fpm_cmd_publish, only: cmd_publish +use fpm_os, only: change_directory, get_current_directory + +implicit none + +class(fpm_cmd_settings), allocatable :: cmd_settings +type(error_t), allocatable :: error +character(len=:), allocatable :: pwd_start, pwd_working, working_dir, project_root + +call get_command_line_settings(cmd_settings) + +call get_current_directory(pwd_start, error) +call handle_error(error) + +call get_working_dir(cmd_settings, working_dir) +if (allocated(working_dir)) then + ! Change working directory if requested + if (len_trim(working_dir) > 0) then + call change_directory(working_dir, error) + call handle_error(error) + + call get_current_directory(pwd_working, error) + call handle_error(error) + write(output_unit, '(*(a))') "fpm: Entering directory '"//pwd_working//"'" + else + pwd_working = pwd_start + end if +else + pwd_working = pwd_start +end if + +select type (settings => cmd_settings) +type is (fpm_new_settings) +class default + if (.not.has_manifest(pwd_working)) then + project_root = pwd_working + do while(.not.has_manifest(project_root)) + working_dir = parent_dir(project_root) + if (len(working_dir) == 0) exit + project_root = working_dir + end do + + if (has_manifest(project_root)) then + call change_directory(project_root, error) + call handle_error(error) + write(output_unit, '(*(a))') "fpm: Entering directory '"//project_root//"'" + end if + end if +end select + +select type(settings=>cmd_settings) +type is (fpm_new_settings) + call cmd_new(settings) +type is (fpm_build_settings) + call cmd_build(settings) +type is (fpm_run_settings) + call cmd_run(settings,test=.false.) +type is (fpm_test_settings) + call cmd_run(settings,test=.true.) +type is (fpm_export_settings) + call cmd_export(settings) +type is (fpm_install_settings) + call cmd_install(settings) +type is (fpm_update_settings) + call cmd_update(settings) +type is (fpm_clean_settings) + call cmd_clean(settings) +type is (fpm_publish_settings) + call cmd_publish(settings) +end select + +if (allocated(project_root)) then + write(output_unit, '(*(a))') "fpm: Leaving directory '"//project_root//"'" +end if + +if (pwd_start /= pwd_working) then + write(output_unit, '(*(a))') "fpm: Leaving directory '"//pwd_working//"'" +end if + +contains + + function has_manifest(dir) + character(len=*), intent(in) :: dir + logical :: has_manifest + + has_manifest = exists(join_path(dir, "fpm.toml")) + end function has_manifest + + subroutine handle_error(error_) + type(error_t), optional, intent(in) :: error_ + if (present(error_)) then + write (error_unit, '("[Error]", 1x, a)') error_%message + stop 1 + end if + end subroutine handle_error + + !> Save access to working directory in settings, in case setting have not been allocated + subroutine get_working_dir(settings, working_dir_) + class(fpm_cmd_settings), optional, intent(in) :: settings + character(len=:), allocatable, intent(out) :: working_dir_ + if (present(settings)) then + working_dir_ = settings%working_dir + end if + end subroutine get_working_dir + +end program main + diff --git a/fpm.toml b/fpm.toml new file mode 100644 index 00000000..7c442394 --- /dev/null +++ b/fpm.toml @@ -0,0 +1,19 @@ +name = "ttb" +version = "1.2.1" +license = "MIT" +author = "Andreas Dutzler" +maintainer = "@" +copyright = "Copyright 2024, Andreas Dutzler" +[build] + auto-executables = true + auto-tests = true + auto-examples = true + module-naming = false +[install] + library = false + test = false +[fortran] + implicit-typing = false + implicit-external = false + source-form = "free" + diff --git a/src/libadd.finc b/src/libadd.finc new file mode 100644 index 00000000..70de8338 --- /dev/null +++ b/src/libadd.finc @@ -0,0 +1,84 @@ +function add_11(T1, T2) + + type(Tensor1), intent(in) :: T1, T2 + type(Tensor1) :: add_11 + + add_11%a = T1%a + T2%a + +end function add_11 + +function add_22(T1, T2) + + type(Tensor2), intent(in) :: T1, T2 + type(Tensor2) :: add_22 + + add_22%ab = T1%ab + T2%ab + +end function add_22 + +function add_2s2s(T1, T2) + + type(Tensor2s), intent(in) :: T1, T2 + type(Tensor2s) :: add_2s2s + + add_2s2s%a6 = T1%a6 + T2%a6 + +end function add_2s2s + +function add_22s(T1, T2) + + type(Tensor2), intent(in) :: T1 + type(Tensor2s), intent(in) :: T2 + type(Tensor2) :: add_22s + + add_22s = T1 + astensor(T2) + +end function add_22s + +function add_2s2(T1, T2) + + type(Tensor2s), intent(in) :: T1 + type(Tensor2), intent(in) :: T2 + type(Tensor2) :: add_2s2 + + add_2s2 = astensor(T1) + T2 + +end function add_2s2 + +function add_44(T1, T2) + + type(Tensor4), intent(in) :: T1, T2 + type(Tensor4) :: add_44 + + add_44%abcd = T1%abcd + T2%abcd + +end function add_44 + +function add_4s4s(T1, T2) + + type(Tensor4s), intent(in) :: T1, T2 + type(Tensor4s) :: add_4s4s + + add_4s4s%a6b6 = T1%a6b6 + T2%a6b6 + +end function add_4s4s + +function add_44s(T1, T2) + + type(Tensor4), intent(in) :: T1 + type(Tensor4s), intent(in) :: T2 + type(Tensor4) :: add_44s + + add_44s = T1 + astensor(T2) + +end function add_44s + +function add_4s4(T1, T2) + + type(Tensor4s), intent(in) :: T1 + type(Tensor4), intent(in) :: T2 + type(Tensor4) :: add_4s4 + + add_4s4 = astensor(T1) + T2 + +end function add_4s4 diff --git a/src/libasabqarray.finc b/src/libasabqarray.finc new file mode 100644 index 00000000..b190b9a8 --- /dev/null +++ b/src/libasabqarray.finc @@ -0,0 +1,34 @@ +! ------AS ABAQUS ARRAY SECTION------------------- +function asabqarray_2s(T,i,j) + + type(Tensor2s), intent(in) :: T + integer, intent(in) :: i + integer, intent(in), optional :: j + real(kind=wp), dimension(i) :: asabqarray_2s + integer :: i1 + + asabqarray_2s(1:min(i,4)) = T%a6(1:min(i,4)) + + if (i.ge.5) then + asabqarray_2s(5) = T%a6(6) + end if + + if (i.ge.6) then + asabqarray_2s(6) = T%a6(5) + endif + +end function asabqarray_2s + +function asabqarray_4s(T,i,j) + + type(Tensor4s), intent(in) :: T + integer, intent(in) :: i,j + real(kind=wp), dimension(i,j) :: asabqarray_4s + integer, dimension(6) :: imap + integer :: i1,j1 + + imap = (/1,2,3,4,6,5/) + + forall (i1=1:i,j1=1:j) asabqarray_4s(i1,j1) = T%a6b6(imap(i1),imap(j1)) + +end function asabqarray_4s diff --git a/src/libasarray.finc b/src/libasarray.finc new file mode 100644 index 00000000..6598db77 --- /dev/null +++ b/src/libasarray.finc @@ -0,0 +1,54 @@ +! ------AS ARRAY SECTION------------------------------------ +function asarray_1(T,i,j,k,l) + + type(Tensor1), intent(in) :: T + integer, intent(in) :: i + integer, intent(in), optional :: j,k,l + real(kind=wp), dimension(i) :: asarray_1 + + asarray_1 = T%a(1:i) + +end function asarray_1 + +function asarray_2(T,i,j,k,l) + + type(Tensor2), intent(in) :: T + integer, intent(in) :: i,j + integer, intent(in), optional :: k,l + real(kind=wp), dimension(i,j) :: asarray_2 + + asarray_2 = T%ab(1:i,1:j) + +end function asarray_2 + +function asarray_2s(T,i,j,k,l) + + type(Tensor2s), intent(in) :: T + integer, intent(in) :: i + integer, intent(in), optional :: j,k,l + real(kind=wp), dimension(i) :: asarray_2s + + asarray_2s = T%a6(1:i) + +end function asarray_2s + +function asarray_4(T,i,j,k,l) + + type(Tensor4), intent(in) :: T + integer, intent(in) :: i,j,k,l + real(kind=wp), dimension(i,j,k,l) :: asarray_4 + + asarray_4 = T%abcd(1:i,1:j,1:k,1:l) + +end function asarray_4 + +function asarray_4s(T,i,j,k,l) + + type(Tensor4s), intent(in) :: T + integer, intent(in) :: i,j + integer, intent(in), optional :: k,l + real(kind=wp), dimension(i,j) :: asarray_4s + + asarray_4s = T%a6b6(1:i,1:j) + +end function asarray_4s diff --git a/src/libassignarray.finc b/src/libassignarray.finc new file mode 100644 index 00000000..a228ee9d --- /dev/null +++ b/src/libassignarray.finc @@ -0,0 +1,89 @@ +subroutine assignarr_2s(T,A) + + type(Tensor2s), intent(inout) :: T + real(kind=wp), dimension(6), intent(in) :: A + + T%a6 = A + +end subroutine assignarr_2s + +subroutine assignarr_2sr4(T,A) + + type(Tensor2s), intent(inout) :: T + real(kind=4), dimension(6), intent(in) :: A + + T%a6 = dble(A) + +end subroutine assignarr_2sr4 + +subroutine assignarr_4s(T,A) + + type(Tensor4s), intent(inout) :: T + real(kind=wp), dimension(6,6), intent(in) :: A + + T%a6b6 = A + +end subroutine assignarr_4s + +subroutine assignarr_4sr4(T,A) + + type(Tensor4s), intent(inout) :: T + real(kind=4), dimension(6,6), intent(in) :: A + + T%a6b6 = dble(A) + +end subroutine assignarr_4sr4 + +subroutine assignarr_1(T,A) + + type(Tensor1), intent(inout) :: T + real(kind=wp), dimension(3), intent(in) :: A + + T%a = A + +end subroutine assignarr_1 + +subroutine assignarr_1r4(T,A) + + type(Tensor1), intent(inout) :: T + real(kind=4), dimension(3), intent(in) :: A + + T%a = dble(A) + +end subroutine assignarr_1r4 + +subroutine assignarr_2(T,A) + + type(Tensor2), intent(inout) :: T + real(kind=wp), dimension(3,3), intent(in) :: A + + T%ab = A + +end subroutine assignarr_2 + +subroutine assignarr_2r4(T,A) + + type(Tensor2), intent(inout) :: T + real(kind=4), dimension(3,3), intent(in) :: A + + T%ab = dble(A) + +end subroutine assignarr_2r4 + +subroutine assignarr_4(T,A) + + type(Tensor4), intent(inout) :: T + real(kind=wp), dimension(3,3,3,3), intent(in) :: A + + T%abcd = A + +end subroutine assignarr_4 + +subroutine assignarr_4r4(T,A) + + type(Tensor4), intent(inout) :: T + real(kind=4), dimension(3,3,3,3), intent(in) :: A + + T%abcd = dble(A) + +end subroutine assignarr_4r4 diff --git a/src/libassignscalar.finc b/src/libassignscalar.finc new file mode 100644 index 00000000..cc7bf7da --- /dev/null +++ b/src/libassignscalar.finc @@ -0,0 +1,89 @@ +subroutine assignscalar_2s(T,w) + + type(Tensor2s), intent(inout) :: T + real(kind=wp), intent(in) :: w + + T%a6 = w + +end subroutine assignscalar_2s + +subroutine assignscalar_2sr4(T,w) + + type(Tensor2s), intent(inout) :: T + real(kind=4), intent(in) :: w + + T%a6 = dble(w) + +end subroutine assignscalar_2sr4 + +subroutine assignscalar_4s(T,w) + + type(Tensor4s), intent(inout) :: T + real(kind=wp), intent(in) :: w + + T%a6b6 = w + +end subroutine assignscalar_4s + +subroutine assignscalar_4sr4(T,w) + + type(Tensor4s), intent(inout) :: T + real(kind=4), intent(in) :: w + + T%a6b6 = dble(w) + +end subroutine assignscalar_4sr4 + +subroutine assignscalar_1(T,w) + + type(Tensor1), intent(inout) :: T + real(kind=wp), intent(in) :: w + + T%a = w + +end subroutine assignscalar_1 + +subroutine assignscalar_1r4(T,w) + + type(Tensor1), intent(inout) :: T + real(kind=4), intent(in) :: w + + T%a = dble(w) + +end subroutine assignscalar_1r4 + +subroutine assignscalar_2(T,w) + + type(Tensor2), intent(inout) :: T + real(kind=wp), intent(in) :: w + + T%ab = w + +end subroutine assignscalar_2 + +subroutine assignscalar_2r4(T,w) + + type(Tensor2), intent(inout) :: T + real(kind=4), intent(in) :: w + + T%ab = dble(w) + +end subroutine assignscalar_2r4 + +subroutine assignscalar_4(T,w) + + type(Tensor4), intent(inout) :: T + real(kind=wp), intent(in) :: w + + T%abcd = w + +end subroutine assignscalar_4 + +subroutine assignscalar_4r4(T,w) + + type(Tensor4), intent(inout) :: T + real(kind=4), intent(in) :: w + + T%abcd = dble(w) + +end subroutine assignscalar_4r4 diff --git a/src/libassignten2sym.finc b/src/libassignten2sym.finc new file mode 100644 index 00000000..86ce5b0e --- /dev/null +++ b/src/libassignten2sym.finc @@ -0,0 +1,35 @@ +subroutine assignten2sym_2(T,A) + + type(Tensor2s), intent(inout) :: T + type(Tensor2), intent(in) :: A + + T = voigt(A) + +end subroutine assignten2sym_2 + +subroutine assignten2sym_4(T,A) + + type(Tensor4s), intent(inout) :: T + type(Tensor4), intent(in) :: A + + T = voigt(A) + +end subroutine assignten2sym_4 + +subroutine assignsym2ten_2(T,A) + + type(Tensor2), intent(inout) :: T + type(Tensor2s), intent(in) :: A + + T = astensor(A) + +end subroutine assignsym2ten_2 + +subroutine assignsym2ten_4(T,A) + + type(Tensor4), intent(inout) :: T + type(Tensor4s), intent(in) :: A + + T = astensor(A) + +end subroutine assignsym2ten_4 diff --git a/src/libcrossdyadic.finc b/src/libcrossdyadic.finc new file mode 100644 index 00000000..80b9044d --- /dev/null +++ b/src/libcrossdyadic.finc @@ -0,0 +1,42 @@ +function crossdyadic_22(T1, T2) + + type(Tensor2), intent(in) :: T1, T2 + type(Tensor4) :: crossdyadic_22 + integer i, j, k, l + + forall(i=1:3,j=1:3,k=1:3,l=1:3) crossdyadic_22%abcd(i,j,k,l) & + & = (T1%ab(i,k) * T2%ab(j,l) + T1%ab(i,l) * T2%ab(j,k) + & + & T2%ab(i,k) * T1%ab(j,l) + T2%ab(i,l) * T1%ab(j,k))/4.d0 + +end function crossdyadic_22 + +function crossdyadic_2s2s(T1, T2) + + type(Tensor2s), intent(in) :: T1, T2 + type(Tensor4s) :: crossdyadic_2s2s + integer :: i,j,k,l + integer, dimension(3,3) :: i6 + + i6 = reshape( (/1,4,6, 4,2,5, 6,5,3/), (/3, 3/) ) + + crossdyadic_2s2s%a6b6 = 0.d0 + + do i=1,3 + do j=1,3 + if (i.le.j) then + do k=1,3 + do l=1,3 + if (k.le.l) then + crossdyadic_2s2s%a6b6(i6(i,j),i6(k,l)) & + & = ( T1%a6(i6(i,k)) * T2%a6(i6(j,l)) & + & +T1%a6(i6(i,l)) * T2%a6(i6(j,k)) & + & +T2%a6(i6(i,k)) * T1%a6(i6(j,l)) & + & +T2%a6(i6(i,l)) * T1%a6(i6(j,k)) )/4.d0 + end if + end do + end do + end if + end do + end do + +end function crossdyadic_2s2s diff --git a/src/libddot.finc b/src/libddot.finc new file mode 100644 index 00000000..deb40540 --- /dev/null +++ b/src/libddot.finc @@ -0,0 +1,164 @@ +function ddot_22(T1, T2) + + type(Tensor2), intent(in) :: T1 + type(Tensor2), intent(in) :: T2 + real(kind=wp) :: ddot_22 + integer :: i,j + + ddot_22 = 0.d0 + do i = 1,3 + do j = 1,3 + ddot_22 = ddot_22 + T1%ab(i,j)*T2%ab(i,j) + enddo + enddo + +end function ddot_22 + +function ddot_2s2s(T1, T2) + + type(Tensor2s), intent(in) :: T1 + type(Tensor2s), intent(in) :: T2 + real(kind=wp) :: ddot_2s2s + integer :: i + + ddot_2s2s = 0.d0 + do i=1,3 + ddot_2s2s = ddot_2s2s + T1%a6(i)*T2%a6(i) + enddo + do i=4,6 + ddot_2s2s = ddot_2s2s + T1%a6(i)*T2%a6(i)*2.d0 + enddo + +end function ddot_2s2s + +function ddot_24(T1, T2) + + type(Tensor2), intent(in) :: T1 + type(Tensor4), intent(in) :: T2 + type(Tensor2) :: ddot_24 + integer :: i,j,k,l + + ddot_24%ab = 0.d0 + do i = 1,3 + do j = 1,3 + do k = 1,3 + do l = 1,3 + ddot_24%ab(k,l) = ddot_24%ab(k,l) + T1%ab(i,j)*T2%abcd(i,j,k,l) + enddo + enddo + enddo + enddo + +end function ddot_24 + +function ddot_2s4s(T1, T2) + + type(Tensor2s), intent(in) :: T1 + type(Tensor4s), intent(in) :: T2 + type(Tensor2s) :: ddot_2s4s + real(kind=wp) :: w + integer :: i,j + + ddot_2s4s%a6 = 0.d0 + do i = 1,6 + do j = 1,6 + if (i > 3) then + w = 2.d0 + else + w = 1.d0 + endif + ddot_2s4s%a6(j) = ddot_2s4s%a6(j) + T1%a6(i)*T2%a6b6(i,j)*w + enddo + enddo + +end function ddot_2s4s + +function ddot_42(T1, T2) + + type(Tensor4), intent(in) :: T1 + type(Tensor2), intent(in) :: T2 + type(Tensor2) :: ddot_42 + integer :: i,j,k,l + + ddot_42%ab = 0.d0 + do i = 1,3 + do j = 1,3 + do k = 1,3 + do l = 1,3 + ddot_42%ab(i,j) = ddot_42%ab(i,j) + T1%abcd(i,j,k,l)*T2%ab(k,l) + enddo + enddo + enddo + enddo + +end function ddot_42 + +function ddot_4s2s(T1, T2) + + type(Tensor4s), intent(in) :: T1 + type(Tensor2s), intent(in) :: T2 + type(Tensor2s) :: ddot_4s2s + real(kind=wp) :: w + integer :: i,j + + ddot_4s2s%a6 = 0.d0 + do i = 1,6 + do j = 1,6 + if (j > 3) then + w = 2.d0 + else + w = 1.d0 + endif + ddot_4s2s%a6(i) = ddot_4s2s%a6(i) + T1%a6b6(i,j)*T2%a6(j)*w + enddo + enddo + +end function ddot_4s2s + +function ddot_44(T1, T2) + + type(Tensor4), intent(in) :: T1 + type(Tensor4), intent(in) :: T2 + type(Tensor4) :: ddot_44 + integer :: i,j,k,l,m,n + + ddot_44%abcd = 0.d0 + do i = 1,3 + do j = 1,3 + do m = 1,3 + do n = 1,3 + do k = 1,3 + do l = 1,3 + ddot_44%abcd(i,j,k,l) = ddot_44%abcd(i,j,k,l) + T1%abcd(i,j,m,n)*T2%abcd(m,n,k,l) + enddo + enddo + enddo + enddo + enddo + enddo + +end function ddot_44 + +function ddot_4s4s(T1, T2) + + type(Tensor4s), intent(in) :: T1 + type(Tensor4s), intent(in) :: T2 + type(Tensor4s) :: ddot_4s4s + real(kind=wp) :: w + integer :: i,j,k + + ddot_4s4s%a6b6 = 0.d0 + do i = 1,6 + do k = 1,6 + do j = 1,6 + if (k > 3) then + w = 2.d0 + else + w = 1.d0 + endif + ddot_4s4s%a6b6(i,j) = ddot_4s4s%a6b6(i,j) + T1%a6b6(i,k)*T2%a6b6(k,j)*w + enddo + enddo + enddo + +end function ddot_4s4s diff --git a/src/libdet.finc b/src/libdet.finc new file mode 100644 index 00000000..2f37f3b6 --- /dev/null +++ b/src/libdet.finc @@ -0,0 +1,25 @@ +function det_2(T) + + type(Tensor2) :: T + real(kind=wp) :: det_2 + + det_2 = T%ab(1,1)*(T%ab(2,2)*T%ab(3,3)-T%ab(2,3)*T%ab(3,2)) & + & + T%ab(1,2)*(T%ab(2,3)*T%ab(3,1)-T%ab(2,1)*T%ab(3,3)) & + & + T%ab(1,3)*(T%ab(2,1)*T%ab(3,2)-T%ab(2,2)*T%ab(3,1)) + +end function det_2 + +function det_2s(T) + + type(Tensor2s), intent(in) :: T + real(kind=wp) :: det_2s + + det_2s = T%a6(1)*T%a6(2)*T%a6(3) & + & + T%a6(4)*T%a6(5)*T%a6(6) & + & + T%a6(6)*T%a6(4)*T%a6(5) & + & - T%a6(6)*T%a6(2)*T%a6(6) & + & - T%a6(5)*T%a6(5)*T%a6(1) & + & - T%a6(3)*T%a6(4)*T%a6(4) + +end function det_2s + diff --git a/src/libdev.finc b/src/libdev.finc new file mode 100644 index 00000000..8c7f8edb --- /dev/null +++ b/src/libdev.finc @@ -0,0 +1,19 @@ +function dev_2(T) + + type(Tensor2), intent(in) :: T + type(Tensor2) :: dev_2,Eye + + Eye = identity2(Eye) + dev_2%ab = T%ab - tr(T)/3.d0*Eye%ab + +end function dev_2 + +function dev_2s(T) + + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: dev_2s,Eye + + Eye = identity2(Eye) + dev_2s%a6 = T%a6 - tr(T)/3.d0*Eye%a6 + +end function dev_2s diff --git a/src/libdiv.finc b/src/libdiv.finc new file mode 100644 index 00000000..d5a1fd90 --- /dev/null +++ b/src/libdiv.finc @@ -0,0 +1,100 @@ +! ------REAL(KIND=8)-------------------------------------- +function div_10(T, w) + + real(kind=wp), intent(in) :: w + type(Tensor1), intent(in) :: T + type(Tensor1) :: div_10 + + div_10%a = T%a / w + +end function div_10 + +function div_20(T, w) + + real(kind=wp), intent(in) :: w + type(Tensor2), intent(in) :: T + type(Tensor2) :: div_20 + + div_20%ab = T%ab / w + +end function div_20 + +function div_20s(T, w) + + real(kind=wp), intent(in) :: w + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: div_20s + + div_20s%a6 = T%a6 / w + +end function div_20s + +function div_40(T, w) + + real(kind=wp), intent(in) :: w + type(Tensor4), intent(in) :: T + type(Tensor4) :: div_40 + + div_40%abcd = T%abcd / w + +end function div_40 + +function div_40s(T, w) + + real(kind=wp), intent(in) :: w + type(Tensor4s), intent(in) :: T + type(Tensor4s) :: div_40s + + div_40s%a6b6 = T%a6b6 / w + +end function div_40s +! ------REAL(KIND=4)---------------------------------------- +function div_10_r4(T, w) + + real(kind=4), intent(in) :: w + type(Tensor1), intent(in) :: T + type(Tensor1) :: div_10_r4 + + div_10_r4%a = T%a / dble(w) + +end function div_10_r4 + +function div_20_r4(T, w) + + real(kind=4), intent(in) :: w + type(Tensor2), intent(in) :: T + type(Tensor2) :: div_20_r4 + + div_20_r4%ab = T%ab / dble(w) + +end function div_20_r4 + +function div_20s_r4(T, w) + + real(kind=4), intent(in) :: w + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: div_20s_r4 + + div_20s_r4%a6 = T%a6 / dble(w) + +end function div_20s_r4 + +function div_40_r4(T, w) + + real(kind=4), intent(in) :: w + type(Tensor4), intent(in) :: T + type(Tensor4) :: div_40_r4 + + div_40_r4%abcd = T%abcd / dble(w) + +end function div_40_r4 + +function div_40s_r4(T, w) + + real(kind=4), intent(in) :: w + type(Tensor4s), intent(in) :: T + type(Tensor4s) :: div_40s_r4 + + div_40s_r4%a6b6 = T%a6b6 / dble(w) + +end function div_40s_r4 diff --git a/src/libdot.finc b/src/libdot.finc new file mode 100644 index 00000000..40a772d2 --- /dev/null +++ b/src/libdot.finc @@ -0,0 +1,308 @@ +! ------DOT SECTION----------------------------------------- +! ------SIMPLE DOT SECTION---------------------------------- +! ------REAL(KIND=8)---------------------------------------- +function dot_01(w, T) + + real(kind=wp), intent(in) :: w + type(Tensor1), intent(in) :: T + type(Tensor1) :: dot_01 + + dot_01%a = w * T%a + +end function dot_01 + +function dot_10(T, w) + + real(kind=wp), intent(in) :: w + type(Tensor1), intent(in) :: T + type(Tensor1) :: dot_10 + + dot_10%a = w * T%a + +end function dot_10 + +function dot_02(w, T) + + real(kind=wp), intent(in) :: w + type(Tensor2), intent(in) :: T + type(Tensor2) :: dot_02 + + dot_02%ab = w * T%ab + +end function dot_02 + +function dot_02s(w, T) + + real(kind=wp), intent(in) :: w + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: dot_02s + + dot_02s%a6 = w * T%a6 + +end function dot_02s + +function dot_20(T, w) + + real(kind=wp), intent(in) :: w + type(Tensor2), intent(in) :: T + type(Tensor2) :: dot_20 + + dot_20%ab = w * T%ab + +end function dot_20 + +function dot_20s(T, w) + + real(kind=wp), intent(in) :: w + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: dot_20s + + dot_20s%a6 = w * T%a6 + +end function dot_20s + +function dot_04(w, T) + + real(kind=wp), intent(in) :: w + type(Tensor4), intent(in) :: T + type(Tensor4) :: dot_04 + + dot_04%abcd = w * T%abcd + +end function dot_04 + +function dot_04s(w, T) + + real(kind=wp), intent(in) :: w + type(Tensor4s), intent(in) :: T + type(Tensor4s) :: dot_04s + + dot_04s%a6b6 = w * T%a6b6 + +end function dot_04s + +function dot_40(T, w) + + real(kind=wp), intent(in) :: w + type(Tensor4), intent(in) :: T + type(Tensor4) :: dot_40 + + dot_40%abcd = w * T%abcd + +end function dot_40 + +function dot_40s(T, w) + + real(kind=wp), intent(in) :: w + type(Tensor4s), intent(in) :: T + type(Tensor4s) :: dot_40s + + dot_40s%a6b6 = w * T%a6b6 + +end function dot_40s +! ------REAL(KIND=4)---------------------------------------- +function dot_01_r4(w, T) + + real(kind=4), intent(in) :: w + type(Tensor1), intent(in) :: T + type(Tensor1) :: dot_01_r4 + + dot_01_r4%a = dble(w) * T%a + +end function dot_01_r4 + +function dot_10_r4(T, w) + + real(kind=4), intent(in) :: w + type(Tensor1), intent(in) :: T + type(Tensor1) :: dot_10_r4 + + dot_10_r4%a = dble(w) * T%a + +end function dot_10_r4 + +function dot_02_r4(w, T) + + real(kind=4), intent(in) :: w + type(Tensor2), intent(in) :: T + type(Tensor2) :: dot_02_r4 + + dot_02_r4%ab = dble(w) * T%ab + +end function dot_02_r4 + +function dot_02s_r4(w, T) + + real(kind=4), intent(in) :: w + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: dot_02s_r4 + + dot_02s_r4%a6 = dble(w) * T%a6 + +end function dot_02s_r4 + +function dot_20_r4(T, w) + + real(kind=4), intent(in) :: w + type(Tensor2), intent(in) :: T + type(Tensor2) :: dot_20_r4 + + dot_20_r4%ab = dble(w) * T%ab + +end function dot_20_r4 + +function dot_20s_r4(T, w) + + real(kind=4), intent(in) :: w + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: dot_20s_r4 + + dot_20s_r4%a6 = dble(w) * T%a6 + +end function dot_20s_r4 + +function dot_04_r4(w, T) + + real(kind=4), intent(in) :: w + type(Tensor4), intent(in) :: T + type(Tensor4) :: dot_04_r4 + + dot_04_r4%abcd = dble(w) * T%abcd + +end function dot_04_r4 + +function dot_04s_r4(w, T) + + real(kind=4), intent(in) :: w + type(Tensor4s), intent(in) :: T + type(Tensor4s) :: dot_04s_r4 + + dot_04s_r4%a6b6 = dble(w) * T%a6b6 + +end function dot_04s_r4 + +function dot_40_r4(T, w) + + real(kind=4), intent(in) :: w + type(Tensor4), intent(in) :: T + type(Tensor4) :: dot_40_r4 + + dot_40_r4%abcd = dble(w) * T%abcd + +end function dot_40_r4 + +function dot_40s_r4(T, w) + + real(kind=4), intent(in) :: w + type(Tensor4s), intent(in) :: T + type(Tensor4s) :: dot_40s_r4 + + dot_40s_r4%a6b6 = dble(w) * T%a6b6 + +end function dot_40s_r4 + +! ------REAL(KIND=8)---------------------------------------- +function dot_21(T1, T2) + + type(Tensor2), intent(in) :: T1 + type(Tensor1), intent(in) :: T2 + type(Tensor1) :: dot_21 + integer :: i, j + + do i = 1,3 + dot_21%a(i) = 0.d0 + do j = 1,3 + dot_21%a(i) = dot_21%a(i) + T1%ab(i,j)*T2%a(j) + enddo + enddo + +end function dot_21 + +function dot_2s1(T1, T2) + + type(Tensor2s), intent(in) :: T1 + type(Tensor1), intent(in) :: T2 + type(Tensor1) :: dot_2s1 + + dot_2s1%a(1)=T1%a6(1)*T2%a(1)+T1%a6(4)*T2%a(2)+T1%a6(6)*T2%a(3) + dot_2s1%a(2)=T1%a6(4)*T2%a(1)+T1%a6(2)*T2%a(2)+T1%a6(5)*T2%a(3) + dot_2s1%a(3)=T1%a6(6)*T2%a(1)+T1%a6(5)*T2%a(2)+T1%a6(3)*T2%a(3) + +end function dot_2s1 + +function dot_12(T1, T2) + + type(Tensor1), intent(in) :: T1 + type(Tensor2), intent(in) :: T2 + type(Tensor1) :: dot_12 + integer :: i, j + + do i = 1,3 + dot_12%a(i) = 0.d0 + do j = 1,3 + dot_12%a(i) = dot_12%a(i) + T1%a(j)*T2%ab(j,i) + enddo + enddo + +end function dot_12 + +function dot_12s(T1, T2) + + type(Tensor2s), intent(in) :: T2 + type(Tensor1), intent(in) :: T1 + type(Tensor1) :: dot_12s + + dot_12s%a(1)=T1%a(1)*T2%a6(1)+T1%a(2)*T2%a6(4)+T1%a(3)*T2%a6(6) + dot_12s%a(2)=T1%a(1)*T2%a6(4)+T1%a(2)*T2%a6(2)+T1%a(3)*T2%a6(5) + dot_12s%a(3)=T1%a(1)*T2%a6(6)+T1%a(2)*T2%a6(5)+T1%a(3)*T2%a6(3) + +end function dot_12s + +function dot_11(T1, T2) + + type(Tensor1), intent(in) :: T1 + type(Tensor1), intent(in) :: T2 + real(kind=wp) :: dot_11 + integer :: i + + dot_11 = 0.d0 + do i = 1,3 + dot_11 = dot_11 + T1%a(i)*T2%a(i) + enddo + +end function dot_11 + +function dot_22(T1, T2) + + type(Tensor2), intent(in) :: T1 + type(Tensor2), intent(in) :: T2 + type(Tensor2) :: dot_22 + integer :: i,j,k + + dot_22%ab = 0.d0 + do i = 1,3 + do j = 1,3 + do k = 1,3 + dot_22%ab(i,j) = dot_22%ab(i,j) + T1%ab(i,k)*T2%ab(k,j) + enddo + enddo + enddo + +end function dot_22 + +function dot_2s2s(T1, T2) + + type(Tensor2s), intent(in) :: T1, T2 + type(Tensor2) :: dot_2s2s + + dot_2s2s%ab(1,1) = T1%a6(1)*T2%a6(1)+T1%a6(4)*T2%a6(4) +T1%a6(6)*T2%a6(6) + dot_2s2s%ab(2,2) = T1%a6(4)*T2%a6(4)+T1%a6(2)*T2%a6(2) +T1%a6(5)*T2%a6(5) + dot_2s2s%ab(3,3) = T1%a6(6)*T2%a6(6)+T1%a6(5)*T2%a6(5) +T1%a6(3)*T2%a6(3) + dot_2s2s%ab(1,2) = T1%a6(1)*T2%a6(4)+T1%a6(4)*T2%a6(2) +T1%a6(6)*T2%a6(5) + dot_2s2s%ab(2,1) = T1%a6(4)*T2%a6(1)+T1%a6(2)*T2%a6(4) +T1%a6(5)*T2%a6(6) + dot_2s2s%ab(2,3) = T1%a6(4)*T2%a6(6)+T1%a6(2)*T2%a6(5) +T1%a6(5)*T2%a6(3) + dot_2s2s%ab(3,2) = T1%a6(6)*T2%a6(4)+T1%a6(5)*T2%a6(2) +T1%a6(3)*T2%a6(5) + dot_2s2s%ab(1,3) = T1%a6(1)*T2%a6(6)+T1%a6(4)*T2%a6(5) +T1%a6(6)*T2%a6(3) + dot_2s2s%ab(3,1) = T1%a6(6)*T2%a6(1)+T1%a6(5)*T2%a6(4) +T1%a6(3)*T2%a6(6) + +end function dot_2s2s diff --git a/src/libdyadic.finc b/src/libdyadic.finc new file mode 100644 index 00000000..59ab223d --- /dev/null +++ b/src/libdyadic.finc @@ -0,0 +1,29 @@ +function dyadic_11(T1, T2) + + type(Tensor1), intent(in) :: T1, T2 + type(Tensor2) :: dyadic_11 + integer i, j + + forall(i=1:3,j=1:3) dyadic_11%ab(i,j) = T1%a(i) * T2%a(j) + +end function dyadic_11 + +function dyadic_22(T1, T2) + + type(Tensor2), intent(in) :: T1, T2 + type(Tensor4) :: dyadic_22 + integer i, j, k, l + + forall(i=1:3,j=1:3,k=1:3,l=1:3) dyadic_22%abcd(i,j,k,l) = T1%ab(i,j) * T2%ab(k,l) + +end function dyadic_22 + +function dyadic_2s2s(T1, T2) + + type(Tensor2s), intent(in) :: T1, T2 + type(Tensor4s) :: dyadic_2s2s + integer i, j + + forall(i=1:6,j=1:6) dyadic_2s2s%a6b6(i,j) = T1%a6(i) * T2%a6(j) + +end function dyadic_2s2s diff --git a/src/libidentity.finc b/src/libidentity.finc new file mode 100644 index 00000000..eb39c550 --- /dev/null +++ b/src/libidentity.finc @@ -0,0 +1,43 @@ +function ident_2(T) + + type(Tensor2), intent(in) :: T + type(Tensor2) :: ident_2 + integer :: i + + ident_2%ab = 0.d0 + do i = 1,3 + ident_2%ab(i,i) = 1.d0 + enddo + +end function ident_2 + +function ident_2s(T) + + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: ident_2s + integer :: i + + ident_2s%a6 = 0.d0 + do i = 1,3 + ident_2s%a6(i) = 1.d0 + enddo + +end function ident_2s + +function ident_4(T) + + type(Tensor2), intent(in) :: T + type(Tensor4) :: ident_4 + + ident_4 = T.cdya.T + +end function ident_4 + +function ident_4s(T) + + type(Tensor2s), intent(in) :: T + type(Tensor4s) :: ident_4s + + ident_4s = T.cdya.T + +end function ident_4s diff --git a/src/libinv.finc b/src/libinv.finc new file mode 100644 index 00000000..1cb7644a --- /dev/null +++ b/src/libinv.finc @@ -0,0 +1,73 @@ +function inv_2(T) + + type(Tensor2), intent(in) :: T + type(Tensor2) :: inv_2 + real(kind=wp) :: idetT + + idetT = 1.d0/det(T) + + inv_2%ab(1,1)=+idetT*(T%ab(2,2)*T%ab(3,3)-T%ab(2,3)*T%ab(3,2)) + inv_2%ab(2,1)=-idetT*(T%ab(2,1)*T%ab(3,3)-T%ab(2,3)*T%ab(3,1)) + inv_2%ab(3,1)=+idetT*(T%ab(2,1)*T%ab(3,2)-T%ab(2,2)*T%ab(3,1)) + inv_2%ab(1,2)=-idetT*(T%ab(1,2)*T%ab(3,3)-T%ab(1,3)*T%ab(3,2)) + inv_2%ab(2,2)=+idetT*(T%ab(1,1)*T%ab(3,3)-T%ab(1,3)*T%ab(3,1)) + inv_2%ab(3,2)=-idetT*(T%ab(1,1)*T%ab(3,2)-T%ab(1,2)*T%ab(3,1)) + inv_2%ab(1,3)=+idetT*(T%ab(1,2)*T%ab(2,3)-T%ab(1,3)*T%ab(2,2)) + inv_2%ab(2,3)=-idetT*(T%ab(1,1)*T%ab(2,3)-T%ab(1,3)*T%ab(2,1)) + inv_2%ab(3,3)=+idetT*(T%ab(1,1)*T%ab(2,2)-T%ab(1,2)*T%ab(2,1)) + +end function inv_2 + +function inv_2s(T) + + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: inv_2s + real(kind=wp) :: idetT + + idetT = 1.d0/det(T) + + inv_2s%a6(1)=+idetT*(T%a6(2)*T%a6(3) -T%a6(5)*T%a6(5)) + inv_2s%a6(4)=-idetT*(T%a6(4)*T%a6(3) -T%a6(5)*T%a6(6)) + inv_2s%a6(6)=+idetT*(T%a6(4)*T%a6(5) -T%a6(2)*T%a6(6)) + inv_2s%a6(2)=+idetT*(T%a6(1)*T%a6(3) -T%a6(6)*T%a6(6)) + inv_2s%a6(5)=-idetT*(T%a6(1)*T%a6(5) -T%a6(4)*T%a6(6)) + inv_2s%a6(3)=+idetT*(T%a6(1)*T%a6(2) -T%a6(4)*T%a6(4)) + +end function inv_2s + +function inv2d(T,detT) + + type(Tensor2), intent(in) :: T + type(Tensor2) :: inv2d + real(kind=wp) :: detT, idetT + + idetT = 1.d0/detT + + inv2d%ab(1,1)=+idetT*(T%ab(2,2)*T%ab(3,3)-T%ab(2,3)*T%ab(3,2)) + inv2d%ab(2,1)=-idetT*(T%ab(2,1)*T%ab(3,3)-T%ab(2,3)*T%ab(3,1)) + inv2d%ab(3,1)=+idetT*(T%ab(2,1)*T%ab(3,2)-T%ab(2,2)*T%ab(3,1)) + inv2d%ab(1,2)=-idetT*(T%ab(1,2)*T%ab(3,3)-T%ab(1,3)*T%ab(3,2)) + inv2d%ab(2,2)=+idetT*(T%ab(1,1)*T%ab(3,3)-T%ab(1,3)*T%ab(3,1)) + inv2d%ab(3,2)=-idetT*(T%ab(1,1)*T%ab(3,2)-T%ab(1,2)*T%ab(3,1)) + inv2d%ab(1,3)=+idetT*(T%ab(1,2)*T%ab(2,3)-T%ab(1,3)*T%ab(2,2)) + inv2d%ab(2,3)=-idetT*(T%ab(1,1)*T%ab(2,3)-T%ab(1,3)*T%ab(2,1)) + inv2d%ab(3,3)=+idetT*(T%ab(1,1)*T%ab(2,2)-T%ab(1,2)*T%ab(2,1)) + +end function inv2d + +function inv2sd(T,detT) + + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: inv2sd + real(kind=wp) :: detT, idetT + + idetT = 1.d0/detT + + inv2sd%a6(1)=+idetT*(T%a6(2)*T%a6(3) -T%a6(5)*T%a6(5)) + inv2sd%a6(4)=-idetT*(T%a6(4)*T%a6(3) -T%a6(5)*T%a6(6)) + inv2sd%a6(6)=+idetT*(T%a6(4)*T%a6(5) -T%a6(2)*T%a6(6)) + inv2sd%a6(2)=+idetT*(T%a6(1)*T%a6(3) -T%a6(6)*T%a6(6)) + inv2sd%a6(5)=-idetT*(T%a6(1)*T%a6(5) -T%a6(4)*T%a6(6)) + inv2sd%a6(3)=+idetT*(T%a6(1)*T%a6(2) -T%a6(4)*T%a6(4)) + +end function inv2sd diff --git a/src/libnorm.finc b/src/libnorm.finc new file mode 100644 index 00000000..9c22d8c3 --- /dev/null +++ b/src/libnorm.finc @@ -0,0 +1,26 @@ +function norm_1(T) + + type(Tensor1) :: T + real(kind=wp) :: norm_1 + + norm_1 = sqrt(sum((T%a)**2)) + +end function norm_1 + +function norm_2(T) + + type(Tensor2) :: T + real(kind=wp) :: norm_2 + + norm_2 = sqrt(T**T) + +end function norm_2 + +function norm_2s(T) + + type(Tensor2s) :: T + real(kind=wp) :: norm_2s + + norm_2s = sqrt(T**T) + +end function norm_2s diff --git a/src/libpermute.finc b/src/libpermute.finc new file mode 100644 index 00000000..99b27632 --- /dev/null +++ b/src/libpermute.finc @@ -0,0 +1,63 @@ +function permute_2(T,i1,j1) + ! permute tensor of rank 2 for orders 2,1 = transpose(T) + + type(Tensor2), intent(in) :: T + integer, intent(in) :: i1,j1 + + type(Tensor2) :: permute_2 + + permute_2%ab = transpose(T%ab) + +end function permute_2 + +function permute_2s(T,i1,j1) + ! permute tensor of rank 2 for orders 2,1 = transpose(T) + + type(Tensor2s), intent(in) :: T + integer, intent(in) :: i1,j1 + + type(Tensor2s) :: permute_2s + + permute_2s%a6 = T%a6 + +end function permute_2s + +function permute_4(T,i1,j1,k1,l1) + ! permute tensor of rank 4 + + type(Tensor4), intent(in) :: T + integer, intent(in) :: i1,j1,k1,l1 + + type(Tensor4) :: permute_4 + integer i,j,k,l + +! hard-coded permutation +! if (i1==1 .and. j1==3 .and. k1==2 .and. l1==4) then +! forall(i=1:3,j=1:3,k=1:3,l=1:3) permute_4%abcd(i,j,k,l) = T%abcd(i,k,j,l) +! else if (i1==1 .and. j1==4 .and. k1==2 .and. l1==3) then +! forall(i=1:3,j=1:3,k=1:3,l=1:3) permute_4%abcd(i,j,k,l) = T%abcd(i,l,j,k) +! else +! permute_4%abcd = T%abcd +! end if + + permute_4%abcd = reshape(T%abcd,(/3,3,3,3/), (/0.d0/),(/i1,j1,k1,l1/)) + +end function permute_4 + +function permute_4s(T,i1,j1,k1,l1) + ! permute tensor of rank 4s + + type(Tensor4s), intent(in) :: T + type(Tensor4) :: Tp + integer, intent(in) :: i1,j1,k1,l1 + type(Tensor4) :: permute_4 + type(Tensor4s) :: permute_4s + + integer i,j,k,l + + Tp = tensorstore(T) + + permute_4%abcd = reshape(Tp%abcd,(/3,3,3,3/), (/0.d0/),(/i1,j1,k1,l1/)) + permute_4s = symstore(permute_4) + +end function permute_4s diff --git a/src/libpiola.finc b/src/libpiola.finc new file mode 100644 index 00000000..03d32cfc --- /dev/null +++ b/src/libpiola.finc @@ -0,0 +1,85 @@ +function piola2(F, T) + + type(Tensor2), intent(in) :: T, F + type(Tensor2) :: piola2 + + piola2 = F*T*transpose(F) + +end function piola2 + +function piola2s(F, T) + + type(Tensor2s), intent(in) :: T + type(Tensor2), intent(in) :: F + type(Tensor2s) :: piola2s + + piola2s = symstore(F*tensorstore(T)*transpose(F)) + +end function piola2s + +function piola4(F, T) + + type(Tensor2), intent(in) :: F + type(Tensor4), intent(in) :: T + type(Tensor4) :: piola4 + integer :: i,j,k,l,ii,jj,kk,ll + + piola4%abcd = 0.d0 + do i=1,3 + do j=1,3 + do k=1,3 + do l=1,3 + do ii=1,3 + do jj=1,3 + do kk=1,3 + do ll=1,3 + piola4%abcd(i,j,k,l) = piola4%abcd(i,j,k,l) + & + & F%ab(i,ii)*F%ab(j,jj)*F%ab(k,kk)*F%ab(l,ll) & + & * T%abcd(ii,jj,kk,ll) + end do + end do + end do + end do + end do + end do + end do + end do + +end function piola4 + +function piola4s(F, T) + + type(Tensor2), intent(in) :: F + type(Tensor4s), intent(in) :: T + ! type(Tensor4) :: T2, piola4 + type(Tensor4s) :: piola4s,FF + ! integer :: i,j,k,l,ii,jj,kk,ll + + ! piola4%abcd = 0.d0 + ! T2 = tensorstore(T) + + ! do i=1,3 + ! do j=1,3 + ! do k=1,3 + ! do l=1,3 + ! do ii=1,3 + ! do jj=1,3 + ! do kk=1,3 + ! do ll=1,3 + ! piola4%abcd(i,j,k,l) = piola4%abcd(i,j,k,l) + & + ! ! & F%ab(i,ii)*F%ab(j,jj)*F%ab(k,kk)*F%ab(l,ll) & + ! ! & *T2%abcd(ii,jj,kk,ll) + ! end do + ! end do + ! end do + ! end do + ! end do + ! end do + ! end do + ! end do + ! piola4s = symstore(piola4) + + FF = symstore(F.cdya.F) + piola4s = FF**T**transpose(FF) + +end function piola4s diff --git a/src/libpower.finc b/src/libpower.finc new file mode 100644 index 00000000..9e71a8cb --- /dev/null +++ b/src/libpower.finc @@ -0,0 +1,50 @@ +function pow_2(T,i) + + type(Tensor2), intent(in) :: T + integer, intent(in) :: i + + type(Tensor2) :: pow_2, invT + integer :: j + + if (i > 0) then + pow_2 = T + do j=1,i-1 + pow_2 = pow_2*T + end do + else if (i == 0) then + pow_2 = identity2(T) + else + invT = inv(T) + pow_2 = invT + do j=1,abs(i)-1 + pow_2 = pow_2*invT + end do + end if + +end function pow_2 + +function pow_2s(T,i) + + type(Tensor2s), intent(in) :: T + integer, intent(in) :: i + + type(Tensor2s) :: pow_2s, invT + integer :: j + + if (i > 0) then + pow_2s = T + do j=1,i-1 + pow_2s = pow_2s*T + end do + else if (i == 0) then + pow_2s = identity2(T) + else + invT = inv(T) + pow_2s = invT + do j=1,abs(i)-1 + pow_2s = pow_2s*invT + end do + end if + +end function pow_2s + diff --git a/src/libreducedim.finc b/src/libreducedim.finc new file mode 100644 index 00000000..ba706191 --- /dev/null +++ b/src/libreducedim.finc @@ -0,0 +1,19 @@ +function reduce_dim_2s(T,i) + + type(Tensor2s), intent(in) :: T + integer, intent(in) :: i + real(kind=wp), dimension(i) :: reduce_dim_2s + + reduce_dim_2s = T%a6(1:i) + +end function reduce_dim_2s + +function reduce_dim_4s(T,i,j) + + type(Tensor4s), intent(in) :: T + integer, intent(in) :: i,j + real(kind=wp), dimension(i,j) :: reduce_dim_4s + + reduce_dim_4s = T%a6b6(1:i,1:j) + +end function reduce_dim_4s diff --git a/src/librotation.finc b/src/librotation.finc new file mode 100644 index 00000000..98e9a32e --- /dev/null +++ b/src/librotation.finc @@ -0,0 +1,23 @@ +function rotation_2(phi,i) + + real(kind=wp), intent(in) :: phi + integer, intent(in) :: i + real(kind=wp), dimension(2,2) :: R + type(Tensor2) :: rotation_2 + + R = reshape( (/cos(phi), sin(phi), -sin(phi), cos(phi)/), (/2,2/) ) + + rotation_2 = identity2(rotation_2) + + if (i == 1) then + rotation_2%ab(2:3,2:3) = R + else if (i == 3) then + rotation_2%ab(1:2,1:2) = R + else !i == 2 + rotation_2%ab(1,1) = R(1,1) + rotation_2%ab(3,3) = R(2,2) + rotation_2%ab(1,3) = R(2,1) + rotation_2%ab(3,1) = R(1,2) + end if + +end function rotation_2 diff --git a/src/libsqrt.finc b/src/libsqrt.finc new file mode 100644 index 00000000..181d2029 --- /dev/null +++ b/src/libsqrt.finc @@ -0,0 +1,86 @@ +function sqrt_1(T) + + type(Tensor1), intent(in) :: T + type(Tensor1) :: sqrt_1 + + sqrt_1%a = dsqrt(T%a) + +end function sqrt_1 + +function sqrt_2(T) + ! Source: + ! + ! Franca, L.P. (1989): AN ALGORITHM TO COMPUTE + ! THE SQUARE ROOT OF A POSITIVE DEFINITE MATRIX + ! + + type(Tensor2), intent(in) :: T + type(Tensor2) :: sqrt_2 + + real(kind=wp) :: I_T,II_T,III_T,I_U,II_U,III_U,k,l,lam,phi + + ! Invariants of T + I_T = tr(T) + II_T = 0.5*(I_T**2-T**T) + III_T = det(T) + k = I_T**2-3.*II_T + + ! Isotropy check + if (dabs(k).le.1.0d-8) then + lam = (I_T/3.)**(1./2.) + sqrt_2 = lam * identity2(T) + return + end if + + ! Calculate largest eigenvalues + l = I_T**3 - 9./2. * I_T*II_T + 27./2. * III_T + phi = dacos(l/k**(3./2.)) + lam = dsqrt(1./3.*(I_T+2*k**(1./2.)*dcos(phi/3.))) + + ! Invariants of U + III_U = (III_T)**(1./2.) + I_U = lam + dsqrt(-lam**2+I_T+2.*III_U/lam) + II_U = (I_U**2-I_T)/2. + + sqrt_2 = 1./(I_U*II_U-III_U) *(I_U*III_U*identity2(T) + (I_U**2-II_U)*T-T**2) + +end function sqrt_2 + +function sqrt_2s(T) + ! Source: + ! + ! Franca, L.P. (1989): AN ALGORITHM TO COMPUTE + ! THE SQUARE ROOT OF A POSITIVE DEFINITE MATRIX + ! + + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: sqrt_2s + + real(kind=wp) :: I_T,II_T,III_T,I_U,II_U,III_U,k,l,lam,phi + + ! Invariants of T + I_T = tr(T) + II_T = 0.5*(I_T**2-tr(T*T)) + III_T = det(T) + k = I_T**2-3.*II_T + + ! Isotropy check + if (k.le.1.0d-8) then + lam = (I_T/3.)**(1./2.) + sqrt_2s = lam * identity2(T) + return + end if + + ! Calculate largest eigenvalues + l = I_T**3 - 9./2. * I_T*II_T + 27./2. * III_T + phi = dacos(l/k**(3./2.)) + lam = dsqrt(1./3.*(I_T+2*k**(1./2.)*dcos(phi/3.))) + + ! Invariants of U + III_U = (III_T)**(1./2.) + I_U = lam + dsqrt(-lam**2+I_T+2.*III_U/lam) + II_U = (I_U**2-I_T)/2. + + sqrt_2s = 1./(I_U*II_U-III_U) *(I_U*III_U*identity2(T) + (I_U**2-II_U)*T-T*T) + +end function sqrt_2s diff --git a/src/libstrainstore.finc b/src/libstrainstore.finc new file mode 100644 index 00000000..1c64f9f9 --- /dev/null +++ b/src/libstrainstore.finc @@ -0,0 +1,42 @@ +! function str2ten_2(E,ndi,nshear,ngens) +! implicit none +! +! integer :: ndi,nshear,ngens +! real(kind=wp), dimension(ngens) :: E +! type(Tensor2) :: str2ten_2 +! integer, dimension(3) :: ii, jj +! integer :: i +! +! str2ten_2 = Identity2(str2ten_2) +! +! do i=1,ndi +! str2ten_2%ab(i,i) = E(i) +! enddo +! +! ii = (/1,2,3/) +! jj = (/2,3,1/) +! +! do i=1,nshear +! str2ten_2%ab(ii(i),jj(i)) = E(i+ndi)/2. +! end do + +! end function str2ten_2 + +function str2ten_2s(E,ndi,nshear,ngens) + + integer :: ndi, nshear, ngens + real(kind=wp), dimension(ngens) :: E + type(Tensor2s) :: str2ten_2s + integer :: i + + str2ten_2s = Identity2(str2ten_2s) + + do i=1,ndi + str2ten_2s%a6(i) = E(i) + enddo + + do i=1,nshear + str2ten_2s%a6(i+3) = E(i+ndi)/2. + end do + +end function str2ten_2s diff --git a/src/libsub.finc b/src/libsub.finc new file mode 100644 index 00000000..6083ca25 --- /dev/null +++ b/src/libsub.finc @@ -0,0 +1,84 @@ +function sub_11(T1, T2) + + type(Tensor1), intent(in) :: T1, T2 + type(Tensor1) :: sub_11 + + sub_11%a = T1%a - T2%a + +end function sub_11 + +function sub_22(T1, T2) + + type(Tensor2), intent(in) :: T1, T2 + type(Tensor2) :: sub_22 + + sub_22%ab = T1%ab - T2%ab + +end function sub_22 + +function sub_2s2s(T1, T2) + + type(Tensor2s), intent(in) :: T1, T2 + type(Tensor2s) :: sub_2s2s + + sub_2s2s%a6 = T1%a6 - T2%a6 + +end function sub_2s2s + +function sub_22s(T1, T2) + + type(Tensor2), intent(in) :: T1 + type(Tensor2s), intent(in) :: T2 + type(Tensor2) :: sub_22s + + sub_22s = T1 - astensor(T2) + +end function sub_22s + +function sub_2s2(T1, T2) + + type(Tensor2s), intent(in) :: T1 + type(Tensor2), intent(in) :: T2 + type(Tensor2) :: sub_2s2 + + sub_2s2 = astensor(T1) - T2 + +end function sub_2s2 + +function sub_44(T1, T2) + + type(Tensor4), intent(in) :: T1, T2 + type(Tensor4) :: sub_44 + + sub_44%abcd = T1%abcd - T2%abcd + +end function sub_44 + +function sub_4s4s(T1, T2) + + type(Tensor4s), intent(in) :: T1, T2 + type(Tensor4s) :: sub_4s4s + + sub_4s4s%a6b6 = T1%a6b6 - T2%a6b6 + +end function sub_4s4s + +function sub_44s(T1, T2) + + type(Tensor4), intent(in) :: T1 + type(Tensor4s), intent(in) :: T2 + type(Tensor4) :: sub_44s + + sub_44s = T1 - astensor(T2) + +end function sub_44s + +function sub_4s4(T1, T2) + + type(Tensor4s), intent(in) :: T1 + type(Tensor4), intent(in) :: T2 + type(Tensor4) :: sub_4s4 + + sub_4s4 = astensor(T1) - T2 + +end function sub_4s4 diff --git a/src/libsymstore.finc b/src/libsymstore.finc new file mode 100644 index 00000000..fe91beae --- /dev/null +++ b/src/libsymstore.finc @@ -0,0 +1,88 @@ +function symstore_2s(T) + + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: symstore_2s + + symstore_2s%a6 = T%a6 + +end function symstore_2s + +function symstore_2sa(T) + + real(kind=wp), dimension(6), intent(in) :: T + type(Tensor2s) :: symstore_2sa + + symstore_2sa%a6 = T + +end function symstore_2sa + +function symstore_4s(T) + + type(Tensor4s), intent(in) :: T + type(Tensor4s) :: symstore_4s + + symstore_4s%a6b6 = T%a6b6 + +end function symstore_4s + +function symstore_4sa(T) + + real(kind=wp), dimension(6,6), intent(in) :: T + type(Tensor4s) :: symstore_4sa + + symstore_4sa%a6b6 = T + +end function symstore_4sa + +function symstore_2(T) + + type(Tensor2), intent(in) :: T + type(Tensor2s) :: symstore_2 + integer :: i + + symstore_2%a6 = 0.d0 + do i=1,3 + symstore_2%a6(i) = T%ab(i,i) + enddo + symstore_2%a6(4) = T%ab(1,2) + symstore_2%a6(5) = T%ab(2,3) + symstore_2%a6(6) = T%ab(3,1) + +end function symstore_2 + +function symstore_4(T) + + type(Tensor4), intent(in) :: T + type(Tensor4s) :: symstore_4 + integer :: i,j + + symstore_4%a6b6 = 0.d0 + do i=1,3 + do j=1,3 + symstore_4%a6b6(i,j) = T%abcd(i,i,j,j) + enddo + enddo + + symstore_4%a6b6(4,4) = T%abcd(1,2,1,2) + symstore_4%a6b6(5,5) = T%abcd(2,3,2,3) + symstore_4%a6b6(6,6) = T%abcd(3,1,3,1) + + do i=1,3 + symstore_4%a6b6(i,4) = T%abcd(i,i,1,2) + symstore_4%a6b6(i,5) = T%abcd(i,i,2,3) + symstore_4%a6b6(i,6) = T%abcd(i,i,3,1) + symstore_4%a6b6(4,i) = T%abcd(1,2,i,i) + symstore_4%a6b6(5,i) = T%abcd(2,3,i,i) + symstore_4%a6b6(6,i) = T%abcd(3,1,i,i) + enddo + + symstore_4%a6b6(4,5) = T%abcd(1,2,2,3) + symstore_4%a6b6(4,6) = T%abcd(1,2,3,1) + + symstore_4%a6b6(5,4) = T%abcd(2,3,1,2) + symstore_4%a6b6(5,6) = T%abcd(2,3,3,1) + + symstore_4%a6b6(6,4) = T%abcd(3,1,1,2) + symstore_4%a6b6(6,5) = T%abcd(3,1,2,3) + +end function symstore_4 diff --git a/src/libtenstore.finc b/src/libtenstore.finc new file mode 100644 index 00000000..f41ec09b --- /dev/null +++ b/src/libtenstore.finc @@ -0,0 +1,67 @@ +function tenstore_2s(T) + + type(Tensor2s), intent(in) :: T + type(Tensor2) :: tenstore_2s + integer :: i + + tenstore_2s%ab = 0.d0 + do i=1,3 + tenstore_2s%ab(i,i) = T%a6(i) + enddo + tenstore_2s%ab(1,2) = T%a6(4) + tenstore_2s%ab(2,3) = T%a6(5) + tenstore_2s%ab(3,1) = T%a6(6) + tenstore_2s%ab(2,1) = tenstore_2s%ab(1,2) + tenstore_2s%ab(3,2) = tenstore_2s%ab(2,3) + tenstore_2s%ab(1,3) = tenstore_2s%ab(3,1) + +end function tenstore_2s + +function tenstore_2(T) + + type(Tensor2), intent(in) :: T + type(Tensor2) :: tenstore_2 + + tenstore_2%ab = T%ab + +end function tenstore_2 + +function tenstore_2a(T) + + real(kind=wp), dimension(3,3), intent(in) :: T + type(Tensor2) :: tenstore_2a + + tenstore_2a%ab = T + +end function tenstore_2a + +function tenstore_4(T) + + type(Tensor4), intent(in) :: T + type(Tensor4) :: tenstore_4 + + tenstore_4%abcd = T%abcd + +end function tenstore_4 + +function tenstore_4a(T) + + real(kind=wp), dimension(3,3,3,3), intent(in) :: T + type(Tensor4) :: tenstore_4a + + tenstore_4a%abcd = T + +end function tenstore_4a + +function tenstore_4s(T) + + type(Tensor4s), intent(in) :: T + type(Tensor4) :: tenstore_4s + integer :: i,j,k,l + integer, dimension(3,3) :: i6j6 + + i6j6 = reshape( (/1,4,6, 4,2,5, 6,5,3/), (/3, 3/) ) + + forall (i=1:3,j=1:3,k=1:3,l=1:3) tenstore_4s%abcd(i,j,k,l) = T%a6b6(i6j6(i,j),i6j6(k,l)) + +end function tenstore_4s diff --git a/src/libtools.finc b/src/libtools.finc new file mode 100644 index 00000000..14369bd6 --- /dev/null +++ b/src/libtools.finc @@ -0,0 +1,12 @@ +function fact_i(n) + + integer, intent(in) :: n + real(kind=wp) :: fact_i + integer :: i + + fact_i = 1.d0 + do i = 2, n + fact_i = fact_i * i + enddo + +end function fact_i diff --git a/src/libtrace.finc b/src/libtrace.finc new file mode 100644 index 00000000..c4583c31 --- /dev/null +++ b/src/libtrace.finc @@ -0,0 +1,17 @@ +function tr_2(T) + + type(Tensor2) :: T + real(kind=wp) :: tr_2 + + tr_2 = T%ab(1,1)+T%ab(2,2)+T%ab(3,3) + +end function tr_2 + +function tr_2s(T) + + type(Tensor2s) :: T + real(kind=wp) :: tr_2s + + tr_2s = T%a6(1)+T%a6(2)+T%a6(3) + +end function tr_2s diff --git a/src/libtransp.finc b/src/libtransp.finc new file mode 100644 index 00000000..ab703838 --- /dev/null +++ b/src/libtransp.finc @@ -0,0 +1,38 @@ +function transp2(T) + + type(Tensor2), intent(in) :: T + type(Tensor2) :: transp2 + + transp2%ab = transpose(T%ab) + +end function transp2 + +function transp2s(T) + + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: transp2s + + transp2s%a6 = T%a6 + +end function transp2s + +function transp4(T) + + type(Tensor4), intent(in) :: T + type(Tensor4) :: transp4 + integer :: i,j,k,l + + transp4%abcd = 0.d0 + forall (i=1:3,j=1:3,k=1:3,l=1:3) transp4%abcd(i,j,k,l) = T%abcd(k,l,i,j) + +end function transp4 + +function transp4s(T) + + type(Tensor4s), intent(in) :: T + type(Tensor4s) :: transp4s + + transp4s%a6b6 = transpose(T%a6b6) + +end function transp4s + diff --git a/src/libunimodular.finc b/src/libunimodular.finc new file mode 100644 index 00000000..ee6b6b69 --- /dev/null +++ b/src/libunimodular.finc @@ -0,0 +1,49 @@ +function unimod_2(T) + + type(Tensor2), intent(in) :: T + type(Tensor2) :: unimod_2, Eye + real(kind=wp) :: detT + + detT = det(T) + Eye = identity2(Eye) + + unimod_2 = detT**(-1./3.) * T + +end function unimod_2 + +function unimod_2s(T) + + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: unimod_2s, Eye + real(kind=wp) :: detT + + detT = det(T) + Eye = identity2(Eye) + + unimod_2s = detT**(-1./3.) * T + +end function unimod_2s + +function unimod_2d(T,detT) + + type(Tensor2), intent(in) :: T + type(Tensor2) :: unimod_2d, Eye + real(kind=wp), intent(in) :: detT + + Eye = identity2(Eye) + + unimod_2d = detT**(-1./3.) * T + +end function unimod_2d + +function unimod_2sd(T,detT) + + type(Tensor2s), intent(in) :: T + type(Tensor2s) :: unimod_2sd, Eye + real(kind=wp), intent(in) :: detT + + Eye = identity2(Eye) + + unimod_2sd = detT**(-1./3.) * T + +end function unimod_2sd diff --git a/ttb/ttb_library.f b/src/ttb_library.f90 similarity index 61% rename from ttb/ttb_library.f rename to src/ttb_library.f90 index 05517395..a686c24f 100644 --- a/ttb/ttb_library.f +++ b/src/ttb_library.f90 @@ -1,52 +1,54 @@ ! -----------MODULE TENSOR--------------------------------------- - module Tensor - ! --------------------------------------- - ! Tensor Toolbox Module for Fortran - ! Andreas Dutzler - ! Graz University of Technology - ! Institute of Structural Durability - ! and Railway Technology - ! --------------------------------------- - ! tested on: Windows 10 (64bit) - ! - Intel Fortran >2015 - ! - MinGW gfortran >6.3 - ! --------------------------------------- - ! use this module in the following form: - ! --------------------------------------- - ! include 'ttb/ttb_library.f' - ! program sample - ! use Tensor - ! ... - ! end program sample - ! --------------------------------------- - - type Tensor1 +module Tensor +! --------------------------------------- +! Tensor Toolbox Module for Fortran +! Andreas Dutzler +! Graz University of Technology +! Institute of Structural Durability +! and Railway Technology +! --------------------------------------- +! tested on: Windows 10 (64bit) +! - Intel Fortran >2015 +! - MinGW gfortran >6.3 +! --------------------------------------- +! use this module in the following form: +! --------------------------------------- +! include 'ttb_library.finc' +! program sample +! use Tensor +! ... +! end program sample +! --------------------------------------- +implicit none +integer,private,parameter :: wp=kind(0.0d0) + + type Tensor1 ! tensor of rank 1 - real(kind=8), dimension(3) :: a = 0.d0 - end type Tensor1 - - type Tensor2 + real(kind=wp), dimension(3) :: a = 0.d0 + end type Tensor1 + + type Tensor2 ! tensor of rank 2 - real(kind=8), dimension(3,3) :: ab = 0.d0 - end type Tensor2 - - type Tensor2S + real(kind=wp), dimension(3,3) :: ab = 0.d0 + end type Tensor2 + + type Tensor2S ! symmetric tensor of rank 2 stored as vector - real(kind=8), dimension(6) :: a6 = 0.d0 - end type Tensor2S - - type Tensor4 + real(kind=wp), dimension(6) :: a6 = 0.d0 + end type Tensor2S + + type Tensor4 ! tensor of rank 4 - real(kind=8), dimension(3,3,3,3) :: abcd = 0.d0 - end type Tensor4 - - type Tensor4S + real(kind=wp), dimension(3,3,3,3) :: abcd = 0.d0 + end type Tensor4 + + type Tensor4S ! symmetric tensor of rank 4 stored as 6x6 matrix - real(kind=8), dimension(6, 6) :: a6b6 = 0.d0 - end type Tensor4S + real(kind=wp), dimension(6, 6) :: a6b6 = 0.d0 + end type Tensor4S ! ------BEGIN INTERFACE------------------------------------- - interface operator (/) + interface operator (/) module procedure div_10 module procedure div_20 module procedure div_20s @@ -57,8 +59,8 @@ module Tensor module procedure div_20s_r4 module procedure div_40_r4 module procedure div_40s_r4 - end interface - interface operator (.div.) + end interface + interface operator (.div.) module procedure div_10 module procedure div_20 module procedure div_20s @@ -69,9 +71,9 @@ module Tensor module procedure div_20s_r4 module procedure div_40_r4 module procedure div_40s_r4 - end interface - - interface operator (*) + end interface + + interface operator (*) ! simple dot-product of rank 1 and rank 2 tensor combinations module procedure dot_01 module procedure dot_10 @@ -100,8 +102,8 @@ module Tensor module procedure dot_04s_r4 module procedure dot_40_r4 module procedure dot_40s_r4 - end interface - interface operator (.dot.) + end interface + interface operator (.dot.) ! simple dot-product of rank 1 and rank 2 tensor combinations module procedure dot_01 module procedure dot_10 @@ -130,9 +132,9 @@ module Tensor module procedure dot_04s_r4 module procedure dot_40_r4 module procedure dot_40s_r4 - end interface - - interface operator (**) + end interface + + interface operator (**) ! double dot-product of rank 1 and rank 2 tensor combinations module procedure ddot_22 module procedure ddot_2s2s @@ -144,9 +146,9 @@ module Tensor module procedure ddot_4s4s module procedure pow_2 module procedure pow_2s - end interface - - interface operator (.ddot.) + end interface + + interface operator (.ddot.) ! double dot-product of rank 1 and rank 2 tensor combinations module procedure ddot_22 module procedure ddot_2s2s @@ -156,14 +158,14 @@ module Tensor module procedure ddot_4s2s module procedure ddot_44 module procedure ddot_4s4s - end interface - - interface operator (.pow.) + end interface + + interface operator (.pow.) module procedure pow_2 module procedure pow_2s - end interface - - interface operator (+) + end interface + + interface operator (+) ! addition of rank 1 and rank 2 tensors module procedure add_11 module procedure add_22 @@ -174,8 +176,8 @@ module Tensor module procedure add_4s4s module procedure add_44s module procedure add_4s4 - end interface - interface operator (.add.) + end interface + interface operator (.add.) ! addition of rank 1 and rank 2 tensors module procedure add_11 module procedure add_22 @@ -186,9 +188,9 @@ module Tensor module procedure add_4s4s module procedure add_44s module procedure add_4s4 - end interface - - interface operator (-) + end interface + + interface operator (-) ! subtraction of rank 1 and rank 2 tensors module procedure sub_11 module procedure sub_22 @@ -199,8 +201,8 @@ module Tensor module procedure sub_4s4s module procedure sub_44s module procedure sub_4s4 - end interface - interface operator (.sub.) + end interface + interface operator (.sub.) ! subtraction of rank 1 and rank 2 tensors module procedure sub_11 module procedure sub_22 @@ -211,178 +213,178 @@ module Tensor module procedure sub_4s4s module procedure sub_44s module procedure sub_4s4 - end interface - - interface operator (.dya.) + end interface + + interface operator (.dya.) ! dyadic product of rank 2 and rank 4 tensor combinations module procedure dyadic_11 module procedure dyadic_22 module procedure dyadic_2s2s - end interface - - interface operator (.cdya.) + end interface + + interface operator (.cdya.) ! symmetric crossed dyadic product of rank 2 tensor combinations ! (i,j,k,l) = 1/2 * (i,k,j,l)*(i,l,j,k) module procedure crossdyadic_22 module procedure crossdyadic_2s2s - end interface - - interface fact + end interface + + interface fact module procedure fact_i - end interface - - interface tr + end interface + + interface tr module procedure tr_2 module procedure tr_2s - end interface - - interface det + end interface + + interface det module procedure det_2 module procedure det_2s - end interface - - interface dev + end interface + + interface dev module procedure dev_2 module procedure dev_2s - end interface - - interface unimodular + end interface + + interface unimodular module procedure unimod_2 module procedure unimod_2s module procedure unimod_2d module procedure unimod_2sd - end interface - - interface inv + end interface + + interface inv module procedure inv_2 module procedure inv_2s module procedure inv2d module procedure inv2sd - end interface - - interface norm + end interface + + interface norm module procedure norm_1 module procedure norm_2 module procedure norm_2s - end interface - - interface sqrt + end interface + + interface sqrt module procedure sqrt_1 module procedure sqrt_2 module procedure sqrt_2s - end interface - - interface dsqrt + end interface + + interface dsqrt module procedure sqrt_1 module procedure sqrt_2 module procedure sqrt_2s - end interface - - interface rotation_matrix + end interface + + interface rotation_matrix module procedure rotation_2 - end interface - - interface identity2 + end interface + + interface identity2 module procedure ident_2 module procedure ident_2s - end interface - - interface identity4 + end interface + + interface identity4 module procedure ident_4 module procedure ident_4s - end interface - - interface tensorstore + end interface + + interface tensorstore module procedure tenstore_2 module procedure tenstore_2a module procedure tenstore_2s module procedure tenstore_4 module procedure tenstore_4a module procedure tenstore_4s - end interface - - interface astensor + end interface + + interface astensor module procedure tenstore_2 module procedure tenstore_2a module procedure tenstore_2s module procedure tenstore_4 module procedure tenstore_4a module procedure tenstore_4s - end interface - - interface symstore + end interface + + interface symstore module procedure symstore_2 module procedure symstore_4 module procedure symstore_2s module procedure symstore_4s module procedure symstore_2sa module procedure symstore_4sa - end interface - - interface strain + end interface + + interface strain ! module procedure str2ten_2 module procedure str2ten_2s - end interface - - interface asvoigt + end interface + + interface asvoigt module procedure symstore_2 module procedure symstore_4 module procedure symstore_2s module procedure symstore_4s module procedure symstore_2sa module procedure symstore_4sa - end interface - - interface voigt + end interface + + interface voigt module procedure symstore_2 module procedure symstore_4 module procedure symstore_2s module procedure symstore_4s module procedure symstore_2sa module procedure symstore_4sa - end interface - - interface reduce_dim + end interface + + interface reduce_dim module procedure reduce_dim_2s module procedure reduce_dim_4s - end interface - - interface permute + end interface + + interface permute ! double dot-product of rank 1 and rank 2 tensor combinations module procedure permute_2 module procedure permute_2s module procedure permute_4 module procedure permute_4s - end interface - - interface transpose + end interface + + interface transpose module procedure transp2 module procedure transp2s module procedure transp4 module procedure transp4s - end interface - - interface piola + end interface + + interface piola module procedure piola2 module procedure piola2s module procedure piola4 module procedure piola4s - end interface - - interface asarray + end interface + + interface asarray module procedure asarray_1 module procedure asarray_2 module procedure asarray_4 module procedure asarray_2s module procedure asarray_4s - end interface - - interface asabqarray + end interface + + interface asabqarray module procedure asabqarray_2s module procedure asabqarray_4s - end interface - - interface assignment (=) + end interface + + interface assignment (=) module procedure assignscalar_1 module procedure assignscalar_2 module procedure assignscalar_2s @@ -406,60 +408,60 @@ module Tensor module procedure assignarr_2sr4 module procedure assignarr_4r4 module procedure assignarr_4sr4 - end interface -! ------END INTERFACE--------------------------------------- - - contains + end interface +!------END INTERFACE--------------------------------------- + +contains -! ------BEGIN FUNCTIONS------------------------------------- -! ------MATH TOOLS SECTION---------------------------------- - include 'ttb/libtools.f' -! ------+/- SECTION----------------------------------------- - include 'ttb/libadd.f' - include 'ttb/libsub.f' -! ------DIVISION SECTION------------------------------------ - include 'ttb/libdiv.f' -! ------DOT SECTION----------------------------------------- - include 'ttb/libdot.f' -! ------DOUBLE DOT SECTION---------------------------------- - include 'ttb/libddot.f' -! ------POWER SECTION--------------------------------------- - include 'ttb/libpower.f' -! ------DYADIC SECTION-------------------------------------- - include 'ttb/libdyadic.f' -! ------CROSS-DYADIC SECTION-------------------------------- - include 'ttb/libcrossdyadic.f' -! ------PERMUTE SECTION------------------------------------- - include 'ttb/libpermute.f' -! ------TENSOR FUNCTION SECTION----------------------------- - include 'ttb/libtransp.f' - include 'ttb/libtrace.f' - include 'ttb/libdet.f' - include 'ttb/libdev.f' - include 'ttb/libunimodular.f' - include 'ttb/libinv.f' - include 'ttb/libnorm.f' - include 'ttb/libsqrt.f' - include 'ttb/librotation.f' -! ------TENSOR INITIALIZATION SECTION----------------------- - include 'ttb/libidentity.f' -! ------SYMSTORE SECTION------------------------------------ - include 'ttb/libsymstore.f' -! ------USYMSTORE SECTION----------------------------------- - include 'ttb/libtenstore.f' -! ------STRAINSTORE SECTION--------------------------------- - include 'ttb/libstrainstore.f' -! ------REDUCE DIM. SECTION--------------------------------- - include 'ttb/libreducedim.f' -! ------AS ARRAY SECTION------------------------------------ - include 'ttb/libasarray.f' - include 'ttb/libasabqarray.f' -! ------PIOLA SECTION--------------------------------------- - include 'ttb/libpiola.f' -! ------END FUNCTIONS--------------------------------------- -! ------BEGIN SUBROUTINES----------------------------------- - include 'ttb/libassignscalar.f' - include 'ttb/libassignarray.f' - include 'ttb/libassignten2sym.f' +!------BEGIN FUNCTIONS------------------------------------- +!------MATH TOOLS SECTION---------------------------------- + include 'libtools.finc' +!------+/- SECTION----------------------------------------- + include 'libadd.finc' + include 'libsub.finc' +!------DIVISION SECTION------------------------------------ + include 'libdiv.finc' +!------DOT SECTION----------------------------------------- + include 'libdot.finc' +!------DOUBLE DOT SECTION---------------------------------- + include 'libddot.finc' +!------POWER SECTION--------------------------------------- + include 'libpower.finc' +!------DYADIC SECTION-------------------------------------- + include 'libdyadic.finc' +!------CROSS-DYADIC SECTION-------------------------------- + include 'libcrossdyadic.finc' +!------PERMUTE SECTION------------------------------------- + include 'libpermute.finc' +!------TENSOR FUNCTION SECTION----------------------------- + include 'libtransp.finc' + include 'libtrace.finc' + include 'libdet.finc' + include 'libdev.finc' + include 'libunimodular.finc' + include 'libinv.finc' + include 'libnorm.finc' + include 'libsqrt.finc' + include 'librotation.finc' +!------TENSOR INITIALIZATION SECTION----------------------- + include 'libidentity.finc' +!------SYMSTORE SECTION------------------------------------ + include 'libsymstore.finc' +!------USYMSTORE SECTION----------------------------------- + include 'libtenstore.finc' +!------STRAINSTORE SECTION--------------------------------- + include 'libstrainstore.finc' +!------REDUCE DIM. SECTION--------------------------------- + include 'libreducedim.finc' +!------AS ARRAY SECTION------------------------------------ + include 'libasarray.finc' + include 'libasabqarray.finc' +!------PIOLA SECTION--------------------------------------- + include 'libpiola.finc' +!------END FUNCTIONS--------------------------------------- +!------BEGIN SUBROUTINES----------------------------------- + include 'libassignscalar.finc' + include 'libassignarray.finc' + include 'libassignten2sym.finc' - end module Tensor +end module Tensor diff --git a/test/check.f90 b/test/check.f90 new file mode 100644 index 00000000..d7e3cba6 --- /dev/null +++ b/test/check.f90 @@ -0,0 +1,5 @@ +program check +implicit none + +print *, "Put some tests in here!" +end program check diff --git a/ttb/libadd.f b/ttb/libadd.f deleted file mode 100644 index b55610b2..00000000 --- a/ttb/libadd.f +++ /dev/null @@ -1,94 +0,0 @@ - function add_11(T1, T2) - implicit none - - type(Tensor1), intent(in) :: T1, T2 - type(Tensor1) :: add_11 - - add_11%a = T1%a + T2%a - - end function add_11 - - function add_22(T1, T2) - implicit none - - type(Tensor2), intent(in) :: T1, T2 - type(Tensor2) :: add_22 - - add_22%ab = T1%ab + T2%ab - - end function add_22 - - function add_2s2s(T1, T2) - implicit none - - type(Tensor2s), intent(in) :: T1, T2 - type(Tensor2s) :: add_2s2s - - add_2s2s%a6 = T1%a6 + T2%a6 - - end function add_2s2s - - function add_22s(T1, T2) - implicit none - - type(Tensor2), intent(in) :: T1 - type(Tensor2s), intent(in) :: T2 - type(Tensor2) :: add_22s - - add_22s = T1 + astensor(T2) - - end function add_22s - - function add_2s2(T1, T2) - implicit none - - type(Tensor2s), intent(in) :: T1 - type(Tensor2), intent(in) :: T2 - type(Tensor2) :: add_2s2 - - add_2s2 = astensor(T1) + T2 - - end function add_2s2 - - function add_44(T1, T2) - implicit none - - type(Tensor4), intent(in) :: T1, T2 - type(Tensor4) :: add_44 - - add_44%abcd = T1%abcd + T2%abcd - - end function add_44 - - function add_4s4s(T1, T2) - implicit none - - type(Tensor4s), intent(in) :: T1, T2 - type(Tensor4s) :: add_4s4s - - add_4s4s%a6b6 = T1%a6b6 + T2%a6b6 - - end function add_4s4s - - function add_44s(T1, T2) - implicit none - - type(Tensor4), intent(in) :: T1 - type(Tensor4s), intent(in) :: T2 - type(Tensor4) :: add_44s - - add_44s = T1 + astensor(T2) - - end function add_44s - - function add_4s4(T1, T2) - implicit none - - type(Tensor4s), intent(in) :: T1 - type(Tensor4), intent(in) :: T2 - type(Tensor4) :: add_4s4 - - add_4s4 = astensor(T1) + T2 - - end function add_4s4 - \ No newline at end of file diff --git a/ttb/libasabqarray.f b/ttb/libasabqarray.f deleted file mode 100644 index a889cafa..00000000 --- a/ttb/libasabqarray.f +++ /dev/null @@ -1,37 +0,0 @@ -! ------AS ABAQUS ARRAY SECTION------------------- - function asabqarray_2s(T,i,j) - implicit none - - type(Tensor2s), intent(in) :: T - integer, intent(in) :: i - integer, intent(in), optional :: j - real(kind=8), dimension(i) :: asabqarray_2s - integer :: i1 - - asabqarray_2s(1:min(i,4)) = T%a6(1:min(i,4)) - - if (i.ge.5) then - asabqarray_2s(5) = T%a6(6) - end if - - if (i.ge.6) then - asabqarray_2s(6) = T%a6(5) - endif - - end function asabqarray_2s - - function asabqarray_4s(T,i,j) - implicit none - - type(Tensor4s), intent(in) :: T - integer, intent(in) :: i,j - real(kind=8), dimension(i,j) :: asabqarray_4s - integer, dimension(6) :: imap - integer :: i1,j1 - - imap = (/1,2,3,4,6,5/) - - forall (i1=1:i,j1=1:j) asabqarray_4s(i1,j1) = - * T%a6b6(imap(i1),imap(j1)) - - end function asabqarray_4s \ No newline at end of file diff --git a/ttb/libasarray.f b/ttb/libasarray.f deleted file mode 100644 index 7d95bc54..00000000 --- a/ttb/libasarray.f +++ /dev/null @@ -1,59 +0,0 @@ -! ------AS ARRAY SECTION------------------------------------ - function asarray_1(T,i,j,k,l) - implicit none - - type(Tensor1), intent(in) :: T - integer, intent(in) :: i - integer, intent(in), optional :: j,k,l - real(kind=8), dimension(i) :: asarray_1 - - asarray_1 = T%a(1:i) - - end function asarray_1 - - function asarray_2(T,i,j,k,l) - implicit none - - type(Tensor2), intent(in) :: T - integer, intent(in) :: i,j - integer, intent(in), optional :: k,l - real(kind=8), dimension(i,j) :: asarray_2 - - asarray_2 = T%ab(1:i,1:j) - - end function asarray_2 - - function asarray_2s(T,i,j,k,l) - implicit none - - type(Tensor2s), intent(in) :: T - integer, intent(in) :: i - integer, intent(in), optional :: j,k,l - real(kind=8), dimension(i) :: asarray_2s - - asarray_2s = T%a6(1:i) - - end function asarray_2s - - function asarray_4(T,i,j,k,l) - implicit none - - type(Tensor4), intent(in) :: T - integer, intent(in) :: i,j,k,l - real(kind=8), dimension(i,j,k,l) :: asarray_4 - - asarray_4 = T%abcd(1:i,1:j,1:k,1:l) - - end function asarray_4 - - function asarray_4s(T,i,j,k,l) - implicit none - - type(Tensor4s), intent(in) :: T - integer, intent(in) :: i,j - integer, intent(in), optional :: k,l - real(kind=8), dimension(i,j) :: asarray_4s - - asarray_4s = T%a6b6(1:i,1:j) - - end function asarray_4s \ No newline at end of file diff --git a/ttb/libassignarray.f b/ttb/libassignarray.f deleted file mode 100644 index 91588153..00000000 --- a/ttb/libassignarray.f +++ /dev/null @@ -1,99 +0,0 @@ - subroutine assignarr_2s(T,A) - implicit none - - type(Tensor2s), intent(inout) :: T - real(kind=8), dimension(6), intent(in) :: A - - T%a6 = A - - end subroutine assignarr_2s - - subroutine assignarr_2sr4(T,A) - implicit none - - type(Tensor2s), intent(inout) :: T - real(kind=4), dimension(6), intent(in) :: A - - T%a6 = dble(A) - - end subroutine assignarr_2sr4 - - subroutine assignarr_4s(T,A) - implicit none - - type(Tensor4s), intent(inout) :: T - real(kind=8), dimension(6,6), intent(in) :: A - - T%a6b6 = A - - end subroutine assignarr_4s - - subroutine assignarr_4sr4(T,A) - implicit none - - type(Tensor4s), intent(inout) :: T - real(kind=4), dimension(6,6), intent(in) :: A - - T%a6b6 = dble(A) - - end subroutine assignarr_4sr4 - - subroutine assignarr_1(T,A) - implicit none - - type(Tensor1), intent(inout) :: T - real(kind=8), dimension(3), intent(in) :: A - - T%a = A - - end subroutine assignarr_1 - - subroutine assignarr_1r4(T,A) - implicit none - - type(Tensor1), intent(inout) :: T - real(kind=4), dimension(3), intent(in) :: A - - T%a = dble(A) - - end subroutine assignarr_1r4 - - subroutine assignarr_2(T,A) - implicit none - - type(Tensor2), intent(inout) :: T - real(kind=8), dimension(3,3), intent(in) :: A - - T%ab = A - - end subroutine assignarr_2 - - subroutine assignarr_2r4(T,A) - implicit none - - type(Tensor2), intent(inout) :: T - real(kind=4), dimension(3,3), intent(in) :: A - - T%ab = dble(A) - - end subroutine assignarr_2r4 - - subroutine assignarr_4(T,A) - implicit none - - type(Tensor4), intent(inout) :: T - real(kind=8), dimension(3,3,3,3), intent(in) :: A - - T%abcd = A - - end subroutine assignarr_4 - - subroutine assignarr_4r4(T,A) - implicit none - - type(Tensor4), intent(inout) :: T - real(kind=4), dimension(3,3,3,3), intent(in) :: A - - T%abcd = dble(A) - - end subroutine assignarr_4r4 \ No newline at end of file diff --git a/ttb/libassignscalar.f b/ttb/libassignscalar.f deleted file mode 100644 index 4a5bd637..00000000 --- a/ttb/libassignscalar.f +++ /dev/null @@ -1,99 +0,0 @@ - subroutine assignscalar_2s(T,w) - implicit none - - type(Tensor2s), intent(inout) :: T - real(kind=8), intent(in) :: w - - T%a6 = w - - end subroutine assignscalar_2s - - subroutine assignscalar_2sr4(T,w) - implicit none - - type(Tensor2s), intent(inout) :: T - real(kind=4), intent(in) :: w - - T%a6 = dble(w) - - end subroutine assignscalar_2sr4 - - subroutine assignscalar_4s(T,w) - implicit none - - type(Tensor4s), intent(inout) :: T - real(kind=8), intent(in) :: w - - T%a6b6 = w - - end subroutine assignscalar_4s - - subroutine assignscalar_4sr4(T,w) - implicit none - - type(Tensor4s), intent(inout) :: T - real(kind=4), intent(in) :: w - - T%a6b6 = dble(w) - - end subroutine assignscalar_4sr4 - - subroutine assignscalar_1(T,w) - implicit none - - type(Tensor1), intent(inout) :: T - real(kind=8), intent(in) :: w - - T%a = w - - end subroutine assignscalar_1 - - subroutine assignscalar_1r4(T,w) - implicit none - - type(Tensor1), intent(inout) :: T - real(kind=4), intent(in) :: w - - T%a = dble(w) - - end subroutine assignscalar_1r4 - - subroutine assignscalar_2(T,w) - implicit none - - type(Tensor2), intent(inout) :: T - real(kind=8), intent(in) :: w - - T%ab = w - - end subroutine assignscalar_2 - - subroutine assignscalar_2r4(T,w) - implicit none - - type(Tensor2), intent(inout) :: T - real(kind=4), intent(in) :: w - - T%ab = dble(w) - - end subroutine assignscalar_2r4 - - subroutine assignscalar_4(T,w) - implicit none - - type(Tensor4), intent(inout) :: T - real(kind=8), intent(in) :: w - - T%abcd = w - - end subroutine assignscalar_4 - - subroutine assignscalar_4r4(T,w) - implicit none - - type(Tensor4), intent(inout) :: T - real(kind=4), intent(in) :: w - - T%abcd = dble(w) - - end subroutine assignscalar_4r4 diff --git a/ttb/libassignten2sym.f b/ttb/libassignten2sym.f deleted file mode 100644 index 22301ec0..00000000 --- a/ttb/libassignten2sym.f +++ /dev/null @@ -1,39 +0,0 @@ - subroutine assignten2sym_2(T,A) - implicit none - - type(Tensor2s), intent(inout) :: T - type(Tensor2), intent(in) :: A - - T = voigt(A) - - end subroutine assignten2sym_2 - - subroutine assignten2sym_4(T,A) - implicit none - - type(Tensor4s), intent(inout) :: T - type(Tensor4), intent(in) :: A - - T = voigt(A) - - end subroutine assignten2sym_4 - - subroutine assignsym2ten_2(T,A) - implicit none - - type(Tensor2), intent(inout) :: T - type(Tensor2s), intent(in) :: A - - T = astensor(A) - - end subroutine assignsym2ten_2 - - subroutine assignsym2ten_4(T,A) - implicit none - - type(Tensor4), intent(inout) :: T - type(Tensor4s), intent(in) :: A - - T = astensor(A) - - end subroutine assignsym2ten_4 \ No newline at end of file diff --git a/ttb/libcrossdyadic.f b/ttb/libcrossdyadic.f deleted file mode 100644 index 74a58030..00000000 --- a/ttb/libcrossdyadic.f +++ /dev/null @@ -1,44 +0,0 @@ - function crossdyadic_22(T1, T2) - implicit none - - type(Tensor2), intent(in) :: T1, T2 - type(Tensor4) :: crossdyadic_22 - integer i, j, k, l - - forall(i=1:3,j=1:3,k=1:3,l=1:3) crossdyadic_22%abcd(i,j,k,l) - * = (T1%ab(i,k) * T2%ab(j,l) + T1%ab(i,l) * T2%ab(j,k) + - * T2%ab(i,k) * T1%ab(j,l) + T2%ab(i,l) * T1%ab(j,k))/4.d0 - - end function crossdyadic_22 - - function crossdyadic_2s2s(T1, T2) - implicit none - - type(Tensor2s), intent(in) :: T1, T2 - type(Tensor4s) :: crossdyadic_2s2s - integer :: i,j,k,l - integer, dimension(3,3) :: i6 - - i6 = reshape( (/1,4,6, 4,2,5, 6,5,3/), (/3, 3/) ) - - crossdyadic_2s2s%a6b6 = 0.d0 - - do i=1,3 - do j=1,3 - if (i.le.j) then - do k=1,3 - do l=1,3 - if (k.le.l) then - crossdyadic_2s2s%a6b6(i6(i,j),i6(k,l)) - * = ( T1%a6(i6(i,k)) * T2%a6(i6(j,l)) - * +T1%a6(i6(i,l)) * T2%a6(i6(j,k)) - * +T2%a6(i6(i,k)) * T1%a6(i6(j,l)) - * +T2%a6(i6(i,l)) * T1%a6(i6(j,k)) )/4.d0 - end if - end do - end do - end if - end do - end do - - end function crossdyadic_2s2s diff --git a/ttb/libddot.f b/ttb/libddot.f deleted file mode 100644 index b628fc21..00000000 --- a/ttb/libddot.f +++ /dev/null @@ -1,177 +0,0 @@ - function ddot_22(T1, T2) - implicit none - - type(Tensor2), intent(in) :: T1 - type(Tensor2), intent(in) :: T2 - real(kind=8) :: ddot_22 - integer :: i,j - - ddot_22 = 0.d0 - do i = 1,3 - do j = 1,3 - ddot_22 = ddot_22 + T1%ab(i,j)*T2%ab(i,j) - enddo - enddo - - end function ddot_22 - - function ddot_2s2s(T1, T2) - implicit none - - type(Tensor2s), intent(in) :: T1 - type(Tensor2s), intent(in) :: T2 - real(kind=8) :: ddot_2s2s - integer :: i - - ddot_2s2s = 0.d0 - do i=1,3 - ddot_2s2s = ddot_2s2s + T1%a6(i)*T2%a6(i) - enddo - do i=4,6 - ddot_2s2s = ddot_2s2s + T1%a6(i)*T2%a6(i)*2.d0 - enddo - - end function ddot_2s2s - - function ddot_24(T1, T2) - implicit none - - type(Tensor2), intent(in) :: T1 - type(Tensor4), intent(in) :: T2 - type(Tensor2) :: ddot_24 - integer :: i,j,k,l - - ddot_24%ab = 0.d0 - do i = 1,3 - do j = 1,3 - do k = 1,3 - do l = 1,3 - ddot_24%ab(k,l) = ddot_24%ab(k,l) - * + T1%ab(i,j)*T2%abcd(i,j,k,l) - enddo - enddo - enddo - enddo - - end function ddot_24 - - function ddot_2s4s(T1, T2) - implicit none - - type(Tensor2s), intent(in) :: T1 - type(Tensor4s), intent(in) :: T2 - type(Tensor2s) :: ddot_2s4s - real(kind=8) :: w - integer :: i,j - - ddot_2s4s%a6 = 0.d0 - do i = 1,6 - do j = 1,6 - if (i > 3) then - w = 2.d0 - else - w = 1.d0 - endif - ddot_2s4s%a6(j) = ddot_2s4s%a6(j) - * + T1%a6(i)*T2%a6b6(i,j)*w - enddo - enddo - - end function ddot_2s4s - - function ddot_42(T1, T2) - implicit none - - type(Tensor4), intent(in) :: T1 - type(Tensor2), intent(in) :: T2 - type(Tensor2) :: ddot_42 - integer :: i,j,k,l - - ddot_42%ab = 0.d0 - do i = 1,3 - do j = 1,3 - do k = 1,3 - do l = 1,3 - ddot_42%ab(i,j) = ddot_42%ab(i,j) - * + T1%abcd(i,j,k,l)*T2%ab(k,l) - enddo - enddo - enddo - enddo - - end function ddot_42 - - function ddot_4s2s(T1, T2) - implicit none - - type(Tensor4s), intent(in) :: T1 - type(Tensor2s), intent(in) :: T2 - type(Tensor2s) :: ddot_4s2s - real(kind=8) :: w - integer :: i,j - - ddot_4s2s%a6 = 0.d0 - do i = 1,6 - do j = 1,6 - if (j > 3) then - w = 2.d0 - else - w = 1.d0 - endif - ddot_4s2s%a6(i) = ddot_4s2s%a6(i) - * + T1%a6b6(i,j)*T2%a6(j)*w - enddo - enddo - - end function ddot_4s2s - - function ddot_44(T1, T2) - implicit none - - type(Tensor4), intent(in) :: T1 - type(Tensor4), intent(in) :: T2 - type(Tensor4) :: ddot_44 - integer :: i,j,k,l,m,n - - ddot_44%abcd = 0.d0 - do i = 1,3 - do j = 1,3 - do m = 1,3 - do n = 1,3 - do k = 1,3 - do l = 1,3 - ddot_44%abcd(i,j,k,l) = ddot_44%abcd(i,j,k,l) - * + T1%abcd(i,j,m,n)*T2%abcd(m,n,k,l) - enddo - enddo - enddo - enddo - enddo - enddo - end function ddot_44 - - function ddot_4s4s(T1, T2) - implicit none - - type(Tensor4s), intent(in) :: T1 - type(Tensor4s), intent(in) :: T2 - type(Tensor4s) :: ddot_4s4s - real(kind=8) :: w - integer :: i,j,k - - ddot_4s4s%a6b6 = 0.d0 - do i = 1,6 - do k = 1,6 - do j = 1,6 - if (k > 3) then - w = 2.d0 - else - w = 1.d0 - endif - ddot_4s4s%a6b6(i,j) = ddot_4s4s%a6b6(i,j) - * + T1%a6b6(i,k)*T2%a6b6(k,j)*w - enddo - enddo - enddo - - end function ddot_4s4s \ No newline at end of file diff --git a/ttb/libdet.f b/ttb/libdet.f deleted file mode 100644 index ef7164f3..00000000 --- a/ttb/libdet.f +++ /dev/null @@ -1,27 +0,0 @@ - function det_2(T) - implicit none - - type(Tensor2) :: T - real(kind=8) :: det_2 - - det_2 = T%ab(1,1)*(T%ab(2,2)*T%ab(3,3)-T%ab(2,3)*T%ab(3,2)) - * + T%ab(1,2)*(T%ab(2,3)*T%ab(3,1)-T%ab(2,1)*T%ab(3,3)) - * + T%ab(1,3)*(T%ab(2,1)*T%ab(3,2)-T%ab(2,2)*T%ab(3,1)) - - end function det_2 - - function det_2s(T) - implicit none - - type(Tensor2s), intent(in) :: T - real(kind=8) :: det_2s - - det_2s = T%a6(1)*T%a6(2)*T%a6(3) - * + T%a6(4)*T%a6(5)*T%a6(6) - * + T%a6(6)*T%a6(4)*T%a6(5) - * - T%a6(6)*T%a6(2)*T%a6(6) - * - T%a6(5)*T%a6(5)*T%a6(1) - * - T%a6(3)*T%a6(4)*T%a6(4) - - end function det_2s - \ No newline at end of file diff --git a/ttb/libdev.f b/ttb/libdev.f deleted file mode 100644 index 115f6a14..00000000 --- a/ttb/libdev.f +++ /dev/null @@ -1,21 +0,0 @@ - function dev_2(T) - implicit none - - type(Tensor2), intent(in) :: T - type(Tensor2) :: dev_2,Eye - - Eye = identity2(Eye) - dev_2%ab = T%ab - tr(T)/3.d0*Eye%ab - - end function dev_2 - - function dev_2s(T) - implicit none - - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: dev_2s,Eye - - Eye = identity2(Eye) - dev_2s%a6 = T%a6 - tr(T)/3.d0*Eye%a6 - - end function dev_2s diff --git a/ttb/libdiv.f b/ttb/libdiv.f deleted file mode 100644 index 91f4ab50..00000000 --- a/ttb/libdiv.f +++ /dev/null @@ -1,110 +0,0 @@ -! ------REAL(KIND=8)-------------------------------------- - function div_10(T, w) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor1), intent(in) :: T - type(Tensor1) :: div_10 - - div_10%a = T%a / w - - end function div_10 - - function div_20(T, w) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor2), intent(in) :: T - type(Tensor2) :: div_20 - - div_20%ab = T%ab / w - - end function div_20 - - function div_20s(T, w) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: div_20s - - div_20s%a6 = T%a6 / w - - end function div_20s - - function div_40(T, w) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor4), intent(in) :: T - type(Tensor4) :: div_40 - - div_40%abcd = T%abcd / w - - end function div_40 - - function div_40s(T, w) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor4s), intent(in) :: T - type(Tensor4s) :: div_40s - - div_40s%a6b6 = T%a6b6 / w - - end function div_40s -! ------REAL(KIND=4)---------------------------------------- - function div_10_r4(T, w) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor1), intent(in) :: T - type(Tensor1) :: div_10_r4 - - div_10_r4%a = T%a / dble(w) - - end function div_10_r4 - - function div_20_r4(T, w) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor2), intent(in) :: T - type(Tensor2) :: div_20_r4 - - div_20_r4%ab = T%ab / dble(w) - - end function div_20_r4 - - function div_20s_r4(T, w) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: div_20s_r4 - - div_20s_r4%a6 = T%a6 / dble(w) - - end function div_20s_r4 - - function div_40_r4(T, w) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor4), intent(in) :: T - type(Tensor4) :: div_40_r4 - - div_40_r4%abcd = T%abcd / dble(w) - - end function div_40_r4 - - function div_40s_r4(T, w) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor4s), intent(in) :: T - type(Tensor4s) :: div_40s_r4 - - div_40s_r4%a6b6 = T%a6b6 / dble(w) - - end function div_40s_r4 \ No newline at end of file diff --git a/ttb/libdot.f b/ttb/libdot.f deleted file mode 100644 index c1c47a30..00000000 --- a/ttb/libdot.f +++ /dev/null @@ -1,341 +0,0 @@ -! ------DOT SECTION----------------------------------------- -! ------SIMPLE DOT SECTION---------------------------------- -! ------REAL(KIND=8)---------------------------------------- - function dot_01(w, T) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor1), intent(in) :: T - type(Tensor1) :: dot_01 - - dot_01%a = w * T%a - - end function dot_01 - - function dot_10(T, w) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor1), intent(in) :: T - type(Tensor1) :: dot_10 - - dot_10%a = w * T%a - - end function dot_10 - - function dot_02(w, T) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor2), intent(in) :: T - type(Tensor2) :: dot_02 - - dot_02%ab = w * T%ab - - end function dot_02 - - function dot_02s(w, T) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: dot_02s - - dot_02s%a6 = w * T%a6 - - end function dot_02s - - function dot_20(T, w) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor2), intent(in) :: T - type(Tensor2) :: dot_20 - - dot_20%ab = w * T%ab - - end function dot_20 - - function dot_20s(T, w) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: dot_20s - - dot_20s%a6 = w * T%a6 - - end function dot_20s - - function dot_04(w, T) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor4), intent(in) :: T - type(Tensor4) :: dot_04 - - dot_04%abcd = w * T%abcd - - end function dot_04 - - function dot_04s(w, T) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor4s), intent(in) :: T - type(Tensor4s) :: dot_04s - - dot_04s%a6b6 = w * T%a6b6 - - end function dot_04s - - function dot_40(T, w) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor4), intent(in) :: T - type(Tensor4) :: dot_40 - - dot_40%abcd = w * T%abcd - - end function dot_40 - - function dot_40s(T, w) - implicit none - - real(kind=8), intent(in) :: w - type(Tensor4s), intent(in) :: T - type(Tensor4s) :: dot_40s - - dot_40s%a6b6 = w * T%a6b6 - - end function dot_40s -! ------REAL(KIND=4)---------------------------------------- - function dot_01_r4(w, T) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor1), intent(in) :: T - type(Tensor1) :: dot_01_r4 - - dot_01_r4%a = dble(w) * T%a - - end function dot_01_r4 - - function dot_10_r4(T, w) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor1), intent(in) :: T - type(Tensor1) :: dot_10_r4 - - dot_10_r4%a = dble(w) * T%a - - end function dot_10_r4 - - function dot_02_r4(w, T) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor2), intent(in) :: T - type(Tensor2) :: dot_02_r4 - - dot_02_r4%ab = dble(w) * T%ab - - end function dot_02_r4 - - function dot_02s_r4(w, T) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: dot_02s_r4 - - dot_02s_r4%a6 = dble(w) * T%a6 - - end function dot_02s_r4 - - function dot_20_r4(T, w) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor2), intent(in) :: T - type(Tensor2) :: dot_20_r4 - - dot_20_r4%ab = dble(w) * T%ab - - end function dot_20_r4 - - function dot_20s_r4(T, w) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: dot_20s_r4 - - dot_20s_r4%a6 = dble(w) * T%a6 - - end function dot_20s_r4 - - function dot_04_r4(w, T) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor4), intent(in) :: T - type(Tensor4) :: dot_04_r4 - - dot_04_r4%abcd = dble(w) * T%abcd - - end function dot_04_r4 - - function dot_04s_r4(w, T) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor4s), intent(in) :: T - type(Tensor4s) :: dot_04s_r4 - - dot_04s_r4%a6b6 = dble(w) * T%a6b6 - - end function dot_04s_r4 - - function dot_40_r4(T, w) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor4), intent(in) :: T - type(Tensor4) :: dot_40_r4 - - dot_40_r4%abcd = dble(w) * T%abcd - - end function dot_40_r4 - - function dot_40s_r4(T, w) - implicit none - - real(kind=4), intent(in) :: w - type(Tensor4s), intent(in) :: T - type(Tensor4s) :: dot_40s_r4 - - dot_40s_r4%a6b6 = dble(w) * T%a6b6 - - end function dot_40s_r4 - -! ------REAL(KIND=8)---------------------------------------- - function dot_21(T1, T2) - implicit none - - type(Tensor2), intent(in) :: T1 - type(Tensor1), intent(in) :: T2 - type(Tensor1) :: dot_21 - integer :: i, j - - do i = 1,3 - dot_21%a(i) = 0.d0 - do j = 1,3 - dot_21%a(i) = dot_21%a(i) + T1%ab(i,j)*T2%a(j) - enddo - enddo - - end function dot_21 - - function dot_2s1(T1, T2) - implicit none - - type(Tensor2s), intent(in) :: T1 - type(Tensor1), intent(in) :: T2 - type(Tensor1) :: dot_2s1 - - dot_2s1%a(1)=T1%a6(1)*T2%a(1)+T1%a6(4)*T2%a(2)+T1%a6(6)*T2%a(3) - dot_2s1%a(2)=T1%a6(4)*T2%a(1)+T1%a6(2)*T2%a(2)+T1%a6(5)*T2%a(3) - dot_2s1%a(3)=T1%a6(6)*T2%a(1)+T1%a6(5)*T2%a(2)+T1%a6(3)*T2%a(3) - - end function dot_2s1 - - function dot_12(T1, T2) - implicit none - - type(Tensor1), intent(in) :: T1 - type(Tensor2), intent(in) :: T2 - type(Tensor1) :: dot_12 - integer :: i, j - - do i = 1,3 - dot_12%a(i) = 0.d0 - do j = 1,3 - dot_12%a(i) = dot_12%a(i) + T1%a(j)*T2%ab(j,i) - enddo - enddo - - end function dot_12 - - function dot_12s(T1, T2) - implicit none - - type(Tensor2s), intent(in) :: T2 - type(Tensor1), intent(in) :: T1 - type(Tensor1) :: dot_12s - - dot_12s%a(1)=T1%a(1)*T2%a6(1)+T1%a(2)*T2%a6(4)+T1%a(3)*T2%a6(6) - dot_12s%a(2)=T1%a(1)*T2%a6(4)+T1%a(2)*T2%a6(2)+T1%a(3)*T2%a6(5) - dot_12s%a(3)=T1%a(1)*T2%a6(6)+T1%a(2)*T2%a6(5)+T1%a(3)*T2%a6(3) - - end function dot_12s - - function dot_11(T1, T2) - implicit none - - type(Tensor1), intent(in) :: T1 - type(Tensor1), intent(in) :: T2 - real(kind=8) :: dot_11 - integer :: i - - dot_11 = 0.d0 - do i = 1,3 - dot_11 = dot_11 + T1%a(i)*T2%a(i) - enddo - end function dot_11 - - function dot_22(T1, T2) - implicit none - - type(Tensor2), intent(in) :: T1 - type(Tensor2), intent(in) :: T2 - type(Tensor2) :: dot_22 - integer :: i,j,k - - dot_22%ab = 0.d0 - do i = 1,3 - do j = 1,3 - do k = 1,3 - dot_22%ab(i,j) = dot_22%ab(i,j) + T1%ab(i,k)*T2%ab(k,j) - enddo - enddo - enddo - end function dot_22 - - function dot_2s2s(T1, T2) - implicit none - - type(Tensor2s), intent(in) :: T1, T2 - type(Tensor2) :: dot_2s2s - - dot_2s2s%ab(1,1) = T1%a6(1)*T2%a6(1)+T1%a6(4)*T2%a6(4) - * +T1%a6(6)*T2%a6(6) - dot_2s2s%ab(2,2) = T1%a6(4)*T2%a6(4)+T1%a6(2)*T2%a6(2) - * +T1%a6(5)*T2%a6(5) - dot_2s2s%ab(3,3) = T1%a6(6)*T2%a6(6)+T1%a6(5)*T2%a6(5) - * +T1%a6(3)*T2%a6(3) - dot_2s2s%ab(1,2) = T1%a6(1)*T2%a6(4)+T1%a6(4)*T2%a6(2) - * +T1%a6(6)*T2%a6(5) - dot_2s2s%ab(2,1) = T1%a6(4)*T2%a6(1)+T1%a6(2)*T2%a6(4) - * +T1%a6(5)*T2%a6(6) - dot_2s2s%ab(2,3) = T1%a6(4)*T2%a6(6)+T1%a6(2)*T2%a6(5) - * +T1%a6(5)*T2%a6(3) - dot_2s2s%ab(3,2) = T1%a6(6)*T2%a6(4)+T1%a6(5)*T2%a6(2) - * +T1%a6(3)*T2%a6(5) - dot_2s2s%ab(1,3) = T1%a6(1)*T2%a6(6)+T1%a6(4)*T2%a6(5) - * +T1%a6(6)*T2%a6(3) - dot_2s2s%ab(3,1) = T1%a6(6)*T2%a6(1)+T1%a6(5)*T2%a6(4) - * +T1%a6(3)*T2%a6(6) - end function dot_2s2s diff --git a/ttb/libdyadic.f b/ttb/libdyadic.f deleted file mode 100644 index 45960ed6..00000000 --- a/ttb/libdyadic.f +++ /dev/null @@ -1,33 +0,0 @@ - function dyadic_11(T1, T2) - implicit none - - type(Tensor1), intent(in) :: T1, T2 - type(Tensor2) :: dyadic_11 - integer i, j - - forall(i=1:3,j=1:3) dyadic_11%ab(i,j) = T1%a(i) * T2%a(j) - - end function dyadic_11 - - function dyadic_22(T1, T2) - implicit none - - type(Tensor2), intent(in) :: T1, T2 - type(Tensor4) :: dyadic_22 - integer i, j, k, l - - forall(i=1:3,j=1:3,k=1:3,l=1:3) dyadic_22%abcd(i,j,k,l) - * = T1%ab(i,j) * T2%ab(k,l) - - end function dyadic_22 - - function dyadic_2s2s(T1, T2) - implicit none - - type(Tensor2s), intent(in) :: T1, T2 - type(Tensor4s) :: dyadic_2s2s - integer i, j - - forall(i=1:6,j=1:6) dyadic_2s2s%a6b6(i,j) = T1%a6(i) * T2%a6(j) - - end function dyadic_2s2s \ No newline at end of file diff --git a/ttb/libidentity.f b/ttb/libidentity.f deleted file mode 100644 index a7b68ab2..00000000 --- a/ttb/libidentity.f +++ /dev/null @@ -1,47 +0,0 @@ - function ident_2(T) - implicit none - - type(Tensor2), intent(in) :: T - type(Tensor2) :: ident_2 - integer :: i - - ident_2%ab = 0.d0 - do i = 1,3 - ident_2%ab(i,i) = 1.d0 - enddo - - end function ident_2 - - function ident_2s(T) - implicit none - - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: ident_2s - integer :: i - - ident_2s%a6 = 0.d0 - do i = 1,3 - ident_2s%a6(i) = 1.d0 - enddo - - end function ident_2s - - function ident_4(T) - implicit none - - type(Tensor2), intent(in) :: T - type(Tensor4) :: ident_4 - - ident_4 = T.cdya.T - - end function ident_4 - - function ident_4s(T) - implicit none - - type(Tensor2s), intent(in) :: T - type(Tensor4s) :: ident_4s - - ident_4s = T.cdya.T - - end function ident_4s diff --git a/ttb/libinv.f b/ttb/libinv.f deleted file mode 100644 index b2d1c95f..00000000 --- a/ttb/libinv.f +++ /dev/null @@ -1,77 +0,0 @@ - function inv_2(T) - implicit none - - type(Tensor2), intent(in) :: T - type(Tensor2) :: inv_2 - real(kind=8) :: idetT - - idetT = 1.d0/det(T) - - inv_2%ab(1,1)=+idetT*(T%ab(2,2)*T%ab(3,3)-T%ab(2,3)*T%ab(3,2)) - inv_2%ab(2,1)=-idetT*(T%ab(2,1)*T%ab(3,3)-T%ab(2,3)*T%ab(3,1)) - inv_2%ab(3,1)=+idetT*(T%ab(2,1)*T%ab(3,2)-T%ab(2,2)*T%ab(3,1)) - inv_2%ab(1,2)=-idetT*(T%ab(1,2)*T%ab(3,3)-T%ab(1,3)*T%ab(3,2)) - inv_2%ab(2,2)=+idetT*(T%ab(1,1)*T%ab(3,3)-T%ab(1,3)*T%ab(3,1)) - inv_2%ab(3,2)=-idetT*(T%ab(1,1)*T%ab(3,2)-T%ab(1,2)*T%ab(3,1)) - inv_2%ab(1,3)=+idetT*(T%ab(1,2)*T%ab(2,3)-T%ab(1,3)*T%ab(2,2)) - inv_2%ab(2,3)=-idetT*(T%ab(1,1)*T%ab(2,3)-T%ab(1,3)*T%ab(2,1)) - inv_2%ab(3,3)=+idetT*(T%ab(1,1)*T%ab(2,2)-T%ab(1,2)*T%ab(2,1)) - - end function inv_2 - - function inv_2s(T) - implicit none - - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: inv_2s - real(kind=8) :: idetT - - idetT = 1.d0/det(T) - - inv_2s%a6(1)=+idetT*(T%a6(2)*T%a6(3) -T%a6(5)*T%a6(5)) - inv_2s%a6(4)=-idetT*(T%a6(4)*T%a6(3) -T%a6(5)*T%a6(6)) - inv_2s%a6(6)=+idetT*(T%a6(4)*T%a6(5) -T%a6(2)*T%a6(6)) - inv_2s%a6(2)=+idetT*(T%a6(1)*T%a6(3) -T%a6(6)*T%a6(6)) - inv_2s%a6(5)=-idetT*(T%a6(1)*T%a6(5) -T%a6(4)*T%a6(6)) - inv_2s%a6(3)=+idetT*(T%a6(1)*T%a6(2) -T%a6(4)*T%a6(4)) - - end function inv_2s - - function inv2d(T,detT) - implicit none - - type(Tensor2), intent(in) :: T - type(Tensor2) :: inv2d - real(kind=8) :: detT, idetT - - idetT = 1.d0/detT - - inv2d%ab(1,1)=+idetT*(T%ab(2,2)*T%ab(3,3)-T%ab(2,3)*T%ab(3,2)) - inv2d%ab(2,1)=-idetT*(T%ab(2,1)*T%ab(3,3)-T%ab(2,3)*T%ab(3,1)) - inv2d%ab(3,1)=+idetT*(T%ab(2,1)*T%ab(3,2)-T%ab(2,2)*T%ab(3,1)) - inv2d%ab(1,2)=-idetT*(T%ab(1,2)*T%ab(3,3)-T%ab(1,3)*T%ab(3,2)) - inv2d%ab(2,2)=+idetT*(T%ab(1,1)*T%ab(3,3)-T%ab(1,3)*T%ab(3,1)) - inv2d%ab(3,2)=-idetT*(T%ab(1,1)*T%ab(3,2)-T%ab(1,2)*T%ab(3,1)) - inv2d%ab(1,3)=+idetT*(T%ab(1,2)*T%ab(2,3)-T%ab(1,3)*T%ab(2,2)) - inv2d%ab(2,3)=-idetT*(T%ab(1,1)*T%ab(2,3)-T%ab(1,3)*T%ab(2,1)) - inv2d%ab(3,3)=+idetT*(T%ab(1,1)*T%ab(2,2)-T%ab(1,2)*T%ab(2,1)) - - end function inv2d - - function inv2sd(T,detT) - implicit none - - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: inv2sd - real(kind=8):: detT, idetT - - idetT = 1.d0/detT - - inv2sd%a6(1)=+idetT*(T%a6(2)*T%a6(3) -T%a6(5)*T%a6(5)) - inv2sd%a6(4)=-idetT*(T%a6(4)*T%a6(3) -T%a6(5)*T%a6(6)) - inv2sd%a6(6)=+idetT*(T%a6(4)*T%a6(5) -T%a6(2)*T%a6(6)) - inv2sd%a6(2)=+idetT*(T%a6(1)*T%a6(3) -T%a6(6)*T%a6(6)) - inv2sd%a6(5)=-idetT*(T%a6(1)*T%a6(5) -T%a6(4)*T%a6(6)) - inv2sd%a6(3)=+idetT*(T%a6(1)*T%a6(2) -T%a6(4)*T%a6(4)) - - end function inv2sd \ No newline at end of file diff --git a/ttb/libnorm.f b/ttb/libnorm.f deleted file mode 100644 index d200705f..00000000 --- a/ttb/libnorm.f +++ /dev/null @@ -1,29 +0,0 @@ - function norm_1(T) - implicit none - - type(Tensor1) :: T - real(kind=8) :: norm_1 - - norm_1 = sqrt(sum((T%a)**2)) - - end function norm_1 - - function norm_2(T) - implicit none - - type(Tensor2) :: T - real(kind=8) :: norm_2 - - norm_2 = sqrt(T**T) - - end function norm_2 - - function norm_2s(T) - implicit none - - type(Tensor2s) :: T - real(kind=8) :: norm_2s - - norm_2s = sqrt(T**T) - - end function norm_2s \ No newline at end of file diff --git a/ttb/libpermute.f b/ttb/libpermute.f deleted file mode 100644 index fb689bb0..00000000 --- a/ttb/libpermute.f +++ /dev/null @@ -1,71 +0,0 @@ - function permute_2(T,i1,j1) - ! permute tensor of rank 2 for orders 2,1 = transpose(T) - implicit none - - type(Tensor2), intent(in) :: T - integer, intent(in) :: i1,j1 - - type(Tensor2) :: permute_2 - - permute_2%ab = transpose(T%ab) - - end function permute_2 - - function permute_2s(T,i1,j1) - ! permute tensor of rank 2 for orders 2,1 = transpose(T) - implicit none - - type(Tensor2s), intent(in) :: T - integer, intent(in) :: i1,j1 - - type(Tensor2s) :: permute_2s - - permute_2s%a6 = T%a6 - - end function permute_2s - - function permute_4(T,i1,j1,k1,l1) - ! permute tensor of rank 4 - implicit none - - type(Tensor4), intent(in) :: T - integer, intent(in) :: i1,j1,k1,l1 - - type(Tensor4) :: permute_4 - integer i,j,k,l - -c hard-coded permutation -c if (i1==1 .and. j1==3 .and. k1==2 .and. l1==4) then -c forall(i=1:3,j=1:3,k=1:3,l=1:3) permute_4%abcd(i,j,k,l) -c * = T%abcd(i,k,j,l) -c else if (i1==1 .and. j1==4 .and. k1==2 .and. l1==3) then -c forall(i=1:3,j=1:3,k=1:3,l=1:3) permute_4%abcd(i,j,k,l) -c * = T%abcd(i,l,j,k) -c else -c permute_4%abcd = T%abcd -c end if - - permute_4%abcd = reshape(T%abcd,(/3,3,3,3/), - * (/0.d0/),(/i1,j1,k1,l1/)) - - end function permute_4 - - function permute_4s(T,i1,j1,k1,l1) - ! permute tensor of rank 4s - implicit none - - type(Tensor4s), intent(in) :: T - type(Tensor4) :: Tp - integer, intent(in) :: i1,j1,k1,l1 - type(Tensor4) :: permute_4 - type(Tensor4s) :: permute_4s - - integer i,j,k,l - - Tp = tensorstore(T) - - permute_4%abcd = reshape(Tp%abcd,(/3,3,3,3/), - * (/0.d0/),(/i1,j1,k1,l1/)) - permute_4s = symstore(permute_4) - - end function permute_4s \ No newline at end of file diff --git a/ttb/libpiola.f b/ttb/libpiola.f deleted file mode 100644 index 1faa15f2..00000000 --- a/ttb/libpiola.f +++ /dev/null @@ -1,89 +0,0 @@ - function piola2(F, T) - implicit none - - type(Tensor2), intent(in) :: T, F - type(Tensor2) :: piola2 - - piola2 = F*T*transpose(F) - - end function piola2 - - function piola2s(F, T) - implicit none - - type(Tensor2s), intent(in) :: T - type(Tensor2), intent(in) :: F - type(Tensor2s) :: piola2s - - piola2s = symstore(F*tensorstore(T)*transpose(F)) - - end function piola2s - - function piola4(F, T) - implicit none - - type(Tensor2), intent(in) :: F - type(Tensor4), intent(in) :: T - type(Tensor4) :: piola4 - integer :: i,j,k,l,ii,jj,kk,ll - - piola4%abcd = 0.d0 - do i=1,3 - do j=1,3 - do k=1,3 - do l=1,3 - do ii=1,3 - do jj=1,3 - do kk=1,3 - do ll=1,3 - piola4%abcd(i,j,k,l) = piola4%abcd(i,j,k,l) + - * F%ab(i,ii)*F%ab(j,jj)*F%ab(k,kk)*F%ab(l,ll) - * *T%abcd(ii,jj,kk,ll) - end do - end do - end do - end do - end do - end do - end do - end do - - end function piola4 - - function piola4s(F, T) - implicit none - - type(Tensor2), intent(in) :: F - type(Tensor4s), intent(in) :: T - ! type(Tensor4) :: T2, piola4 - type(Tensor4s) :: piola4s,FF - ! integer :: i,j,k,l,ii,jj,kk,ll - - ! piola4%abcd = 0.d0 - ! T2 = tensorstore(T) - - ! do i=1,3 - ! do j=1,3 - ! do k=1,3 - ! do l=1,3 - ! do ii=1,3 - ! do jj=1,3 - ! do kk=1,3 - ! do ll=1,3 - ! piola4%abcd(i,j,k,l) = piola4%abcd(i,j,k,l) + -C ! * F%ab(i,ii)*F%ab(j,jj)*F%ab(k,kk)*F%ab(l,ll) -C ! * *T2%abcd(ii,jj,kk,ll) - ! end do - ! end do - ! end do - ! end do - ! end do - ! end do - ! end do - ! end do - ! piola4s = symstore(piola4) - - FF = symstore(F.cdya.F) - piola4s = FF**T**transpose(FF) - - end function piola4s \ No newline at end of file diff --git a/ttb/libpower.f b/ttb/libpower.f deleted file mode 100644 index 339b0cc1..00000000 --- a/ttb/libpower.f +++ /dev/null @@ -1,52 +0,0 @@ - function pow_2(T,i) - implicit none - - type(Tensor2), intent(in) :: T - integer, intent(in) :: i - - type(Tensor2) :: pow_2, invT - integer :: j - - if (i > 0) then - pow_2 = T - do j=1,i-1 - pow_2 = pow_2*T - end do - else if (i == 0) then - pow_2 = identity2(T) - else - invT = inv(T) - pow_2 = invT - do j=1,abs(i)-1 - pow_2 = pow_2*invT - end do - end if - - end function pow_2 - - function pow_2s(T,i) - implicit none - - type(Tensor2s), intent(in) :: T - integer, intent(in) :: i - - type(Tensor2s) :: pow_2s, invT - integer :: j - - if (i > 0) then - pow_2s = T - do j=1,i-1 - pow_2s = pow_2s*T - end do - else if (i == 0) then - pow_2s = identity2(T) - else - invT = inv(T) - pow_2s = invT - do j=1,abs(i)-1 - pow_2s = pow_2s*invT - end do - end if - - end function pow_2s - diff --git a/ttb/libreducedim.f b/ttb/libreducedim.f deleted file mode 100644 index 8d70bfcd..00000000 --- a/ttb/libreducedim.f +++ /dev/null @@ -1,21 +0,0 @@ - function reduce_dim_2s(T,i) - implicit none - - type(Tensor2s), intent(in) :: T - integer, intent(in) :: i - real(kind=8), dimension(i) :: reduce_dim_2s - - reduce_dim_2s = T%a6(1:i) - - end function reduce_dim_2s - - function reduce_dim_4s(T,i,j) - implicit none - - type(Tensor4s), intent(in) :: T - integer, intent(in) :: i,j - real(kind=8), dimension(i,j) :: reduce_dim_4s - - reduce_dim_4s = T%a6b6(1:i,1:j) - - end function reduce_dim_4s \ No newline at end of file diff --git a/ttb/librotation.f b/ttb/librotation.f deleted file mode 100644 index 216e6532..00000000 --- a/ttb/librotation.f +++ /dev/null @@ -1,25 +0,0 @@ - function rotation_2(phi,i) - implicit none - - real(kind=8), intent(in) :: phi - integer, intent(in) :: i - real(kind=8), dimension(2,2) :: R - type(Tensor2) :: rotation_2 - - R = reshape( (/cos(phi), sin(phi), - * -sin(phi), cos(phi)/), (/2,2/) ) - - rotation_2 = identity2(rotation_2) - - if (i == 1) then - rotation_2%ab(2:3,2:3) = R - else if (i == 3) then - rotation_2%ab(1:2,1:2) = R - else !i == 2 - rotation_2%ab(1,1) = R(1,1) - rotation_2%ab(3,3) = R(2,2) - rotation_2%ab(1,3) = R(2,1) - rotation_2%ab(3,1) = R(1,2) - end if - - end function rotation_2 \ No newline at end of file diff --git a/ttb/libsqrt.f b/ttb/libsqrt.f deleted file mode 100644 index 8a89f7e9..00000000 --- a/ttb/libsqrt.f +++ /dev/null @@ -1,91 +0,0 @@ - function sqrt_1(T) - implicit none - - type(Tensor1), intent(in) :: T - type(Tensor1) :: sqrt_1 - - sqrt_1%a = dsqrt(T%a) - - end function sqrt_1 - - function sqrt_2(T) - ! Source: - ! - ! Franca, L.P. (1989): AN ALGORITHM TO COMPUTE - ! THE SQUARE ROOT OF A POSITIVE DEFINITE MATRIX - ! - implicit none - - type(Tensor2), intent(in) :: T - type(Tensor2) :: sqrt_2 - - real(kind=8) :: I_T,II_T,III_T,I_U,II_U,III_U,k,l,lam,phi - - ! Invariants of T - I_T = tr(T) - II_T = 0.5*(I_T**2-T**T) - III_T = det(T) - k = I_T**2-3.*II_T - - ! Isotropy check - if (dabs(k).le.1.0d-8) then - lam = (I_T/3.)**(1./2.) - sqrt_2 = lam * identity2(T) - return - end if - - ! Calculate largest eigenvalues - l = I_T**3 - 9./2. * I_T*II_T + 27./2. * III_T - phi = dacos(l/k**(3./2.)) - lam = dsqrt(1./3.*(I_T+2*k**(1./2.)*dcos(phi/3.))) - - ! Invariants of U - III_U = (III_T)**(1./2.) - I_U = lam + dsqrt(-lam**2+I_T+2.*III_U/lam) - II_U = (I_U**2-I_T)/2. - - sqrt_2 = 1./(I_U*II_U-III_U) - * *(I_U*III_U*identity2(T) + (I_U**2-II_U)*T-T**2) - - end function sqrt_2 - - function sqrt_2s(T) - ! Source: - ! - ! Franca, L.P. (1989): AN ALGORITHM TO COMPUTE - ! THE SQUARE ROOT OF A POSITIVE DEFINITE MATRIX - ! - implicit none - - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: sqrt_2s - - real(kind=8) :: I_T,II_T,III_T,I_U,II_U,III_U,k,l,lam,phi - - ! Invariants of T - I_T = tr(T) - II_T = 0.5*(I_T**2-tr(T*T)) - III_T = det(T) - k = I_T**2-3.*II_T - - ! Isotropy check - if (k.le.1.0d-8) then - lam = (I_T/3.)**(1./2.) - sqrt_2s = lam * identity2(T) - return - end if - - ! Calculate largest eigenvalues - l = I_T**3 - 9./2. * I_T*II_T + 27./2. * III_T - phi = dacos(l/k**(3./2.)) - lam = dsqrt(1./3.*(I_T+2*k**(1./2.)*dcos(phi/3.))) - - ! Invariants of U - III_U = (III_T)**(1./2.) - I_U = lam + dsqrt(-lam**2+I_T+2.*III_U/lam) - II_U = (I_U**2-I_T)/2. - - sqrt_2s = 1./(I_U*II_U-III_U) - * *(I_U*III_U*identity2(T) + (I_U**2-II_U)*T-T*T) - - end function sqrt_2s \ No newline at end of file diff --git a/ttb/libstrainstore.f b/ttb/libstrainstore.f deleted file mode 100644 index 7c53b564..00000000 --- a/ttb/libstrainstore.f +++ /dev/null @@ -1,43 +0,0 @@ -C function str2ten_2(E,ndi,nshear,ngens) -C implicit none -C -C integer :: ndi,nshear,ngens -C real(kind=8), dimension(ngens) :: E -C type(Tensor2) :: str2ten_2 -C integer, dimension(3) :: ii, jj -C integer :: i -C -C str2ten_2 = Identity2(str2ten_2) -C -C do i=1,ndi -C str2ten_2%ab(i,i) = E(i) -C enddo -C -C ii = (/1,2,3/) -C jj = (/2,3,1/) -C -C do i=1,nshear -C str2ten_2%ab(ii(i),jj(i)) = E(i+ndi)/2. -C end do - -C end function str2ten_2 - - function str2ten_2s(E,ndi,nshear,ngens) - implicit none - - integer :: ndi, nshear, ngens - real(kind=8), dimension(ngens) :: E - type(Tensor2s) :: str2ten_2s - integer :: i - - str2ten_2s = Identity2(str2ten_2s) - - do i=1,ndi - str2ten_2s%a6(i) = E(i) - enddo - - do i=1,nshear - str2ten_2s%a6(i+3) = E(i+ndi)/2. - end do - - end function str2ten_2s \ No newline at end of file diff --git a/ttb/libsub.f b/ttb/libsub.f deleted file mode 100644 index 5fa9e66a..00000000 --- a/ttb/libsub.f +++ /dev/null @@ -1,93 +0,0 @@ - function sub_11(T1, T2) - implicit none - - type(Tensor1), intent(in) :: T1, T2 - type(Tensor1) :: sub_11 - - sub_11%a = T1%a - T2%a - - end function sub_11 - - function sub_22(T1, T2) - implicit none - - type(Tensor2), intent(in) :: T1, T2 - type(Tensor2) :: sub_22 - - sub_22%ab = T1%ab - T2%ab - - end function sub_22 - - function sub_2s2s(T1, T2) - implicit none - - type(Tensor2s), intent(in) :: T1, T2 - type(Tensor2s) :: sub_2s2s - - sub_2s2s%a6 = T1%a6 - T2%a6 - - end function sub_2s2s - - function sub_22s(T1, T2) - implicit none - - type(Tensor2), intent(in) :: T1 - type(Tensor2s), intent(in) :: T2 - type(Tensor2) :: sub_22s - - sub_22s = T1 - astensor(T2) - - end function sub_22s - - function sub_2s2(T1, T2) - implicit none - - type(Tensor2s), intent(in) :: T1 - type(Tensor2), intent(in) :: T2 - type(Tensor2) :: sub_2s2 - - sub_2s2 = astensor(T1) - T2 - - end function sub_2s2 - - function sub_44(T1, T2) - implicit none - - type(Tensor4), intent(in) :: T1, T2 - type(Tensor4) :: sub_44 - - sub_44%abcd = T1%abcd - T2%abcd - - end function sub_44 - - function sub_4s4s(T1, T2) - implicit none - - type(Tensor4s), intent(in) :: T1, T2 - type(Tensor4s) :: sub_4s4s - - sub_4s4s%a6b6 = T1%a6b6 - T2%a6b6 - - end function sub_4s4s - - function sub_44s(T1, T2) - implicit none - - type(Tensor4), intent(in) :: T1 - type(Tensor4s), intent(in) :: T2 - type(Tensor4) :: sub_44s - - sub_44s = T1 - astensor(T2) - - end function sub_44s - - function sub_4s4(T1, T2) - implicit none - - type(Tensor4s), intent(in) :: T1 - type(Tensor4), intent(in) :: T2 - type(Tensor4) :: sub_4s4 - - sub_4s4 = astensor(T1) - T2 - - end function sub_4s4 \ No newline at end of file diff --git a/ttb/libsymstore.f b/ttb/libsymstore.f deleted file mode 100644 index e6ba9559..00000000 --- a/ttb/libsymstore.f +++ /dev/null @@ -1,93 +0,0 @@ - function symstore_2s(T) - implicit none - - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: symstore_2s - - symstore_2s%a6 = T%a6 - end function symstore_2s - - function symstore_2sa(T) - implicit none - - real(kind=8), dimension(6), intent(in) :: T - type(Tensor2s) :: symstore_2sa - - symstore_2sa%a6 = T - - end function symstore_2sa - - function symstore_4s(T) - implicit none - - type(Tensor4s), intent(in) :: T - type(Tensor4s) :: symstore_4s - - symstore_4s%a6b6 = T%a6b6 - - end function symstore_4s - - function symstore_4sa(T) - implicit none - - real(kind=8), dimension(6,6), intent(in) :: T - type(Tensor4s) :: symstore_4sa - - symstore_4sa%a6b6 = T - - end function symstore_4sa - - function symstore_2(T) - implicit none - - type(Tensor2), intent(in) :: T - type(Tensor2s) :: symstore_2 - integer :: i - - symstore_2%a6 = 0.d0 - do i=1,3 - symstore_2%a6(i) = T%ab(i,i) - enddo - symstore_2%a6(4) = T%ab(1,2) - symstore_2%a6(5) = T%ab(2,3) - symstore_2%a6(6) = T%ab(3,1) - - end function symstore_2 - - function symstore_4(T) - implicit none - - type(Tensor4), intent(in) :: T - type(Tensor4s) :: symstore_4 - integer :: i,j - - symstore_4%a6b6 = 0.d0 - do i=1,3 - do j=1,3 - symstore_4%a6b6(i,j) = T%abcd(i,i,j,j) - enddo - enddo - - symstore_4%a6b6(4,4) = T%abcd(1,2,1,2) - symstore_4%a6b6(5,5) = T%abcd(2,3,2,3) - symstore_4%a6b6(6,6) = T%abcd(3,1,3,1) - - do i=1,3 - symstore_4%a6b6(i,4) = T%abcd(i,i,1,2) - symstore_4%a6b6(i,5) = T%abcd(i,i,2,3) - symstore_4%a6b6(i,6) = T%abcd(i,i,3,1) - symstore_4%a6b6(4,i) = T%abcd(1,2,i,i) - symstore_4%a6b6(5,i) = T%abcd(2,3,i,i) - symstore_4%a6b6(6,i) = T%abcd(3,1,i,i) - enddo - - symstore_4%a6b6(4,5) = T%abcd(1,2,2,3) - symstore_4%a6b6(4,6) = T%abcd(1,2,3,1) - - symstore_4%a6b6(5,4) = T%abcd(2,3,1,2) - symstore_4%a6b6(5,6) = T%abcd(2,3,3,1) - - symstore_4%a6b6(6,4) = T%abcd(3,1,1,2) - symstore_4%a6b6(6,5) = T%abcd(3,1,2,3) - - end function symstore_4 \ No newline at end of file diff --git a/ttb/libtenstore.f b/ttb/libtenstore.f deleted file mode 100644 index 9c39bbb3..00000000 --- a/ttb/libtenstore.f +++ /dev/null @@ -1,74 +0,0 @@ - function tenstore_2s(T) - implicit none - - type(Tensor2s), intent(in) :: T - type(Tensor2) :: tenstore_2s - integer :: i - - tenstore_2s%ab = 0.d0 - do i=1,3 - tenstore_2s%ab(i,i) = T%a6(i) - enddo - tenstore_2s%ab(1,2) = T%a6(4) - tenstore_2s%ab(2,3) = T%a6(5) - tenstore_2s%ab(3,1) = T%a6(6) - tenstore_2s%ab(2,1) = tenstore_2s%ab(1,2) - tenstore_2s%ab(3,2) = tenstore_2s%ab(2,3) - tenstore_2s%ab(1,3) = tenstore_2s%ab(3,1) - - end function tenstore_2s - - function tenstore_2(T) - implicit none - - type(Tensor2), intent(in) :: T - type(Tensor2) :: tenstore_2 - - tenstore_2%ab = T%ab - - end function tenstore_2 - - function tenstore_2a(T) - implicit none - - real(kind=8), dimension(3,3), intent(in) :: T - type(Tensor2) :: tenstore_2a - - tenstore_2a%ab = T - - end function tenstore_2a - - function tenstore_4(T) - implicit none - - type(Tensor4), intent(in) :: T - type(Tensor4) :: tenstore_4 - - tenstore_4%abcd = T%abcd - - end function tenstore_4 - - function tenstore_4a(T) - implicit none - - real(kind=8), dimension(3,3,3,3), intent(in) :: T - type(Tensor4) :: tenstore_4a - - tenstore_4a%abcd = T - - end function tenstore_4a - - function tenstore_4s(T) - implicit none - - type(Tensor4s), intent(in) :: T - type(Tensor4) :: tenstore_4s - integer :: i,j,k,l - integer, dimension(3,3) :: i6j6 - - i6j6 = reshape( (/1,4,6, 4,2,5, 6,5,3/), (/3, 3/) ) - - forall (i=1:3,j=1:3,k=1:3,l=1:3) tenstore_4s%abcd(i,j,k,l) - * = T%a6b6(i6j6(i,j),i6j6(k,l)) - - end function tenstore_4s \ No newline at end of file diff --git a/ttb/libtools.f b/ttb/libtools.f deleted file mode 100644 index ee797786..00000000 --- a/ttb/libtools.f +++ /dev/null @@ -1,12 +0,0 @@ - function fact_i(n) - - integer, intent(in) :: n - real(kind=8) :: fact_i - integer :: i - - fact_i = 1.d0 - do i = 2, n - fact_i = fact_i * i - enddo - - end function fact_i \ No newline at end of file diff --git a/ttb/libtrace.f b/ttb/libtrace.f deleted file mode 100644 index 9dcdd387..00000000 --- a/ttb/libtrace.f +++ /dev/null @@ -1,19 +0,0 @@ - function tr_2(T) - implicit none - - type(Tensor2) :: T - real(kind=8) :: tr_2 - - tr_2 = T%ab(1,1)+T%ab(2,2)+T%ab(3,3) - - end function tr_2 - - function tr_2s(T) - implicit none - - type(Tensor2s) :: T - real(kind=8) :: tr_2s - - tr_2s = T%a6(1)+T%a6(2)+T%a6(3) - - end function tr_2s \ No newline at end of file diff --git a/ttb/libtransp.f b/ttb/libtransp.f deleted file mode 100644 index e04148aa..00000000 --- a/ttb/libtransp.f +++ /dev/null @@ -1,43 +0,0 @@ - function transp2(T) - implicit none - - type(Tensor2), intent(in) :: T - type(Tensor2) :: transp2 - - transp2%ab = transpose(T%ab) - - end function transp2 - - function transp2s(T) - implicit none - - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: transp2s - - transp2s%a6 = T%a6 - - end function transp2s - - function transp4(T) - implicit none - - type(Tensor4), intent(in) :: T - type(Tensor4) :: transp4 - integer :: i,j,k,l - - transp4%abcd = 0.d0 - forall (i=1:3,j=1:3,k=1:3,l=1:3) transp4%abcd(i,j,k,l) - * = T%abcd(k,l,i,j) - - end function transp4 - - function transp4s(T) - implicit none - - type(Tensor4s), intent(in) :: T - type(Tensor4s) :: transp4s - - transp4s%a6b6 = transpose(T%a6b6) - - end function transp4s - \ No newline at end of file diff --git a/ttb/libunimodular.f b/ttb/libunimodular.f deleted file mode 100644 index d985e641..00000000 --- a/ttb/libunimodular.f +++ /dev/null @@ -1,53 +0,0 @@ - function unimod_2(T) - implicit none - - type(Tensor2), intent(in) :: T - type(Tensor2) :: unimod_2, Eye - real(kind=8) :: detT - - detT = det(T) - Eye = identity2(Eye) - - unimod_2 = detT**(-1./3.) * T - - end function unimod_2 - - function unimod_2s(T) - implicit none - - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: unimod_2s, Eye - real(kind=8) :: detT - - detT = det(T) - Eye = identity2(Eye) - - unimod_2s = detT**(-1./3.) * T - - end function unimod_2s - - function unimod_2d(T,detT) - implicit none - - type(Tensor2), intent(in) :: T - type(Tensor2) :: unimod_2d, Eye - real(kind=8), intent(in) :: detT - - Eye = identity2(Eye) - - unimod_2d = detT**(-1./3.) * T - - end function unimod_2d - - function unimod_2sd(T,detT) - implicit none - - type(Tensor2s), intent(in) :: T - type(Tensor2s) :: unimod_2sd, Eye - real(kind=8), intent(in) :: detT - - Eye = identity2(Eye) - - unimod_2sd = detT**(-1./3.) * T - - end function unimod_2sd \ No newline at end of file From 174202969365a39af7929025044d7f7fa3417cc2 Mon Sep 17 00:00:00 2001 From: "John S. Urban" Date: Wed, 15 Jan 2025 19:48:35 -0500 Subject: [PATCH 2/3] makefile prototype --- src/Makefile | 127 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 127 insertions(+) create mode 100644 src/Makefile diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 00000000..8d5e8859 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,127 @@ +#@(#) make(1) rules for maintaining a FORTRAN90/C library. Makefile started by makeout(1) 2020-01-14 01:11:41 +NULL= +PROGFILES = $(wildcard ../app/*.f90) $(wildcard ../example/*.f90) $(wildcard ../example/*/*.F90) +PROG = ${PROGFILES:.f90=} +SRCS = $(wildcard ./*.f90) $(wildcard ./*.c ) $(wildcard ./*.h ) $(wildcard ./*.finc) + +# create a list of corresponding object files +COBJS_FILES = $(wildcard ./*.c ) +FOBJS_FILES = $(wildcard ./*.f90 ) +OBJS = $(patsubst %.c,%.o,$(COBJS_FILES)) $(patsubst %.f90,%.o,$(FOBJS_FILES)) +LIBOBJS = $(patsubst %.f90,$(LIBRARY)(%.o),$(SRCS)) $(patsubst %.c,$(LIBRARY)(%.o),$(SRCS)) + + +# platform-specific values you will probably change +# +CC := cc +CFLAGS := -O +FC := gfortran +INSTALL=../lib/$(FC) +FFLAGS := -g -O -J $(INSTALL) -Wall -std=f2018 -Wextra -Wno-maybe-uninitialized -Wno-uninitialized +LDFLAGS := -I $(INSTALL) +AR=ar +ARFLAGS=rU +RANLIB=ranlib + +LIBS := -L $(INSTALL) -lttb +gfortran: FC=gfortran +gfortran: all + @echo built with $(FC) + +nvfortran: FC=nvfortran +nvfortran: FFLAGS := -Minform=inform -Mbackslash -traceback +nvfortran: all + @echo built with $(FC) + +ifort: FC=ifort +ifort: FFLAGS := -warn all -traceback +ifort: all + @echo built with $(FC) + +nagfor: FC=nagfor +nagfor: FFLAGS := -C all +nagfor: all + @echo built with $(FC) + +# name of library to build of the form lib$NAME.a +LIBNAME=ttb +# directory to place output files in +LIBRARY=$(INSTALL)/lib$(LIBNAME).a +# set the '.RECIPEPREFIX' variable to an alternate character +.RECIPEPREFIX = > +#------------------------------------------------------------------------------- +# list what to run and then do any teardown. Do not leave this empty +all: directorysetup $(LIBRARY) $(CPROG) $(PROG) +> @echo "That's all Folks!" +#------------------------------------------------------------------------------- +# what to do before you start compiling +directorysetup: +> @ echo "MAKING LIBRARY: $(LIBRARY)" +> @ [ -d "$(INSTALL)" ] || \ +> (echo "making directory $(INSTALL)"; \ +> mkdir -p $(INSTALL)) +#------------------------------------------------------------------------------- +# what to do after you have built the library +$(LIBRARY): $(LIBOBJS) +> @ $(RANLIB) $(LIBRARY) +> @ echo "TARGETS FOR $(LIBRARY) UP TO DATE" +#------------------------------------------------------------------------------- +$(PROG): $(LIBRARY) +> -$(FC) $(FFLAGS) $(LDFLAGS) $@.f90 -o $@ $(LIBS) +#------------------------------------------------------------------------------- +.phony: clean +clean: +> -rm -f $(PROG) $(CPROG) $(OBJS) *.mod *.o +> -rm -f $(LIBRARY) $(INSTALL)/*.mod +#------------------------------------------------------------------------------- +$(OBJS): draw.h +#------------------------------------------------------------------------------- +.SUFFIXES: $(SUFFIXES) .f90 .F90 .c +.f90.a: +> echo "LIBRARY is $(LIBRARY)" +> $(FC) -c $(FFLAGS) $< -o $% +> @ $(AR) $(ARFLAGS) $(LIBRARY) $% +> @ $(AR) $(ARFLAGS) $(LIBRARY) $< # optionally store the source code too +> @ /bin/rm -f ${?F:.f90=.o} $% +.c.a: +> $(CC) -c $(CFLAGS) $< -o $% +> @ $(AR) $(ARFLAGS) $(LIBRARY) $% +> @ $(AR) $(ARFLAGS) $(LIBRARY) $< # optionally store the source code too +> @ /bin/rm -f ${?F:.c=.o} $% +#------------------------------------------------------------------------------- +.PHONY: help +help: +>: all '-- build ttb/Tensor module' +>: run '-- run manpage demo programs' +>: man '-- show all manpages as text' +>: clean '-- clean directory of object files and executables' +>: doxygen '-- run doxygen(1) if you have it' +>: ford '-- run ford(1) if you have it' +>: help '-- display this text' +> +#------------------------------------------------------------------------------- +.PHONY: run +run: $(PROG) +># run everything +>echo $? |xargs -n 1|xargs -iXX time XX +#------------------------------------------------------------------------------- +.PHONY: doxygen +doxygen: +>doxygen dox.in +#------------------------------------------------------------------------------- +.PHONY: ford +ford: +>cd ..;ford ford.md +#------------------------------------------------------------------------------- +.PHONY: man +man: +>@mandb ../man 1>&2 +>: INDEX OF MANPAGES TOPICS +>@env MANPATH=../man MANWIDTH=256 man -k .|col -b +>: MANPAGES +>@env MANPATH=../man MANWIDTH=80 man -Tutf8 --regex '.*'|col -b +>: SPELLING +>@env MANPATH=../man MANWIDTH=80 man -Tutf8 --regex '.*'|col -b|spell|xargs -n 5|column -t +#================================================================================= +ttb_library.o: +#================================================================================= From aba5309f86d21c536c69434c36ed6e859b40f9f0 Mon Sep 17 00:00:00 2001 From: "John S. Urban" Date: Wed, 15 Jan 2025 19:49:07 -0500 Subject: [PATCH 3/3] ignore lib/ directory --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index f9f1d493..93a569eb 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ # Not sure what a .gitignore is? # See: https://git-scm.com/docs/gitignore +lib/ # These are directly copied from Jekyll's first-party docs on `.gitignore` files: # https://jekyllrb.com/tutorials/using-jekyll-with-bundler/#commit-to-source-control