Merge pull request #22 from BerkeleyLab/double-precision-json-value-g…

…etter

Double precision json value getter

example/check-command-line-argument.f90

@@ -1,3 +1,5 @@
+! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute
+! Terms of use are as specified in LICENSE.txt
 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

example/get-flag-value.f90

@@ -1,3 +1,5 @@
+! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute
+! Terms of use are as specified in LICENSE.txt
 program get_flag_value
   !! Demonstrate how to find the value of a command-line flag 
   !! Running this program as follows with the command

example/handle-missing-flag.f90

@@ -1,3 +1,5 @@
+! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute
+! Terms of use are as specified in LICENSE.txt
 program handle_missing_flag
   !! This program serves the dual purposes of
   !!

src/julienne/julienne_string_m.f90

@@ -23,22 +23,26 @@ module julienne_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_real, get_real_with_character_key & 
-                                ,get_string, get_string_with_character_key & 
+    generic :: get_json_value => get_string &
+                                ,get_real, get_real_with_character_key &
+                                ,get_character, get_character_with_character_key &
                                 ,get_logical, get_logical_with_character_key  &
                                 ,get_real_array ,get_real_array_with_character_key &
                                 ,get_integer_array, get_integer_array_with_character_key &
-                                ,get_integer, get_integer_with_character_key
+                                ,get_integer, get_integer_with_character_key &
+                                ,get_double_precision, get_double_precision_with_character_key
     procedure, private :: get_real, get_real_with_character_key
-    procedure, private :: get_string, get_string_with_character_key
+    procedure, private :: get_string
     procedure, private :: get_logical, get_logical_with_character_key
     procedure, private :: get_integer, get_integer_with_character_key
     procedure, private :: get_real_array, get_real_array_with_character_key
     procedure, private :: get_integer_array, get_integer_array_with_character_key
-    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
-    procedure, private            :: string_t_cat_string_t, string_t_cat_character
+    procedure, private :: get_character, get_character_with_character_key
+    procedure :: get_double_precision, get_double_precision_with_character_key
+    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
+    procedure, private :: string_t_cat_string_t, string_t_cat_character
     procedure, private, pass(rhs) :: character_cat_string_t
     procedure, private, pass(rhs) :: character_ne_string_t
     procedure, private, pass(rhs) :: character_eq_string_t
@@ -129,11 +133,33 @@ pure module function get_real_with_character_key(self, key, mold) result(value_)
       real value_
     end function
 
-    elemental module function get_string_with_character_key(self, key, mold) result(value_)
+    pure module function get_double_precision(self, key, mold) result(value_)
       implicit none
-      class(string_t), intent(in) :: self, mold
+      class(string_t), intent(in) :: self, key
+      double precision, intent(in) :: mold
+      double precision value_
+    end function
+
+    pure module function get_double_precision_with_character_key(self, key, mold) result(value_)
+      implicit none
+      class(string_t), intent(in) :: self
       character(len=*), intent(in) :: key
-      type(string_t) :: value_
+      double precision, intent(in) :: mold
+      double precision value_
+    end function
+
+    pure module function get_character(self, key, mold) result(value_)
+      implicit none
+      class(string_t), intent(in) :: self, key
+      character(len=*), intent(in) :: mold
+      character(len=:), allocatable :: value_
+    end function
+
+    pure module function get_character_with_character_key(self, key, mold) result(value_)
+      implicit none
+      class(string_t), intent(in) :: self
+      character(len=*), intent(in) :: key, mold
+      character(len=:), allocatable :: value_
     end function
 
     elemental module function get_string(self, key, mold) result(value_)

src/julienne/julienne_string_s.f90

@@ -106,11 +106,34 @@
     value_ = self%get_real(string_t(key), mold)
   end procedure
 
+  module procedure get_double_precision_with_character_key
+    value_ = self%get_double_precision(string_t(key), mold)
+  end procedure
+
   module procedure get_real
     character(len=:), allocatable :: raw_line, string_value
 
     call assert(key==self%get_json_key(), "string_s(get_real): key==self%get_json_key()", key)
 
+    raw_line = self%string()
+    associate(text_after_colon => raw_line(index(raw_line, ':')+1:))
+      associate(trailing_comma => index(text_after_colon, ','))
+        if (trailing_comma == 0) then
+          string_value = trim(adjustl((text_after_colon)))
+        else
+          string_value = trim(adjustl((text_after_colon(:trailing_comma-1))))
+        end if
+        read(string_value, fmt=*) value_
+      end associate
+    end associate
+
+  end procedure
+
+  module procedure get_double_precision
+    character(len=:), allocatable :: raw_line, string_value
+
+    call assert(key==self%get_json_key(), "string_s(get_double_precision): key==self%get_json_key()", key)
+
     raw_line = self%string()
     associate(text_after_colon => raw_line(index(raw_line, ':')+1:))
       associate(trailing_comma => index(text_after_colon, ','))
@@ -125,8 +148,16 @@
 
   end procedure
 
-  module procedure get_string_with_character_key
-    value_ = self%get_string(string_t(key), mold)
+  module procedure get_character
+    associate(string_value => self%get_string(key, string_t(mold)))
+      value_ = string_value%string()
+    end associate
+  end procedure
+
+  module procedure get_character_with_character_key
+    associate(string_value => self%get_string(string_t(key), string_t(mold)))
+      value_ = string_value%string()
+    end associate
   end procedure
 
   module procedure get_string

test/bin_test.F90

@@ -1,3 +1,5 @@
+! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute
+! Terms of use are as specified in LICENSE.txt
 module bin_test_m
   !! Check data partitioning across bins
   use julienne_m, only : bin_t, test_t, test_result_t, test_description_t, test_description_substring, string_t

test/command_line_test.F90

@@ -1,3 +1,5 @@
+! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute
+! Terms of use are as specified in LICENSE.txt
 module command_line_test_m
   !! Verify object pattern asbtract parent
   use julienne_m, only : test_t, test_result_t, command_line_t, test_description_substring, string_t, test_description_t

test/formats_test.F90

@@ -1,3 +1,5 @@
+! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute
+! Terms of use are as specified in LICENSE.txt
 module formats_test_m
   !! Verify that format strings provide the desired formatting
   use julienne_m, only : separated_values, test_t, test_result_t, test_description_t, test_description_substring, string_t

test/main.F90

@@ -1,3 +1,5 @@
+! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute
+! Terms of use are as specified in LICENSE.txt
 program main
   use bin_test_m, only : bin_test_t
   use command_line_test_m, only : command_line_test_t

test/string_test.F90

@@ -1,3 +1,5 @@
+! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute
+! Terms of use are as specified in LICENSE.txt
 module string_test_m
   use julienne_m, only : test_t, test_result_t, string_t, operator(.cat.), test_description_t, test_description_substring
 #ifdef __GFORTRAN__
@@ -49,8 +51,12 @@ function results() result(test_results)
         (string_t("extracting a key string from a colon-separated key/value pair"), extracts_key), &
       test_description_t &
         (string_t("extracting a real value from a colon-separated key/value pair"), extracts_real_value), &
+      test_description_t &
+        (string_t("extracting a double-precision value from a colon-separated key/value pair"), extracts_double_precision_value), &
       test_description_t &
         (string_t("extracting a string value from a colon-separated key/value pair"), extracts_string_value), &
+      test_description_t &
+        (string_t("extracting a string value from a colon-separated key/value pair"), extracts_character_value), &
       test_description_t &
         (string_t("extracting a logical value from a colon-separated key/value pair"), extracts_logical_value), &
       test_description_t &
@@ -70,7 +76,8 @@ function results() result(test_results)
       check_allocation_ptr, supports_equivalence_ptr, supports_non_equivalence_ptr, supports_concatenation_ptr, &
       assigns_string_ptr, assigns_character_ptr, constructs_from_integer_ptr, constructs_from_real_ptr, concatenates_ptr, &
       extracts_key_ptr, extracts_real_ptr, extracts_string_ptr, extracts_logical_ptr, extracts_integer_array_ptr, &
-      extracts_real_array_ptr, extracts_integer_ptr, extracts_file_base_ptr, extracts_file_name_ptr
+      extracts_real_array_ptr, extracts_integer_ptr, extracts_file_base_ptr, extracts_file_name_ptr, extracts_character_ptr, &
+      extracts_double_precision_value_ptr
 
     check_allocation_ptr => check_allocation
     supports_equivalence_ptr => supports_equivalence_operator
@@ -83,7 +90,9 @@ function results() result(test_results)
     concatenates_ptr => concatenates_elements
     extracts_key_ptr => extracts_key
     extracts_real_ptr => extracts_real_value
+    extracts_double_precision_value_ptr => extracts_double_precision_value
     extracts_string_ptr => extracts_string_value
+    extracts_character_ptr => extracts_character_value
     extracts_logical_ptr => extracts_logical_value
     extracts_integer_array_ptr  => extracts_integer_array_value
     extracts_real_array_ptr => extracts_real_array_value
@@ -106,7 +115,10 @@ function results() result(test_results)
       test_description_t(string_t('supporting unary operator(.cat.) for array arguments'), concatenates_ptr), &
       test_description_t(string_t("extracting a key string from a colon-separated key/value pair"), extracts_key_ptr), &
       test_description_t(string_t("extracting a real value from a colon-separated key/value pair"), extracts_real_ptr), &
+      test_description_t( &
+        string_t("extracting a double-precision value from a colon-separated key/value pair"), extracts_double_precision_value_ptr),&
       test_description_t(string_t("extracting a string value from a colon-separated key/value pair"), extracts_string_ptr), &
+      test_description_t(string_t("extracting a character value from a colon-separated key/value pair"), extracts_character_ptr), &
       test_description_t(string_t("extracting a logical value from a colon-separated key/value pair"), extracts_logical_ptr), &
       test_description_t( &
         string_t("extracting an integer array value from a colon-separated key/value pair"), extracts_integer_array_ptr), &
@@ -149,6 +161,22 @@ function extracts_key() result(passed)
 #endif
   end function
 
+  function extracts_double_precision_value() result(passed)
+    logical passed
+
+#ifndef _CRAYFTN
+    associate(line => string_t('"pi" : 3.141592653589793D0'))
+      passed = line%get_json_value(key="pi", mold=0.D0) == 3.141592653589793D0
+    end associate
+#else
+    block
+      type(string_t) line
+      line = string_t('"pi" : 3.141592653589793D0')
+      passed = line%get_json_value(key="pi", mold=0.D0) == 3.141592653589793D0
+    end block
+#endif
+  end function
+
   function extracts_real_value() result(passed)
     logical passed
 
@@ -165,6 +193,29 @@ function extracts_real_value() result(passed)
 #endif
   end function
 
+  function extracts_character_value() result(passed)
+    logical passed
+
+#ifndef _CRAYFTN
+    associate(line => string_t('"foo" : "bar"'), line_with_comma => string_t('"foo" : "bar",'))
+      passed = line%get_json_value(key=string_t("foo"), mold="") == "bar" .and. &
+               line%get_json_value(key="foo" , mold="") == "bar" .and. &
+               line_with_comma%get_json_value(key=string_t("foo"), mold="") == "bar" .and. &
+               line_with_comma%get_json_value(key="foo" , mold="") == "bar"
+    end associate
+#else
+    block
+      type(string_t) line, line_with_comma
+      line = string_t('"foo" : "bar"')
+      line_with_comma = string_t('"foo" : "bar",')
+      passed = line%get_json_value(key=string_t("foo"), mold="") == "bar" .and. &
+               line%get_json_value(key="foo" , mold="") == "bar" .and. &
+               line_with_comma%get_json_value(key=string_t("foo"), mold="") == "bar" .and. &
+               line_with_comma%get_json_value(key="foo" , mold="") == "bar"
+    end block
+#endif
+  end function
+
   function extracts_string_value() result(passed)
     logical passed
 

test/test_description_test.F90

@@ -1,3 +1,5 @@
+! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute
+! Terms of use are as specified in LICENSE.txt
 module test_description_test_m
   !! Verify test_description_t object behavior
   use julienne_m, only : string_t, test_result_t, test_description_t, test_t, test_description_substring
@@ -62,4 +64,4 @@ logical function tautology()
     end function
   end function
 
-end module test_description_test_m
+end module test_description_test_m

test/test_result_test.F90

@@ -1,3 +1,5 @@
+! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute
+! Terms of use are as specified in LICENSE.txt
 module test_result_test_m
   !! Verify test_result_t object behavior
   use julienne_m, only : string_t, test_result_t, test_description_t, test_t, test_description_substring
@@ -72,4 +74,4 @@ function check_single_image_failure() result(passed)
     passed = .not. test_result%passed()
   end function
 
-end module test_result_test_m
+end module test_result_test_m

test/vector_test_description_test.f90

@@ -1,3 +1,5 @@
+! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute
+! Terms of use are as specified in LICENSE.txt
 module vector_test_description_test_m
   !! Verify vector_test_description_t object behavior
   use julienne_m, only : &
@@ -52,4 +54,4 @@ function results() result(test_results)
     end associate
   end function
 
-end module vector_test_description_test_m
+end module vector_test_description_test_m