Merge branch 'main' into prep-release

Author: rouson

README.md

@@ -1,7 +1,7 @@
 Sourcery Library
 ================
 
-A grab bag of useful tricks in Fortran 2018.  
+A grab bag of useful tricks in Fortran 2023.  
 
 ```fortran
                       -:/+-
@@ -52,7 +52,7 @@ Contents
 
 ### Classes
 * Parallel data partitioning and gathering,
-* A minimalistic unit testing framework comprised of two types: `test_t` and `test_result_t`
+* A minimalistic unit testing framework based around three types: `test_t`, `test_description_t`, and `test_result_t`
 * (Co-)[Object pattern] abstract parent,
 * Runtime units tracking,
 * A test oracle using the [Template Method pattern], and
@@ -82,6 +82,16 @@ git clone [email protected]:sourceryinstitute/sourcery
 
 Building and Testing
 --------------------
+### Test-Suite Usage
+Executing `fpm test -- --help` prints the following message:
+```
+Usage: fpm test -- [--help] | [--contains <substring>]
+
+where square brackets ([]) denote optional arguments, a pipe (|) separates alternative arguments,
+angular brackets (<>) denote a user-provided value, and passing a substring limits execution to
+the tests with test subjects or test descriptions containing the user-specified substring.
+```
+
 ### GNU Fortran (`gfortran`)  compiler
 #### Single-image (serial) testing
 With recent versions of [GNU Fortran] (gfortran) and [OpenCoarrays] installed, 
@@ -105,7 +115,7 @@ fpm test --compiler ifx --flag "-coarray"
 
 ### Numerical Algorithms Group (`nagfor`) compiler
 ```zsh
-fpm test --compiler nagfor --flag "-fpp -coarray=cosmp"
+fpm test --compiler nagfor --flag -fpp
 ```
 
 ### Building and testing with the Cray Compiler Environment (CCE)
@@ -153,4 +163,3 @@ documentation.
 [Building the documentation]: #building-the-documentation
 [Sourcery GitHub Pages site]: http://sourceryinstitute.github.io/sourcery/
 [`ford`]: https://github.com/Fortran-FOSS-Programmers/ford
-

example/check-command-line-argument.f90

@@ -0,0 +1,22 @@
+program check_command_line_argument
+  !! This program serves the dual purposes of 
+  !! 1. Showing how to use the command_line_t derived type to check whether a
+  !!    command-line argument is present and
+  !! 2. Supporting the test suite verification of this same behavior.
+  !!
+  !! Running this program as follows with the command
+  !!
+  !! fpm run --example check-command-line-argument -- --some-argument 
+  !!
+  !! should result in normal termination.
+  use assert_m, only : assert
+  use sourcery_m, only : command_line_t
+  implicit none
+
+  type(command_line_t) command_line
+  logical argument_passed
+
+  argument_passed = command_line%argument_present(["--some-argument"])
+
+  call assert(argument_passed, "check_command_line_argument: argument present")
+end program

example/handle-missing-flag.f90

@@ -0,0 +1,23 @@
+program handle_missing_flag
+  !! This program serves the dual purposes of
+  !!
+  !! 1. Showing an example of a command-line with an expected flag missing an
+  !! 2. Supporting the test suite check that the returned value has zero length.
+  !!
+  !! Running this program as follows with the command
+  !!
+  !! fpm run --example handle-missing-flag -- --empty-flag
+  !!
+  !! should result in normal termination.
+  use assert_m, only : assert
+  use sourcery_m, only : command_line_t
+  implicit none
+
+  type(command_line_t) command_line
+  character(len=:), allocatable :: flag_value
+  character(len=*), parameter :: expected_name=""
+
+  flag_value = command_line%flag_value("--empty-flag")
+
+  call assert(flag_value==expected_name,"handle_missing_flag: expected empty flag value", flag_value)
+end program

src/sourcery/sourcery_command_line_s.f90

@@ -39,23 +39,28 @@
     integer argnum, arglen, flag_value_length
     character(len=:), allocatable :: arg
 
-
-    flag_search: &
-    do argnum = 1,command_argument_count()
-
-      if (allocated(arg)) deallocate(arg)
-
-      call get_command_argument(argnum, length=arglen)
-      allocate(character(len=arglen) :: arg)
-      call get_command_argument(argnum, arg)
-
-      if (arg==flag) then
-        call get_command_argument(argnum+1, length=flag_value_length)
-        allocate(character(len=flag_value_length) :: flag_value)
-        call get_command_argument(argnum+1, flag_value)
-        exit flag_search
+    associate(argcount => command_argument_count())
+      if (argcount==0) then
+        flag_value=""
+      else
+        flag_search: &
+        do argnum = 1,argcount
+
+          if (allocated(arg)) deallocate(arg)
+
+          call get_command_argument(argnum, length=arglen)
+          allocate(character(len=arglen) :: arg)
+          call get_command_argument(argnum, arg)
+
+          if (arg==flag) then
+            call get_command_argument(argnum+1, length=flag_value_length)
+            allocate(character(len=flag_value_length) :: flag_value)
+            call get_command_argument(argnum+1, flag_value)
+            exit flag_search
+          end if
+        end do flag_search
       end if
-    end do flag_search
+    end associate
 
   end procedure
 

src/sourcery/sourcery_string_m.f90

@@ -21,8 +21,10 @@ module sourcery_string_m
     generic :: operator(/=)   => string_t_ne_string_t, string_t_ne_character, character_ne_string_t
     generic :: operator(==)   => string_t_eq_string_t, string_t_eq_character, character_eq_string_t
     generic :: assignment(= ) => assign_string_t_to_character, assign_character_to_string_t
-    generic :: get_json_value =>     get_json_integer_array, get_json_logical, get_json_integer, get_json_string, get_json_real
-    procedure, private            :: get_json_integer_array, get_json_logical, get_json_integer, get_json_string, get_json_real
+    generic :: get_json_value =>     get_json_integer_array, get_json_logical, get_json_integer, get_json_string, get_json_real, &
+                                     get_json_real_array
+    procedure, private            :: get_json_integer_array, get_json_logical, get_json_integer, get_json_string, get_json_real, &
+                                     get_json_real_array
     procedure, private            :: string_t_ne_string_t, string_t_ne_character
     procedure, private            :: string_t_eq_string_t, string_t_eq_character
     procedure, private            :: assign_character_to_string_t
@@ -102,7 +104,7 @@ pure module function base_name(self) result(base)
       type(string_t) base
     end function
 
-    elemental module function get_json_real(self, key, mold) result(value_)
+    pure module function get_json_real(self, key, mold) result(value_)
       implicit none
       class(string_t), intent(in) :: self, key
       real, intent(in) :: mold
@@ -136,6 +138,13 @@ pure module function get_json_integer_array(self, key, mold) result(value_)
       integer, allocatable :: value_(:)
     end function
 
+    pure module function get_json_real_array(self, key, mold) result(value_)
+      implicit none
+      class(string_t), intent(in) :: self, key
+      real, intent(in) :: mold(:)
+      real, allocatable :: value_(:)
+    end function
+
     elemental module function string_t_eq_string_t(lhs, rhs) result(lhs_eq_rhs)
       implicit none
       class(string_t), intent(in) :: lhs, rhs

src/sourcery/sourcery_string_s.f90

@@ -182,11 +182,15 @@
   end procedure
 
   module procedure get_json_integer_array
+    value_ = int(self%get_json_real_array(key,mold=[0.]))
+  end procedure
+
+  module procedure get_json_real_array
     character(len=:), allocatable :: raw_line
     real, allocatable :: real_array(:)
     integer i
 
-    call assert(key==self%get_json_key(), "string_s(get_json_integer_array): key==self%get_json_key()", key)
+    call assert(key==self%get_json_key(), "string_s(get_json_{real,integer}_array): key==self%get_json_key()", key)
 
     raw_line = self%string()
     associate(colon => index(raw_line, ":"))
@@ -196,7 +200,7 @@
             associate(num_inputs => commas + 1)
               allocate(real_array(num_inputs))
               read(raw_line(opening_bracket+1:closing_bracket-1), fmt=*) real_array
-              value_ = int(real_array)
+              value_ = real_array
             end associate
           end associate
         end associate

src/sourcery/sourcery_test_description_m.F90

@@ -0,0 +1,78 @@
+module sourcery_test_description_m
+  !! Define an abstraction for describing test intentions and test functions
+  use sourcery_string_m, only : string_t
+  use sourcery_test_result_m, only : test_result_t
+  implicit none
+
+  private
+  public :: test_description_t
+#ifdef __GFORTRAN__
+  public :: test_function_i
+#endif
+
+  abstract interface
+    function test_function_i() result(passes)
+      implicit none
+      logical passes
+    end function
+  end interface
+
+  type test_description_t
+    !! Encapsulate test descriptions and test-functions
+    private
+    type(string_t) description_
+    procedure(test_function_i), pointer, nopass :: test_function_ => null()
+  contains
+    procedure run
+    procedure contains_text
+    generic :: operator(==) => equals
+    procedure, private :: equals
+  end type
+
+  interface test_description_t
+
+    module function construct_from_string_t(description, test_function) result(test_description)
+      !! The result is a test_description_t object with the components defined by the dummy arguments
+      implicit none
+      type(string_t), intent(in) :: description
+      procedure(test_function_i), intent(in), pointer :: test_function
+      type(test_description_t) test_description
+    end function
+
+    module function construct_from_character(description, test_function) result(test_description)
+      !! The result is a test_description_t object with the components defined by the dummy arguments
+      implicit none
+      character(len=*), intent(in) :: description
+      procedure(test_function_i), intent(in), pointer :: test_function
+      type(test_description_t) test_description
+    end function
+
+  end interface
+
+  interface
+
+    impure elemental module function run(self) result(test_result)
+      !! The result encapsulates the test description and test outcome
+      implicit none
+      class(test_description_t), intent(in) :: self
+      type(test_result_t) test_result
+    end function
+
+    impure elemental module function contains_text(self, substring) result(match)
+      !! The result is .true. if the test description includes the value of substring 
+      implicit none
+      class(test_description_t), intent(in) :: self
+      type(string_t), intent(in) :: substring
+      logical match
+    end function
+
+    elemental module function equals(lhs, rhs) result(lhs_eq_rhs)
+      !! The result is .true. if the components of the lhs & rhs are equal
+      implicit none
+      class(test_description_t), intent(in) :: lhs, rhs
+      logical lhs_eq_rhs
+    end function
+
+  end interface
+
+end module sourcery_test_description_m

src/sourcery/sourcery_test_description_s.f90

@@ -0,0 +1,25 @@
+submodule(sourcery_test_description_m) sourcery_test_description_s
+  implicit none
+contains
+    module procedure construct_from_character
+      test_description%description_ = description
+      test_description%test_function_ => test_function
+    end procedure
+
+    module procedure construct_from_string_t
+      test_description%description_ = description
+      test_description%test_function_ => test_function
+    end procedure
+
+    module procedure run
+      test_result = test_result_t(self%description_, self%test_function_())
+    end procedure
+
+    module procedure contains_text
+      match = index(self%description_%string(), substring%string()) /= 0
+    end procedure
+
+    module procedure equals
+      lhs_eq_rhs = (lhs%description_ == rhs%description_) .and. associated(lhs%test_function_, rhs%test_function_)
+    end procedure
+end submodule sourcery_test_description_s

src/sourcery/sourcery_test_m.f90

@@ -6,7 +6,9 @@ module sourcery_test_m
   implicit none
 
   private
-  public :: test_t, test_result_t
+  public :: test_t, test_description_substring
+
+  character(len=:), allocatable, protected :: test_description_substring
 
   type, abstract :: test_t
     !! Facilitate testing and test reporting

src/sourcery/sourcery_test_result_m.f90

@@ -1,14 +1,15 @@
 module sourcery_test_result_m
   !! Define an abstraction for describing test intentions and results
+  use sourcery_string_m, only : string_t
   implicit none
 
   private
   public :: test_result_t
 
   type test_result_t
-    !! Encapsulate test descriptions and outcomes and reporting
+    !! Encapsulate test descriptions and outcomes
     private
-    character(len=:), allocatable :: description_
+    type(string_t) description_
     logical passed_ 
   contains
     procedure :: characterize
@@ -17,14 +18,22 @@ module sourcery_test_result_m
 
   interface test_result_t
 
-    elemental module function construct(description, passed) result(test_result)
+    elemental module function construct_from_character(description, passed) result(test_result)
       !! The result is a test_result_t object with the components defined by the dummy arguments
       implicit none
       character(len=*), intent(in) :: description
       logical, intent(in) :: passed
       type(test_result_t) test_result 
     end function
 
+    module function construct_from_string(description, passed) result(test_result)
+      !! The result is a test_result_t object with the components defined by the dummy arguments
+      implicit none
+      type(string_t), intent(in) :: description
+      logical, intent(in) :: passed
+      type(test_result_t) test_result 
+    end function
+
   end interface
 
   interface