diff --git a/src/julienne/julienne_string_m.f90 b/src/julienne/julienne_string_m.f90 index 0719f20..39f63f1 100644 --- a/src/julienne/julienne_string_m.f90 +++ b/src/julienne/julienne_string_m.f90 @@ -23,7 +23,7 @@ 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_string & + generic :: get_json_value => get_string, get_string_t_array & ,get_real, get_real_with_character_key & ,get_character, get_character_with_character_key & ,get_logical, get_logical_with_character_key & @@ -33,7 +33,7 @@ module julienne_string_m ,get_double_precision, get_double_precision_with_character_key & ,get_double_precision_array, get_double_precision_array_with_character_key procedure, private :: get_real, get_real_with_character_key - procedure, private :: get_string + procedure, private :: get_string, get_string_t_array 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 @@ -185,6 +185,13 @@ elemental module function get_string(self, key, mold) result(value_) type(string_t) :: value_ end function + pure module function get_string_t_array(self, key, mold) result(value_) + implicit none + class(string_t), intent(in) :: self, key + type(string_t), intent(in) :: mold(:) + type(string_t), allocatable :: value_(:) + end function + pure module function get_integer_with_character_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self diff --git a/src/julienne/julienne_string_s.f90 b/src/julienne/julienne_string_s.f90 index c76a233..3ef6996 100644 --- a/src/julienne/julienne_string_s.f90 +++ b/src/julienne/julienne_string_s.f90 @@ -1,7 +1,7 @@ ! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt submodule(julienne_string_m) julienne_string_s - use assert_m, only : assert + use assert_m, only : assert, intrinsic_array_t implicit none contains @@ -160,6 +160,35 @@ end associate end procedure + module procedure get_string_t_array + + character(len=:), allocatable :: raw_line + integer i, comma, opening_quotes, closing_quotes + + call assert(key==self%get_json_key(), "key==self%get_string_json()", key) + + raw_line = self%string() + + associate(colon => index(raw_line, ':')) + associate(opening_bracket => colon + index(raw_line(colon+1:), '[')) + associate(closing_bracket => opening_bracket + index(raw_line(opening_bracket+1:), ']')) + associate(commas => count("," == [(raw_line(i:i), i = opening_bracket+1, closing_bracket-1)])) + allocate(value_(commas+1)) + opening_quotes = opening_bracket + index(raw_line(opening_bracket+1:), '"') + closing_quotes = opening_quotes + index(raw_line(opening_quotes+1:), '"') + value_(1) = raw_line(opening_quotes+1:closing_quotes-1) + do i = 1, commas + comma = closing_quotes + index(raw_line(closing_quotes+1:), ',') + opening_quotes = comma + index(raw_line(comma+1:), '"') + closing_quotes = opening_quotes + index(raw_line(opening_quotes+1:), '"') + value_(i+1) = raw_line(opening_quotes+1:closing_quotes-1) + end do + end associate + end associate + end associate + end associate + end procedure + module procedure get_string character(len=:), allocatable :: raw_line diff --git a/test/string_test.F90 b/test/string_test.F90 index dc2d984..7b66ccf 100644 --- a/test/string_test.F90 +++ b/test/string_test.F90 @@ -64,6 +64,8 @@ function results() result(test_results) (string_t("extracting a logical value from a colon-separated key/value pair"), extracts_logical_value), & test_description_t & (string_t("extracting an integer array value from a colon-separated key/value pair"), extracts_integer_array_value), & + test_description_t & + (string_t("extracting a string_t array value from a colon-separated key/value pair"), extracts_string_array_value), & test_description_t & (string_t("extracting an real array value from a colon-separated key/value pair"), extracts_real_array_value), & test_description_t & @@ -81,8 +83,10 @@ 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_character_ptr, & - extracts_double_precision_value_ptr, extracts_dp_array_value_ptr + extracts_real_array_ptr, extracts_integer_ptr, extracts_file_base_ptr, extracts_file_name_ptr, & + ! Remove code that exposes a gfortran compiler bug: + ! extracts_string_array_ptr, & + extracts_character_ptr, extracts_double_precision_value_ptr, extracts_dp_array_value_ptr check_allocation_ptr => check_allocation supports_equivalence_ptr => supports_equivalence_operator @@ -100,6 +104,8 @@ function results() result(test_results) extracts_character_ptr => extracts_character_value extracts_logical_ptr => extracts_logical_value extracts_integer_array_ptr => extracts_integer_array_value + ! Remove code that exposes a gfortran compiler bug: + !extracts_string_array_ptr => extracts_string_array_value extracts_real_array_ptr => extracts_real_array_value extracts_dp_array_value_ptr => extracts_dp_array_value extracts_integer_ptr => extracts_integer_value @@ -128,6 +134,9 @@ function results() result(test_results) 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), & + ! Remove code that exposes a gfortran compiler bug: + !test_description_t( & + ! string_t("extracting an string array value from a colon-separated key/value pair"), extracts_string_array_ptr), & test_description_t( & string_t("extracting an real array value from a colon-separated key/value pair"), extracts_real_array_ptr), & test_description_t( & @@ -291,6 +300,28 @@ function extracts_logical_value() result(passed) #endif end function +#ifndef __GFORTRAN__ + function extracts_string_array_value() result(passed) + logical passed + +#ifndef _CRAYFTN + associate(key_string_array_pair => string_t('"lead singer" : ["stevie", "ray", "vaughn"],')) + associate(string_array => key_string_array_pair%get_json_value(key=string_t("lead singer"), mold=[string_t::])) + passed = all(string_array == [string_t("stevie"), string_t("ray"), string_t("vaughn")]) + end associate + end associate +#else + block + type(string_t) key_string_array_pair + type(string_t), allocatable :: string_array(:) + key_string_array_pair = string_t('"lead singer" : ["ella", "fitzgerald"],') + string_array = key_string_array_pair%get_json_value(key=string_t("lead singer"), mold=[string_t::]) + passed = all(string_array == [string_t("ella"), string_t("fitzgerald")]) + end block +#endif + end function +#endif + function extracts_integer_array_value() result(passed) logical passed