Merge pull request #75 from sourceryinstitute/get-json-real-array

Add string_t get_json_real_array type-bound procedure

Author: rouson

fpm.toml

@@ -1,9 +1,9 @@
 name = "sourcery"
-version = "4.4.4"
+version = "4.6.1"
 license = "BSD"
 author = ["Damian Rouson"]
-maintainer = "damian@archaeologic.codes"
-copyright = "2020-2023 Sourcery Institute"
+maintainer = "damian@sourceryinstitute.org"
+copyright = "2020-2024 Sourcery Institute"
 
 [dependencies]
 assert = {git = "https://github.com/sourceryinstitute/assert", tag = "1.6.0"}

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

test/string_test.F90

@@ -36,6 +36,7 @@ function results() result(test_results)
       test_result_t("extracting a string value from a colon-separated key/value pair", extracts_string_value()), &
       test_result_t("extracting a logical value from a colon-separated key/value pair", extracts_logical_value()), &
       test_result_t("extracting an integer array value from a colon-separated key/value pair", extracts_integer_array_value()), &
+      test_result_t("extracting an real array value from a colon-separated key/value pair", extracts_real_array_value()), &
       test_result_t("extracting an integer value from a colon-separated key/value pair", extracts_integer_value()), &
       test_result_t('extracting a file base name', extracts_file_base_name()), &
       test_result_t('extracting a file name extension', extracts_file_name_extension()) &
@@ -171,6 +172,26 @@ function extracts_integer_array_value() result(passed)
 #endif
   end function
 
+  function extracts_real_array_value() result(passed)
+    logical passed
+
+#ifndef _CRAYFTN
+    associate(key_real_array_pair => string_t('"a key" : [1., 2., 4.],'))
+      associate(real_array => key_real_array_pair%get_json_value(key=string_t("a key"), mold=[real::]))
+        passed = all(real_array == [1., 2., 4.])
+      end associate
+    end associate
+#else
+    block
+      type(string_t) key_real_array_pair
+      real, allocatable :: real_array(:)
+      key_real_array_pair = string_t('"a key" : [1., 2., 4.],')
+      real_array = key_real_array_pair%get_json_value(key=string_t("a key"), mold=[real::])
+      passed = all(real_array == [1., 2., 4.])
+    end block
+#endif
+  end function
+
   function supports_equivalence_operator() result(passed)
     logical passed
     passed = &