diff --git a/README.md b/README.md index 271ffe982..ad91a849c 100644 --- a/README.md +++ b/README.md @@ -234,7 +234,7 @@ Compiler | Version(s) Tested | Known Issues LLVM `flang-new` | 19, 20 | none NAG `nagfor` | 7.2 Build 7227 | none GCC `gfortran` | 13, 14, 15 | see 1 below -Intel `ifx` | 2025.4 Build 20241205 | see 2 below +Intel `ifx` | 2025.1.1 Build 20250418 | see 2 below 1. `gfortran` issues: - With GCC 14 or earlier, the `test_description_t` constructor's @@ -287,8 +287,9 @@ where the `-ffree-line-length-none` turns on support for lines exceeding the For #### Intel (`ifx`) compiler ``` -fpm test --compiler ifx --flag "-fpp -O3 -coarray" --profile release +fpm test --compiler ifx --flag "-fpp -O3" --profile release ``` +Older versions of `ifx` might require adding `-coarray` to the quoted argument just after `--flag` above. Documentation ------------- diff --git a/src/julienne/julienne_formats_m.F90 b/src/julienne/julienne_formats_m.F90 index 471da85ac..386b8d08f 100644 --- a/src/julienne/julienne_formats_m.F90 +++ b/src/julienne/julienne_formats_m.F90 @@ -4,8 +4,8 @@ module julienne_formats_m !! Useful strings for formatting `print` and `write` statements implicit none - character(len=*), parameter :: csv = "(*(G0,:,','))" !! comma-separated values - character(len=*), parameter :: cscv = "(*('(',G0,',',G0,')',:,',')))" !! comma-separated complex values + character(len=*), parameter :: csv = "(*(G25.20,:,','))" !! comma-separated values + character(len=*), parameter :: cscv = "(*('(',G25.20,',',G25.20,')',:,',')))" !! comma-separated complex values #ifndef _CRAYFTN diff --git a/src/julienne/julienne_formats_s.F90 b/src/julienne/julienne_formats_s.F90 index 20de00956..62adb6680 100644 --- a/src/julienne/julienne_formats_s.F90 +++ b/src/julienne/julienne_formats_s.F90 @@ -10,8 +10,9 @@ module procedure separated_values character(len=*), parameter :: prefix = "(*(G0,:,'" - character(len=*), parameter :: suffix = "'))" + character(len=*), parameter :: double_prefix = "(*(G25.20,:,'" character(len=*), parameter :: complex_prefix = "(*('(',G0,',',G0,')',:,'" + character(len=*), parameter :: suffix = "'))" select rank(mold) rank(1) @@ -19,7 +20,7 @@ type is(complex) format_string = complex_prefix // separator // suffix type is(double precision) - format_string = prefix // separator // suffix + format_string = double_prefix // separator // "'))" type is(real) format_string = prefix // separator // suffix type is(integer) diff --git a/src/julienne/julienne_string_m.f90 b/src/julienne/julienne_string_m.f90 index 02b8f3b8e..d2e4d68bd 100644 --- a/src/julienne/julienne_string_m.f90 +++ b/src/julienne/julienne_string_m.f90 @@ -26,22 +26,24 @@ 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, get_string_t_array_with_character_key, get_string_t_array_with_string_t_key & + generic :: get_json_value => get_string_with_string_key, get_string_with_character_key & + ,get_character_with_character_key, get_character_with_string_key & ,get_real, get_real_with_character_key & - ,get_character, get_character_with_character_key & + ,get_string_t_array_with_character_key, get_string_t_array_with_string_t_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_double_precision, get_double_precision_with_character_key & ,get_double_precision_array, get_double_precision_array_with_character_key + procedure, private :: get_string_with_string_key, get_string_with_character_key + procedure, private :: get_character_with_character_key, get_character_with_string_key procedure, private :: get_real, get_real_with_character_key - procedure, private :: get_string, get_string_t_array_with_character_key, get_string_t_array_with_string_t_key + procedure, private :: get_string_t_array_with_character_key, get_string_t_array_with_string_t_key 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 :: get_character, get_character_with_character_key procedure, private :: get_double_precision, get_double_precision_with_character_key procedure, private :: get_double_precision_array, get_double_precision_array_with_character_key procedure, private :: string_t_ne_string_t, string_t_ne_character @@ -250,21 +252,28 @@ pure module function get_double_precision_array_with_character_key(self, key, mo double precision, allocatable :: value_(:) end function - pure module function get_character(self, key, mold) result(value_) + 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 + + pure module function get_character_with_string_key(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_) + elemental module function get_string_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_ + class(string_t), intent(in) :: self, mold + character(len=*), intent(in) :: key + type(string_t) :: value_ end function - elemental module function get_string(self, key, mold) result(value_) + elemental module function get_string_with_string_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self, key, mold type(string_t) :: value_ diff --git a/src/julienne/julienne_string_s.F90 b/src/julienne/julienne_string_s.F90 index d92b33773..976aeec40 100644 --- a/src/julienne/julienne_string_s.F90 +++ b/src/julienne/julienne_string_s.F90 @@ -220,14 +220,39 @@ end procedure - module procedure get_character - associate(string_value => self%get_string(key, string_t(mold))) - value_ = string_value%string() + module procedure get_string_with_string_key + + character(len=:), allocatable :: raw_line + + call_assert(key==self%get_json_key()) + + raw_line = self%string() + associate(text_after_colon => raw_line(index(raw_line, ':')+1:)) + associate(opening_value_quotes => index(text_after_colon, '"')) + associate(closing_value_quotes => opening_value_quotes + index(text_after_colon(opening_value_quotes+1:), '"')) + if (any([opening_value_quotes, closing_value_quotes] == 0)) then + value_ = string_t(trim(adjustl((text_after_colon)))) + else + value_ = string_t(text_after_colon(opening_value_quotes+1:closing_value_quotes-1)) + end if + end associate + end associate end associate + end procedure + module procedure get_string_with_character_key + value_ = self%get_string_with_string_key(string_t(key), mold) + end procedure + module procedure get_character_with_character_key - associate(string_value => self%get_string(string_t(key), string_t(mold))) + associate(string_value => self%get_string_with_string_key(string_t(key), string_t(mold))) + value_ = string_value%string() + end associate + end procedure + + module procedure get_character_with_string_key + associate(string_value => self%get_string_with_string_key(key, string_t(mold))) value_ = string_value%string() end associate end procedure @@ -265,26 +290,6 @@ end associate end procedure - module procedure get_string - - character(len=:), allocatable :: raw_line - - call_assert(key==self%get_json_key()) - - raw_line = self%string() - associate(text_after_colon => raw_line(index(raw_line, ':')+1:)) - associate(opening_value_quotes => index(text_after_colon, '"')) - associate(closing_value_quotes => opening_value_quotes + index(text_after_colon(opening_value_quotes+1:), '"')) - if (any([opening_value_quotes, closing_value_quotes] == 0)) then - value_ = string_t(trim(adjustl((text_after_colon)))) - else - value_ = string_t(text_after_colon(opening_value_quotes+1:closing_value_quotes-1)) - end if - end associate - end associate - end associate - - end procedure module procedure get_logical_with_character_key value_ = self%get_logical(string_t(key), mold) diff --git a/src/julienne/julienne_test_diagnosis_m.F90 b/src/julienne/julienne_test_diagnosis_m.F90 index a395ffff1..4ea7732ce 100644 --- a/src/julienne/julienne_test_diagnosis_m.F90 +++ b/src/julienne/julienne_test_diagnosis_m.F90 @@ -15,6 +15,7 @@ module julienne_test_diagnosis_m public :: julienne_assert public :: operator(.all.) public :: operator(.and.) + public :: operator(.also.) public :: operator(.approximates.) public :: operator(.isAtLeast.) public :: operator(.isAtMost.) @@ -181,9 +182,9 @@ pure module function aggregate_rank15_diagnosis(diagnoses) result(diagnosis) #endif end interface - interface operator(.and.) + interface operator(.also.) - elemental module function and(lhs, rhs) result(diagnosis) + elemental module function also(lhs, rhs) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: lhs, rhs type(test_diagnosis_t) diagnosis @@ -191,6 +192,10 @@ elemental module function and(lhs, rhs) result(diagnosis) end interface + interface operator(.and.) ! TODO: deprecate overloading an intrinsic operator + module procedure also + end interface + interface operator(.approximates.) elemental module function approximates_real(actual, expected) result(operands) diff --git a/src/julienne/julienne_test_diagnosis_s.F90 b/src/julienne/julienne_test_diagnosis_s.F90 index 7b359d500..249fb974c 100644 --- a/src/julienne/julienne_test_diagnosis_s.F90 +++ b/src/julienne/julienne_test_diagnosis_s.F90 @@ -10,7 +10,7 @@ implicit none contains - module procedure and + module procedure also diagnosis = .all. ([lhs,rhs]) end procedure diff --git a/src/julienne_m.f90 b/src/julienne_m.f90 index 38d36c62a..68b5ae8b6 100644 --- a/src/julienne_m.f90 +++ b/src/julienne_m.f90 @@ -13,7 +13,8 @@ module julienne_m ,call_julienne_assert_ & ,julienne_assert & ,operator(.all.) & - ,operator(.and.) & + ,operator(.also.) & + ,operator(.and.) & ! ssame as .also. TODO: deprecate .and. to avoid confusion with intrinsic operator ,operator(.approximates.) & ,operator(.equalsExpected.) & ,operator(.isAtLeast.) & diff --git a/test/modules/formats_test_m.F90 b/test/modules/formats_test_m.F90 index 4e86ded29..6ca6f87ea 100644 --- a/test/modules/formats_test_m.F90 +++ b/test/modules/formats_test_m.F90 @@ -147,7 +147,7 @@ function check_csv_character() result(test_diagnosis) character(len=200) captured_output character(len=*), parameter :: expected_output = "Yodel, Ay, Hee, Hoo!" - write(captured_output, fmt = separated_values(separator=", ", mold=[integer::])) "Yodel", "Ay", "Hee", "Hoo!" + write(captured_output, fmt = separated_values(separator=", ", mold=[character::])) "Yodel", "Ay", "Hee", "Hoo!" test_diagnosis = test_diagnosis_t( & test_passed = expected_output == captured_output & diff --git a/test/modules/string_test_m.F90 b/test/modules/string_test_m.F90 index 7b693e2cc..409a3f45c 100644 --- a/test/modules/string_test_m.F90 +++ b/test/modules/string_test_m.F90 @@ -17,6 +17,8 @@ module string_test_m #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY ,diagnosis_function_i & #endif + ,operator(.equalsExpected.) & + ,operator(.also.) & ,operator(.cat.) & ,operator(.csv.) & ,operator(.sv.) @@ -49,7 +51,7 @@ function results() result(test_results) ,test_description_t("extracting a key string from a colon-separated key/value pair", extracts_key)& ,test_description_t("extracting double-precision value from colon-separated key/value pair", extracts_double_precision_value)& ,test_description_t("extracting a real value from a colon-separated key/value pair", extracts_real_value)& - ,test_description_t("extracting a string value from a colon-separated key/value pair", extracts_character_value)& + ,test_description_t("extracting a character value from a colon-separated key/value pair", extracts_character_value)& ,test_description_t("extracting a string value from a colon-separated key/value pair", extracts_string_value)& ,test_description_t("extracting an integer value from a colon-separated key/value pair", extracts_integer_value)& ,test_description_t("extracting a logical value from a colon-separated key/value pair", extracts_logical_value)& @@ -78,72 +80,42 @@ function results() result(test_results) #else ! Work around missing Fortran 2008 feature: associating a procedure actual argument with a procedure pointer dummy argument: procedure(diagnosis_function_i), pointer :: & - check_allocation_ptr & - ,extracts_key_ptr & - ,extracts_double_precision_value_ptr & - ,extracts_real_value_ptr & - ,extracts_character_value_ptr & - ,extracts_string_value_ptr & - ,extracts_integer_value_ptr & - ,extracts_logical_value_ptr & - ,extracts_integer_array_value_ptr & - ,extracts_real_array_value_ptr & - ,extracts_dp_array_value_ptr & - ,supports_equivalence_operator_ptr & - ,supports_non_equivalence_operator_ptr & - ,assigns_string_t_to_character_ptr & - ,assigns_character_to_string_t_ptr & - ,supports_concatenation_operator_ptr & - ,constructs_from_default_integer_ptr & - ,constructs_from_default_real_ptr & - ,constructs_from_double_precision_ptr & - ,constructs_from_default_complex_ptr & - ,constructs_from_default_logical_ptr & - ,constructs_from_logical_c_bool_ptr & - ,extracts_file_base_name_ptr & - ,extracts_file_name_extension_ptr & - ,concatenates_elements_ptr & - ,brackets_strings_ptr & - ,extracts_string_array_value_ptr & - ,constructs_separated_values_ptr & - ,constructs_from_double_precision_complex_ptr - - check_allocation_ptr => check_allocation - extracts_key_ptr => extracts_key - extracts_double_precision_value_ptr => extracts_double_precision_value - extracts_real_value_ptr => extracts_real_value - extracts_character_value_ptr => extracts_character_value - extracts_string_value_ptr => extracts_string_value - extracts_integer_value_ptr => extracts_integer_value - extracts_logical_value_ptr => extracts_logical_value - extracts_integer_array_value_ptr => extracts_integer_array_value - extracts_real_array_value_ptr => extracts_real_array_value - extracts_dp_array_value_ptr => extracts_dp_array_value - supports_equivalence_operator_ptr => supports_equivalence_operator - supports_non_equivalence_operator_ptr => supports_non_equivalence_operator - assigns_string_t_to_character_ptr => assigns_string_t_to_character - assigns_character_to_string_t_ptr => assigns_character_to_string_t - supports_concatenation_operator_ptr => supports_concatenation_operator - constructs_from_default_integer_ptr => constructs_from_default_integer - constructs_from_default_real_ptr => constructs_from_default_real - constructs_from_double_precision_ptr => constructs_from_double_precision - constructs_from_default_complex_ptr => constructs_from_default_complex - constructs_from_default_logical_ptr => constructs_from_default_logical - constructs_from_logical_c_bool_ptr => constructs_from_logical_c_bool - extracts_file_base_name_ptr => extracts_file_base_name - extracts_file_name_extension_ptr => extracts_file_name_extension - concatenates_elements_ptr => concatenates_elements - brackets_strings_ptr => brackets_strings - extracts_string_array_value_ptr => extracts_string_array_value - constructs_separated_values_ptr => constructs_separated_values - constructs_from_double_precision_complex_ptr => constructs_from_double_precision_complex + check_allocation_ptr => check_allocation & + ,extracts_key_ptr => extracts_key & + ,extracts_double_precision_value_ptr => extracts_double_precision_value & + ,extracts_real_value_ptr => extracts_real_value & + ,extracts_character_value_ptr => extracts_character_value & + ,extracts_string_value_ptr => extracts_string_value & + ,extracts_integer_value_ptr => extracts_integer_value & + ,extracts_logical_value_ptr => extracts_logical_value & + ,extracts_integer_array_value_ptr => extracts_integer_array_value & + ,extracts_real_array_value_ptr => extracts_real_array_value & + ,extracts_dp_array_value_ptr => extracts_dp_array_value & + ,supports_equivalence_operator_ptr => supports_equivalence_operator & + ,supports_non_equivalence_operator_ptr => supports_non_equivalence_operator & + ,assigns_string_t_to_character_ptr => assigns_string_t_to_character & + ,assigns_character_to_string_t_ptr => assigns_character_to_string_t & + ,supports_concatenation_operator_ptr => supports_concatenation_operator & + ,constructs_from_default_integer_ptr => constructs_from_default_integer & + ,constructs_from_default_real_ptr => constructs_from_default_real & + ,constructs_from_double_precision_ptr => constructs_from_double_precision & + ,constructs_from_default_complex_ptr => constructs_from_default_complex & + ,constructs_from_default_logical_ptr => constructs_from_default_logical & + ,constructs_from_logical_c_bool_ptr => constructs_from_logical_c_bool & + ,extracts_file_base_name_ptr => extracts_file_base_name & + ,extracts_file_name_extension_ptr => extracts_file_name_extension & + ,concatenates_elements_ptr => concatenates_elements & + ,brackets_strings_ptr => brackets_strings & + ,extracts_string_array_value_ptr => extracts_string_array_value & + ,constructs_separated_values_ptr => constructs_separated_values & + ,constructs_from_double_precision_complex_ptr => constructs_from_double_precision_complex test_descriptions = [ & test_description_t("is_allocated() result .true. if & only if the string_t component(s) is/are allocated", check_allocation_ptr)& ,test_description_t("extracting a key string from a colon-separated key/value pair", extracts_key_ptr)& ,test_description_t("extracting double-precision value from colon-separated key/value pair", extracts_double_precision_value_ptr)& ,test_description_t("extracting a real value from a colon-separated key/value pair", extracts_real_value_ptr)& - ,test_description_t("extracting a string value from a colon-separated key/value pair", extracts_character_value_ptr)& + ,test_description_t("extracting a character value from a colon-separated key/value pair", extracts_character_value_ptr)& ,test_description_t("extracting a string value from a colon-separated key/value pair", extracts_string_value_ptr)& ,test_description_t("extracting an integer value from a colon-separated key/value pair", extracts_integer_value_ptr)& ,test_description_t("extracting a logical value from a colon-separated key/value pair", extracts_logical_value_ptr)& @@ -238,33 +210,29 @@ function extracts_real_value() result(test_diagnosis) function extracts_character_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis - associate(line => string_t('"foo" : "bar"'), line_with_comma => string_t('"foo" : "bar",')) - associate(json_values => [ & - line%get_json_value(key="foo" , mold="") & - ,line%get_json_value(key=string_t("foo"), mold="") & - ,line_with_comma%get_json_value(key="foo" , mold="") & - ,line_with_comma%get_json_value(key=string_t("foo"), mold="") & - ]) - test_diagnosis = test_diagnosis_t( & - test_passed = all(json_values == "bar") & - ,diagnostics_string = "expected bar; actual " // .csv. json_values & - ) + associate(line => string_t('"foo" : "bar"')) + associate(line_with_comma => line // ",") + test_diagnosis = ( line%get_json_value(key= "foo" , mold="") .equalsExpected. "bar") & + .also. ( line%get_json_value(key=string_t("foo"), mold="") .equalsExpected. "bar") & + .also. (line_with_comma%get_json_value(key= "foo" , mold="") .equalsExpected. "bar") & + .also. (line_with_comma%get_json_value(key=string_t("foo") , mold="") .equalsExpected. "bar") end associate end associate + end function function extracts_string_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate(line => string_t('"foo" : "bar"')) - associate(json_value => line%get_json_value(key=string_t("foo"), mold=string_t(""))) - test_diagnosis = test_diagnosis_t( & - test_passed = json_value == "bar", & - diagnostics_string = "expected 'bar', actual " // json_value & - ) + associate(line_with_comma => line // ",") + test_diagnosis = ( line%get_json_value(key= "foo" , mold=string_t("")) .equalsExpected. "bar") & + .also. ( line%get_json_value(key=string_t("foo"), mold=string_t("")) .equalsExpected. "bar") & + .also. (line_with_comma%get_json_value(key= "foo" , mold=string_t("")) .equalsExpected. "bar") & + .also. (line_with_comma%get_json_value(key=string_t("foo") , mold=string_t("")) .equalsExpected. "bar") end associate end associate - + end function function extracts_integer_value() result(test_diagnosis)