diff --git a/include/language-support.F90 b/include/language-support.F90 index ce17704d6..581262ee5 100644 --- a/include/language-support.F90 +++ b/include/language-support.F90 @@ -1,6 +1,12 @@ ! Copyright (c), The Regents of the University of California ! Terms of use are as specified in LICENSE.txt +#ifdef __GNUC__ +# define GCC_VERSION (__GNUC__ * 10000 + __GNUC_MINOR__ * 100 + __GNUC_PATCHLEVEL__) +#else +# define GCC_VERSION 0 +#endif + #ifndef HAVE_SELECTED_LOGICAL_KIND ! Define whether the compiler supports standard intrinsic function selected_logical_kind(), ! a feature introduced in Fortran 2023 clause 16.9.182. @@ -15,9 +21,9 @@ ! Define whether the compiler supports associating a procedure pointer dummy argument with an ! actual argument that is a valid target for the pointer dummy in a procedure assignment, a ! feature introduced in Fortran 2008 and described in Fortran 2023 clause 15.5.2.10 paragraph 5. -#if defined(_CRAYFTN) || defined(__INTEL_COMPILER) || defined(NAGFOR) || defined(__flang__) -#define HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 1 +#if defined _CRAYFTN || defined __INTEL_COMPILER || defined NAGFOR || defined __flang__ || (GCC_VERSION > 140200) +# define HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 1 #else -#define HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 0 +# define HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 0 #endif #endif diff --git a/manifest/fpm.toml.template b/manifest/fpm.toml.template index 9ac01d497..63e96fd5f 100644 --- a/manifest/fpm.toml.template +++ b/manifest/fpm.toml.template @@ -9,6 +9,7 @@ copyright = "2021-2025 The Regents of the University of California, through Lawr assert = {git = "https://github.com/berkeleylab/assert.git", tag = "3.0.0"} veggies = {git = "https://gitlab.com/everythingfunctional/veggies", tag = "v1.1.3"} iso_varying_string = {git = "https://gitlab.com/everythingfunctional/iso_varying_string.git", tag = "v3.0.4"} +julienne = {git = "https://github.com/berkeleylab/julienne.git", tag = "3.1.0"} [install] library = true diff --git a/test/julienne-driver.F90 b/test/julienne-driver.F90 new file mode 100644 index 000000000..8b82676f5 --- /dev/null +++ b/test/julienne-driver.F90 @@ -0,0 +1,34 @@ +! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +program test_suite_driver + use julienne_m, only : test_fixture_t, test_harness_t + use prif_init_test_m, only : prif_init_test_t + use prif_coarray_inquiry_test_m, only : prif_coarray_inquiry_test_t + use prif_co_broadcast_test_m, only : prif_co_broadcast_test_t + use prif_co_max_test_m, only : prif_co_max_test_t + use prif_co_min_test_m, only : prif_co_min_test_t + use prif_co_reduce_test_m, only :prif_co_reduce_test_t + use prif_co_sum_test_m, only : prif_co_sum_test_t + use prif_image_queries_test_m, only : prif_image_queries_test_t + use prif_num_images_test_m, only : prif_num_images_test_t + use prif_sync_images_test_m, only : prif_sync_images_test_t + use prif_this_image_no_coarray_test_m, only : prif_this_image_no_coarray_test_t + implicit none + + associate(test_harness => test_harness_t([ & + test_fixture_t( prif_init_test_t() ) & + ,test_fixture_t( prif_coarray_inquiry_test_t() ) & + ,test_fixture_t( prif_co_broadcast_test_t() ) & + ,test_fixture_t( prif_co_max_test_t() ) & + ,test_fixture_t( prif_co_min_test_t() ) & + ,test_fixture_t( prif_co_reduce_test_t() ) & + ,test_fixture_t( prif_co_sum_test_t() ) & + ,test_fixture_t( prif_image_queries_test_t() ) & + ,test_fixture_t( prif_num_images_test_t() ) & + ,test_fixture_t( prif_sync_images_test_t() ) & + ,test_fixture_t( prif_this_image_no_coarray_test_t() ) & + ])) + call test_harness%report_results + end associate +end program test_suite_driver diff --git a/test/main.F90 b/test/main.F90 index dbbaf8f21..425fb2ea6 100644 --- a/test/main.F90 +++ b/test/main.F90 @@ -23,32 +23,9 @@ function run() result(passed) use caf_allocate_test, only: & caf_allocate_prif_allocate => & test_prif_allocate - use caf_co_broadcast_test, only: & - caf_co_broadcast_prif_co_broadcast => & - test_prif_co_broadcast - use caf_co_max_test, only: & - caf_co_max_prif_co_max => & - test_prif_co_max - use caf_co_min_test, only: & - caf_co_min_prif_co_min => & - test_prif_co_min - use caf_co_reduce_test, only: & - caf_co_reduce_prif_co_reduce => & - test_prif_co_reduce - use caf_co_sum_test, only: & - caf_co_sum_prif_co_sum => & - test_prif_co_sum - use caf_coarray_inquiry_test, only: & - caf_coarray_inquiry_coarray_inquiry => & - test_coarray_inquiry use caf_image_index_test, only: & caf_image_index_prif_image_index => & test_prif_image_index - use caf_num_images_test, only: & - caf_num_images_prif_num_images => & - test_prif_num_images - use caf_image_queries_test, only: test_prif_image_queries - use caf_sync_images_test, only: test_prif_sync_images use caf_rma_test, only: & caf_rma_prif_rma => & test_prif_rma @@ -61,9 +38,6 @@ function run() result(passed) use caf_teams_test, only: & caf_teams_caf_teams => & test_caf_teams - use caf_this_image_test, only: & - caf_this_image_prif_this_image_no_coarray => & - test_prif_this_image_no_coarray use caf_stop_test, only: test_prif_stop use caf_error_stop_test, only: test_prif_error_stop use veggies, only: test_item_t, test_that, run_tests, result_t @@ -100,22 +74,12 @@ function run() result(passed) #endif individual_tests = [a00_caffeinate_caffeinate()] individual_tests = [individual_tests, caf_allocate_prif_allocate()] - individual_tests = [individual_tests, caf_coarray_inquiry_coarray_inquiry()] - individual_tests = [individual_tests, caf_co_broadcast_prif_co_broadcast()] - individual_tests = [individual_tests, caf_co_max_prif_co_max()] - individual_tests = [individual_tests, caf_co_min_prif_co_min()] - individual_tests = [individual_tests, caf_co_reduce_prif_co_reduce()] - individual_tests = [individual_tests, caf_co_sum_prif_co_sum()] individual_tests = [individual_tests, caf_image_index_prif_image_index()] - individual_tests = [individual_tests, caf_num_images_prif_num_images()] - individual_tests = [individual_tests, test_prif_image_queries()] individual_tests = [individual_tests, caf_rma_prif_rma()] individual_tests = [individual_tests, test_prif_rma_strided()] individual_tests = [individual_tests, caf_teams_caf_teams()] - individual_tests = [individual_tests, caf_this_image_prif_this_image_no_coarray()] individual_tests = [individual_tests, test_prif_atomic()] individual_tests = [individual_tests, test_prif_event()] - individual_tests = [individual_tests, test_prif_sync_images()] individual_tests = [individual_tests, test_prif_stop()] individual_tests = [individual_tests, test_prif_error_stop()] diff --git a/test/prif_co_broadcast_test.F90 b/test/prif_co_broadcast_test.F90 index d7e6f7935..092a47453 100644 --- a/test/prif_co_broadcast_test.F90 +++ b/test/prif_co_broadcast_test.F90 @@ -1,10 +1,28 @@ -module caf_co_broadcast_test +#include "language-support.F90" + +module prif_co_broadcast_test_m use prif, only : prif_co_broadcast, prif_num_images, prif_this_image_no_coarray - use veggies, only : result_t, test_item_t, describe, it, assert_equals, assert_that + use julienne_m, only : & + test_description_t & + ,test_diagnosis_t & + ,test_result_t & + ,test_t & + ,operator(//) & + ,operator(.expect.) & + ,operator(.equalsExpected.) +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : diagnosis_function_i +#endif implicit none private - public :: test_prif_co_broadcast + public :: prif_co_broadcast_test_t + + type, extends(test_t) :: prif_co_broadcast_test_t + contains + procedure, nopass, non_overridable :: subject + procedure, nopass, non_overridable :: results + end type type object_t integer i @@ -19,16 +37,40 @@ module caf_co_broadcast_test contains - function test_prif_co_broadcast() result(tests) - type(test_item_t) tests - - tests = describe( & - "The prif_co_broadcast subroutine", & - [ it("broadcasts a default integer scalar with no optional arguments present", broadcast_default_integer_scalar) & - ,it("broadcasts a derived type scalar with no allocatable components", broadcast_derived_type) & + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = "The prif_co_broadcast subroutine" + end function + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_co_broadcast_test_t) prif_co_broadcast_test + + test_results = prif_co_broadcast_test%run([ & + test_description_t("broadcasting a default integer scalar with no optional arguments present", broadcast_default_integer_scalar) & + ,test_description_t("broadcasting a derived type scalar with no allocatable components", broadcast_derived_type) & ]) end function +#else + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_co_broadcast_test_t) prif_co_broadcast_test + procedure(diagnosis_function_i), pointer :: & + broadcast_default_integer_scalar_ptr => broadcast_default_integer_scalar & + ,broadcast_derived_type_ptr => broadcast_derived_type + + test_results = prif_co_broadcast_test%run([ & + test_description_t("broadcasting a default integer scalar with no optional arguments present", broadcast_default_integer_scalar_ptr) & + ,test_description_t("broadcasting a derived type scalar with no allocatable components", broadcast_derived_type_ptr) & + ]) + end function + +#endif + logical pure function equals(lhs, rhs) type(object_t), intent(in) :: lhs, rhs equals = all([ & @@ -39,30 +81,29 @@ logical pure function equals(lhs, rhs) ]) end function - function broadcast_default_integer_scalar() result(result_) - type(result_t) result_ + function broadcast_default_integer_scalar() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer iPhone, me integer, parameter :: source_value = 7779311, junk = -99 call prif_this_image_no_coarray(this_image=me) iPhone = merge(source_value, junk, me==1) call prif_co_broadcast(iPhone, source_image=1) - result_ = assert_equals(source_value, iPhone) + test_diagnosis = iPhone .equalsExpected. source_value end function - function broadcast_derived_type() result(result_) - type(result_t) result_ + function broadcast_derived_type() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis type(object_t) object - integer :: me, ni + integer me, ni call prif_this_image_no_coarray(this_image=me) call prif_num_images(num_images=ni) object = object_t(me, .false., "gooey", me*(1.,0.)) call prif_co_broadcast(object, source_image=ni) associate(expected_object => object_t(ni, .false., "gooey", ni*(1.,0.))) - result_ = assert_that(expected_object == object, "co_broadcast derived type") + test_diagnosis = .expect. (object == expected_object) // "co_broadcast derived type" end associate - end function -end module caf_co_broadcast_test +end module prif_co_broadcast_test_m diff --git a/test/prif_co_max_test.F90 b/test/prif_co_max_test.F90 index 5305b037d..6ca0d8d6a 100644 --- a/test/prif_co_max_test.F90 +++ b/test/prif_co_max_test.F90 @@ -1,31 +1,87 @@ -module caf_co_max_test - use iso_c_binding, only: c_int8_t, c_int16_t, c_int32_t, c_int64_t, c_float, c_double - use prif, only : prif_co_max, prif_co_max_character, prif_this_image_no_coarray, prif_num_images - use veggies, only: result_t, test_item_t, assert_equals, describe, it, succeed - +#include "language-support.F90" + +module prif_co_max_test_m + use iso_c_binding, only: c_int8_t, c_int16_t, c_int32_t, c_int64_t, c_float, c_double + use prif, only : prif_co_max, prif_co_max_character, prif_this_image_no_coarray, prif_num_images + use julienne_m, only: & + operator(.all.) & + ,operator(.approximates.) & + ,operator(.within.) & + ,operator(.equalsExpected.) & + ,test_description_t & + ,test_diagnosis_t & + ,test_result_t & + ,test_t +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : diagnosis_function_i +#endif implicit none + + private - public :: test_prif_co_max + public :: prif_co_max_test_t + + type, extends(test_t) :: prif_co_max_test_t + contains + procedure, nopass, non_overridable :: subject + procedure, nopass, non_overridable :: results + end type contains - function test_prif_co_max() result(tests) - type(test_item_t) tests - - tests = describe( & - "The prif_co_max subroutine computes the maximum value across images for corresponding elements for", & - [ it("a 1D default integer array", check_default_integer) & - , it("a 1D 8-bit integer array", check_8_bit_integer) & - , it("a 1D 16-bit integer array", check_16_bit_integer) & - , it("32-bit integer scalars", check_32_bit_integer) & - , it("a 1D 64-bit integer array", check_64_bit_integer) & - , it("a 2D 32-bit real array", check_32_bit_real) & - , it("a 1D 64-bit real array", check_64_bit_real) & - , it("a character scalar", check_character) & - ]) + + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = "The prif_co_max subroutine" + end function + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_co_max_test_t) prif_co_max_test + + test_results = prif_co_max_test%run([ & + test_description_t("computing element-wise maxima for integer(c_int32_t) scalars", check_32_bit_integer) & + ,test_description_t("computing element-wise maxima for a 1D default integer array", check_default_integer) & + ,test_description_t("computing element-wise maxima for a 1D integer(c_int8_t) array", check_8_bit_integer) & + ,test_description_t("computing element-wise maxima for a 1D integer(c_int16_t) array", check_16_bit_integer) & + ,test_description_t("computing element-wise maxima for a 1D integer(c_int64_t array", check_64_bit_integer) & + ,test_description_t("computing element-wise maxima for a 2D real(c_float) array", check_32_bit_real) & + ,test_description_t("computing element-wise maxima for a 1D real(c_double array", check_64_bit_real) & + ,test_description_t("computing element-wise maxima for character scalars", check_character) & + ]) + end function + +#else + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_co_max_test_t) prif_co_max_test + procedure(diagnosis_function_i), pointer :: & + check_32_bit_integer_ptr => check_32_bit_integer & + ,check_default_integer_ptr => check_default_integer & + ,check_8_bit_integer_ptr => check_8_bit_integer & + ,check_16_bit_integer_ptr => check_16_bit_integer & + ,check_64_bit_integer_ptr => check_64_bit_integer & + ,check_32_bit_real_ptr => check_32_bit_real & + ,check_64_bit_real_ptr => check_64_bit_real & + ,check_character_ptr => check_character + + test_results = prif_co_max_test%run([ & + test_description_t("computing element-wise maxima for integer(c_int32_t) scalars", check_32_bit_integer_ptr) & + ,test_description_t("computing element-wise maxima for a 1D default integer array", check_default_integer_ptr) & + ,test_description_t("computing element-wise maxima for a 1D integer(c_int8_t) array", check_8_bit_integer_ptr) & + ,test_description_t("computing element-wise maxima for a 1D integer(c_int16_t) array", check_16_bit_integer_ptr) & + ,test_description_t("computing element-wise maxima for a 1D integer(c_int64_t array", check_64_bit_integer_ptr) & + ,test_description_t("computing element-wise maxima for a 2D real(c_float) array", check_32_bit_real_ptr) & + ,test_description_t("computing element-wise maxima for a 1D real(c_double array", check_64_bit_real_ptr) & + ,test_description_t("computing element-wise maxima for character scalars", check_character_ptr) & + ]) end function - function check_default_integer() result(result_) - type(result_t) :: result_ +#endif + function check_default_integer() result(test_diagnosis) + type(test_diagnosis_t) :: test_diagnosis integer, parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) integer :: me, ni, i @@ -38,11 +94,11 @@ function check_default_integer() result(result_) call prif_co_max(my_val) expected = maxval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(int(expected), int(my_val)) + test_diagnosis = .all. (int(my_val) .equalsExpected. int(expected)) end function - function check_8_bit_integer() result(result_) - type(result_t) :: result_ + function check_8_bit_integer() result(test_diagnosis) + type(test_diagnosis_t) :: test_diagnosis integer(c_int8_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int8_t), [2, 4]) integer :: me, ni, i @@ -55,11 +111,11 @@ function check_8_bit_integer() result(result_) call prif_co_max(my_val) expected = maxval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(int(expected), int(my_val)) + test_diagnosis = .all. (int(my_val) .equalsExpected. int(expected)) end function - function check_16_bit_integer() result(result_) - type(result_t) :: result_ + function check_16_bit_integer() result(test_diagnosis) + type(test_diagnosis_t) :: test_diagnosis integer(c_int16_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int16_t), [2, 4]) integer :: me, ni, i @@ -72,11 +128,11 @@ function check_16_bit_integer() result(result_) call prif_co_max(my_val) expected = maxval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(int(expected), int(my_val)) + test_diagnosis = .all. (int(my_val) .equalsExpected. int(expected)) end function - function check_32_bit_integer() result(result_) - type(result_t) :: result_ + function check_32_bit_integer() result(test_diagnosis) + type(test_diagnosis_t) :: test_diagnosis integer(c_int32_t), parameter :: values(*) = [1, -19, 5, 13, 11, 7, 17, 3] integer :: me, ni, i @@ -89,11 +145,11 @@ function check_32_bit_integer() result(result_) call prif_co_max(my_val) expected = maxval([(values(mod(i-1,size(values))+1), i = 1, ni)]) - result_ = assert_equals(expected, my_val) + test_diagnosis = my_val .equalsExpected. expected end function - function check_64_bit_integer() result(result_) - type(result_t) :: result_ + function check_64_bit_integer() result(test_diagnosis) + type(test_diagnosis_t) :: test_diagnosis integer(c_int64_t), parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) integer :: me, ni, i @@ -106,13 +162,14 @@ function check_64_bit_integer() result(result_) call prif_co_max(my_val) expected = maxval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(int(expected), int(my_val)) + test_diagnosis = .all. (int(my_val) .equalsExpected. int(expected)) end function - function check_32_bit_real() result(result_) - type(result_t) :: result_ + function check_32_bit_real() result(test_diagnosis) + type(test_diagnosis_t) :: test_diagnosis real(c_float), parameter :: values(*,*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2,2,2]) + real(c_float), parameter :: tolerance = 0_c_float integer :: me, ni, i real(c_float), dimension(size(values,1), size(values,2)) :: my_val, expected @@ -123,13 +180,14 @@ function check_32_bit_real() result(result_) call prif_co_max(my_val) expected = maxval(reshape([(values(:,:,mod(i-1,size(values,3))+1), i = 1, ni)], [size(values,1), size(values,2), ni]), dim=3) - result_ = assert_equals(real(expected,kind=c_double), real(my_val,kind=c_double)) + test_diagnosis = .all. (my_val .approximates. expected .within. tolerance) end function - function check_64_bit_real() result(result_) - type(result_t) :: result_ + function check_64_bit_real() result(test_diagnosis) + type(test_diagnosis_t) :: test_diagnosis real(c_double), parameter :: values(*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2, 4]) + real(c_double), parameter :: tolerance = 0_c_double integer :: me, ni, i real(c_double), dimension(size(values,1)) :: my_val, expected @@ -140,11 +198,11 @@ function check_64_bit_real() result(result_) call prif_co_max(my_val) expected = maxval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(expected, my_val) + test_diagnosis = .all. (my_val .approximates. expected .within. tolerance) end function - function check_character() result(result_) - type(result_t) result_ + function check_character() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis character(len=*), parameter :: values(*) = & [ "To be ","or not " & , "to ","be. " & @@ -161,9 +219,8 @@ function check_character() result(result_) ! issue #205: workaround flang optimizer bug with a temp associate(tmp => [(values(mod(i-1,size(values))+1), i = 1, ni)]) - expected = maxval(tmp) + test_diagnosis = my_val .equalsExpected. maxval(tmp) end associate - result_ = assert_equals(expected, my_val) end function -end module caf_co_max_test +end module prif_co_max_test_m diff --git a/test/prif_co_min_test.F90 b/test/prif_co_min_test.F90 index 2a85a2bc2..fe4e77406 100644 --- a/test/prif_co_min_test.F90 +++ b/test/prif_co_min_test.F90 @@ -1,169 +1,225 @@ -module caf_co_min_test - use iso_c_binding, only: c_int8_t, c_int16_t, c_int32_t, c_int64_t, c_float, c_double - use prif, only : prif_co_min, prif_co_min_character, prif_this_image_no_coarray, prif_num_images - use veggies, only: result_t, test_item_t, assert_equals, describe, it, succeed - - implicit none - private - public :: test_prif_co_min +#include "language-support.F90" + +module prif_co_min_test_m + use iso_c_binding, only: c_int8_t, c_int16_t, c_int32_t, c_int64_t, c_float, c_double + use prif, only : prif_co_min, prif_co_min_character, prif_this_image_no_coarray, prif_num_images + use julienne_m, only: & + operator(.all.) & + ,operator(.approximates.) & + ,operator(.within.) & + ,operator(.equalsExpected.) & + ,test_description_t & + ,test_diagnosis_t & + ,test_result_t & + ,test_t +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : diagnosis_function_i +#endif + implicit none + + private + public :: prif_co_min_test_t + + type, extends(test_t) :: prif_co_min_test_t + contains + procedure, nopass, non_overridable :: subject + procedure, nopass, non_overridable :: results + end type contains - function test_prif_co_min() result(tests) - type(test_item_t) tests - - tests = describe( & - "The prif_co_min subroutine computes the minimum value across images for corresponding elements for", & - [ it("a 1D default integer array", check_default_integer) & - , it("a 1D 8-bit integer array", check_8_bit_integer) & - , it("a 1D 16-bit integer array", check_16_bit_integer) & - , it("32-bit integer scalars", check_32_bit_integer) & - , it("a 1D 64-bit integer array", check_64_bit_integer) & - , it("a 2D 32-bit real array", check_32_bit_real) & - , it("a 1D 64-bit real array", check_64_bit_real) & - , it("a character scalar", check_character) & - ]) - end function - - function check_default_integer() result(result_) - type(result_t) :: result_ - - integer, parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) - integer :: me, ni, i - integer, dimension(size(values,1)) :: my_val, expected - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) - - my_val = values(:, mod(me-1, size(values,2))+1) - call prif_co_min(my_val) - - expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(int(expected), int(my_val)) - end function - - function check_8_bit_integer() result(result_) - type(result_t) :: result_ - - integer(c_int8_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int8_t), [2, 4]) - integer :: me, ni, i - integer(c_int8_t), dimension(size(values,1)) :: my_val, expected - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) - - my_val = values(:, mod(me-1, size(values,2))+1) - call prif_co_min(my_val) - - expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(int(expected), int(my_val)) - end function - - function check_16_bit_integer() result(result_) - type(result_t) :: result_ - - integer(c_int16_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int16_t), [2, 4]) - integer :: me, ni, i - integer(c_int16_t), dimension(size(values,1)) :: my_val, expected - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) - - my_val = values(:, mod(me-1, size(values,2))+1) - call prif_co_min(my_val) - - expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(int(expected), int(my_val)) - end function - - function check_32_bit_integer() result(result_) - type(result_t) :: result_ - - integer(c_int32_t), parameter :: values(*) = [1, -19, 5, 13, 11, 7, 17, 3] - integer :: me, ni, i - integer(c_int32_t) :: my_val, expected + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = "The prif_co_min subroutine" + end function + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_co_min_test_t) prif_co_min_test + + test_results = prif_co_min_test%run([ & + test_description_t("computing element-wise minima for integer(c_int32_t) scalars", check_32_bit_integer) & + ,test_description_t("computing element-wise minima for a 1D default integer array", check_default_integer) & + ,test_description_t("computing element-wise minima for a 1D integer(c_int8t) array", check_8_bit_integer) & + ,test_description_t("computing element-wise minima for a 1D integer(c_int16_t) array", check_16_bit_integer) & + ,test_description_t("computing element-wise minima for a 1D integer(c_int64_t) array", check_64_bit_integer) & + ,test_description_t("computing element-wise minima for a 2D real(c_float) array", check_32_bit_real) & + ,test_description_t("computing element-wise minima for a 1D real(c_double) array", check_64_bit_real) & + ,test_description_t("computing element-wise minima for a character scalar", check_character) & + ]) + end function + +#else + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_co_min_test_t) prif_co_min_test + procedure(diagnosis_function_i), pointer :: & + check_32_bit_integer_ptr => check_32_bit_integer & + ,check_default_integer_ptr => check_default_integer & + ,check_8_bit_integer_ptr => check_8_bit_integer & + ,check_16_bit_integer_ptr => check_16_bit_integer & + ,check_64_bit_integer_ptr => check_64_bit_integer & + ,check_32_bit_real_ptr => check_32_bit_real & + ,check_64_bit_real_ptr => check_64_bit_real & + ,check_character_ptr => check_character + + test_results = prif_co_min_test%run([ & + test_description_t("computing element-wise minima for integer(c_int32_t) scalars", check_32_bit_integer_ptr) & + ,test_description_t("computing element-wise minima for a 1D default integer array", check_default_integer_ptr) & + ,test_description_t("computing element-wise minima for a 1D integer(c_int8t) array", check_8_bit_integer_ptr) & + ,test_description_t("computing element-wise minima for a 1D integer(c_int16_t) array", check_16_bit_integer_ptr) & + ,test_description_t("computing element-wise minima for a 1D integer(c_int64_t) array", check_64_bit_integer_ptr) & + ,test_description_t("computing element-wise minima for a 2D real(c_float) array", check_32_bit_real_ptr) & + ,test_description_t("computing element-wise minima for a 1D real(c_double) array", check_64_bit_real_ptr) & + ,test_description_t("computing element-wise minima for a character scalar", check_character_ptr) & + ]) + end function + +#endif + + function check_default_integer() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) + integer, parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) + integer, dimension(size(values,1)) :: my_val, expected + integer me, ni, i - my_val = values(mod(me-1, size(values))+1) - call prif_co_min(my_val) + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) + + my_val = values(:, mod(me-1, size(values,2))+1) + call prif_co_min(my_val) + + expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) + test_diagnosis = .all. (int(my_val) .equalsExpected. int(expected)) + end function - expected = minval([(values(mod(i-1,size(values))+1), i = 1, ni)]) - result_ = assert_equals(expected, my_val) - end function + function check_8_bit_integer() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + + integer(c_int8_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int8_t), [2, 4]) + integer :: me, ni, i + integer(c_int8_t), dimension(size(values,1)) :: my_val, expected + + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) + + my_val = values(:, mod(me-1, size(values,2))+1) + call prif_co_min(my_val) + + expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) + test_diagnosis = .all. (int(my_val) .equalsExpected. int(expected)) + end function + + function check_16_bit_integer() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + + integer(c_int16_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int16_t), [2, 4]) + integer :: me, ni, i + integer(c_int16_t), dimension(size(values,1)) :: my_val, expected + + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) + + my_val = values(:, mod(me-1, size(values,2))+1) + call prif_co_min(my_val) + + expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) + test_diagnosis = .all. (int(my_val) .equalsExpected. int(expected)) + end function + + function check_32_bit_integer() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + + integer(c_int32_t), parameter :: values(*) = [1, -19, 5, 13, 11, 7, 17, 3] + integer :: me, ni, i + integer(c_int32_t) :: my_val, expected + + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) + + my_val = values(mod(me-1, size(values))+1) + call prif_co_min(my_val) + + expected = minval([(values(mod(i-1,size(values))+1), i = 1, ni)]) + test_diagnosis = int(my_val) .equalsExpected. int(expected) + end function - function check_64_bit_integer() result(result_) - type(result_t) :: result_ + function check_64_bit_integer() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis - integer(c_int64_t), parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) - integer :: me, ni, i - integer(c_int64_t), dimension(size(values,1)) :: my_val, expected + integer(c_int64_t), parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) + integer :: me, ni, i + integer(c_int64_t), dimension(size(values,1)) :: my_val, expected - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) - my_val = values(:, mod(me-1, size(values,2))+1) - call prif_co_min(my_val) + my_val = values(:, mod(me-1, size(values,2))+1) + call prif_co_min(my_val) - expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(int(expected), int(my_val)) - end function + expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) + test_diagnosis = .all. (int(my_val) .equalsExpected. int(expected)) + end function - function check_32_bit_real() result(result_) - type(result_t) :: result_ + function check_32_bit_real() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis - real(c_float), parameter :: values(*,*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2,2,2]) - integer :: me, ni, i - real(c_float), dimension(size(values,1), size(values,2)) :: my_val, expected + real(c_float), parameter :: values(*,*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2,2,2]) + real(c_double), parameter :: tolerance = 0_c_double + integer :: me, ni, i + real(c_float), dimension(size(values,1), size(values,2)) :: my_val, expected - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) - my_val = values(:, :, mod(me-1, size(values,3))+1) - call prif_co_min(my_val) + my_val = values(:, :, mod(me-1, size(values,3))+1) + call prif_co_min(my_val) - expected = minval(reshape([(values(:,:,mod(i-1,size(values,3))+1), i = 1, ni)], [size(values,1), size(values,2), ni]), dim=3) - result_ = assert_equals(real(expected,kind=c_double), real(my_val,kind=c_double)) - end function + expected = minval(reshape([(values(:,:,mod(i-1,size(values,3))+1), i = 1, ni)], [size(values,1), size(values,2), ni]), dim=3) + test_diagnosis = .all. (real(expected,kind=c_double) .approximates. real(my_val,kind=c_double) .within. tolerance) + end function - function check_64_bit_real() result(result_) - type(result_t) :: result_ + function check_64_bit_real() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis - real(c_double), parameter :: values(*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2, 4]) - integer :: me, ni, i - real(c_double), dimension(size(values,1)) :: my_val, expected + real(c_double), parameter :: values(*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2, 4]) + real(c_double), parameter :: tolerance = 0_c_double + integer :: me, ni, i + real(c_double), dimension(size(values,1)) :: my_val, expected - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) - my_val = values(:, mod(me-1, size(values,2))+1) - call prif_co_min(my_val) + my_val = values(:, mod(me-1, size(values,2))+1) + call prif_co_min(my_val) - expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(expected, my_val) - end function + expected = minval(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) + test_diagnosis = .all. (my_val .approximates. expected .within. tolerance) + end function - function check_character() result(result_) - type(result_t) result_ - character(len=*), parameter :: values(*) = & - [ "To be ","or not " & - , "to ","be. " & - , "that ","is " & - , "the ","question"] - integer :: me, ni, i - character(len=len(values)) :: my_val, expected + function check_character() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + character(len=*), parameter :: values(*) = & + [ "To be ","or not " & + , "to ","be. " & + , "that ","is " & + , "the ","question"] + character(len=len(values)) my_val + integer me, ni, i - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) - my_val = values(mod(me-1, size(values))+1) - call prif_co_min_character(my_val) + my_val = values(mod(me-1, size(values))+1) + call prif_co_min_character(my_val) - ! issue #205: workaround flang optimizer bug with a temp - associate(tmp => [(values(mod(i-1,size(values))+1), i = 1, ni)]) - expected = minval(tmp) - end associate - result_ = assert_equals(expected, my_val) - end function + ! issue #205: workaround flang optimizer bug with a temp + associate(tmp => [(values(mod(i-1,size(values))+1), i = 1, ni)]) + test_diagnosis = .all. (my_val .equalsExpected. minval(tmp)) + end associate + end function -end module caf_co_min_test +end module prif_co_min_test_m diff --git a/test/prif_co_reduce_test.F90 b/test/prif_co_reduce_test.F90 index ebcbcf22f..5c4e2fd0d 100644 --- a/test/prif_co_reduce_test.F90 +++ b/test/prif_co_reduce_test.F90 @@ -1,11 +1,32 @@ -module caf_co_reduce_test +#include "language-support.F90" + +module prif_co_reduce_test_m use iso_c_binding, only: c_ptr, c_funptr, c_size_t, c_f_pointer, c_f_procpointer, c_funloc, c_loc, c_null_ptr use prif, only : prif_co_reduce, prif_num_images, prif_this_image_no_coarray, prif_operation_wrapper_interface - use veggies, only : result_t, test_item_t, assert_equals, assert_not, assert_that, describe, it, succeed - + use julienne_m, only : & + operator(.all.) & + ,operator(.also.) & + ,operator(.approximates.) & + ,operator(.equalsExpected.) & + ,operator(.expect.) & + ,operator(.within.) & + ,test_description_t & + ,test_diagnosis_t & + ,test_result_t & + ,test_t +#if ! HAVE_PROCEDURAL_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : diagnosis_function_i +#endif implicit none + private - public :: test_prif_co_reduce + public :: prif_co_reduce_test_t + + type, extends(test_t) :: prif_co_reduce_test_t + contains + procedure, nopass, non_overridable :: subject + procedure, nopass, non_overridable :: results + end type type :: pair integer :: fst @@ -26,21 +47,53 @@ module caf_co_reduce_test contains - function test_prif_co_reduce() result(tests) - type(test_item_t) tests + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = "The prif_co_reduce subroutine" + end function + +#if HAVE_PROCEDURAL_ACTUAL_FOR_POINTER_DUMMY + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_co_reduce_test_t) prif_co_reduce_test + + test_results = prif_co_reduce_test%run([ & + test_description_t("performing a logical .and. reduction", check_logical) & + ,test_description_t("performing a derived type reduction", check_derived_type_reduction) & +#if HAVE_PARAM_DERIVED + ,test_description_t("performing a parameterized derived type reduction", check_type_parameter_reduction) & +#endif + ]) + end function + +#else + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_co_reduce_test_t) prif_co_reduce_test + procedure(diagnosis_function_i), pointer :: & + check_logical_ptr => check_logical & + ,check_derived_type_reduction_ptr => check_derived_type_reduction +#if HAVE_PARAM_DERIVED + procedure(diagnosis_function_i), pointer :: check_type_parameter_reduction_ptr => check_type_parameter_reduction +#endif - tests = describe( & - "The prif_co_reduce subroutine", & - [ it("can be used to implement logical and reduction", check_logical) & - , it("can be used for reduction on simple derived types", check_derived_type_reduction) & + test_results = prif_co_reduce_test%run([ & + test_description_t("performing a logical .and. reduction", check_logical_ptr) & + ,test_description_t("performing a derived type reduction", check_derived_type_reduction_ptr) & #if HAVE_PARAM_DERIVED - , it("can be used for reduction on derived types with length type parameters", check_type_parameter_reduction) & + ,test_description_t("performing a parameterized derived type reduction", check_type_parameter_reduction_ptr) & #endif ]) end function - function check_logical() result(result_) - type(result_t) :: result_ + +#endif + + + function check_logical() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis logical :: val integer :: me procedure(prif_operation_wrapper_interface), pointer :: op @@ -48,14 +101,14 @@ function check_logical() result(result_) val = .true. call prif_co_reduce(val, op, c_null_ptr) - result_ = assert_that(val) + test_diagnosis = .expect. val call prif_this_image_no_coarray(this_image=me) if (me == 1) then val = .false. end if call prif_co_reduce(val, op, c_null_ptr) - result_ = result_.and.assert_not(val) + test_diagnosis = test_diagnosis .also. (.expect. (.not. val)) end function subroutine and_wrapper(arg1, arg2_and_out, count, cdata) bind(C) @@ -74,8 +127,8 @@ subroutine and_wrapper(arg1, arg2_and_out, count, cdata) bind(C) end do end subroutine - function check_derived_type_reduction() result(result_) - type(result_t) :: result_ + function check_derived_type_reduction() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis type(pair), parameter :: values(*,*) = reshape( & [ pair(1, 53.), pair(3, 47.) & , pair(5, 43.), pair(7, 41.) & @@ -87,6 +140,7 @@ function check_derived_type_reduction() result(result_) type(pair), dimension(size(values,1)) :: my_val, expected type(pair), dimension(:,:), allocatable :: tmp procedure(prif_operation_wrapper_interface), pointer :: op + double precision, parameter :: tolerance = 0D0 op => pair_adder call prif_this_image_no_coarray(this_image=me) @@ -111,9 +165,8 @@ function check_derived_type_reduction() result(result_) #else expected = reduce(tmp, add_pair, dim=2) #endif - result_ = & - assert_equals(expected%fst, my_val%fst) & - .and. assert_equals(real(expected%snd, kind=kind(0.d0)), real(my_val%snd, kind=kind(0.d0))) + test_diagnosis = .all. (my_val%fst .equalsExpected. expected%fst) & + .also. (.all. ( real(my_val%snd, kind=kind(0.d0)) .approximates. real(expected%snd, kind=kind(0.d0)) .within. tolerance)) end function pure function add_pair(lhs, rhs) result(total) @@ -148,8 +201,8 @@ subroutine pair_adder(arg1, arg2_and_out, count, cdata) bind(C) ! Gfortran 14.2 also lacks the type support for this test: ! Error: Derived type 'pdtarray' at (1) is being used before it is defined - function check_type_parameter_reduction() result(result_) - type(result_t) :: result_ + function check_type_parameter_reduction() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis type(array), parameter :: values(*,*) = reshape( & [ array(elements=[1, 53]), array(elements=[3, 47]) & , array(elements=[5, 43]), array(elements=[7, 41]) & @@ -172,9 +225,7 @@ function check_type_parameter_reduction() result(result_) call prif_co_reduce(my_val, op, c_loc(context)) expected = reduce(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), add_array, dim=2) - do i = 1, size(expected) - result_ = result_.and.assert_equals(expected(i)%elements, my_val(i)%elements) - end do + test_diagnosis = .all. (my_val%elements .equalsExpected. expected%elements) end function pure function add_array(lhs, rhs) result(total) @@ -216,4 +267,4 @@ pure function op_interface(lhs, rhs) result(res) end subroutine #endif /* HAVE_PARAM_DERIVED */ -end module caf_co_reduce_test +end module prif_co_reduce_test_m diff --git a/test/prif_co_sum_test.F90 b/test/prif_co_sum_test.F90 index 665b36e41..1fb52fd5e 100644 --- a/test/prif_co_sum_test.F90 +++ b/test/prif_co_sum_test.F90 @@ -1,197 +1,262 @@ -module caf_co_sum_test +#include "language-support.F90" + +module prif_co_sum_test_m use iso_c_binding, only: c_int8_t, c_int16_t, c_int32_t, c_int64_t, c_float, c_double use prif, only : prif_co_sum, prif_num_images, prif_this_image_no_coarray - use veggies, only: result_t, test_item_t, assert_equals, describe, it, succeed + use julienne_m, only: & + operator(.all.) & + ,operator(.also.) & + ,operator(.approximates.) & + ,operator(.equalsExpected.) & + ,operator(.within.) & + ,test_description_t & + ,test_diagnosis_t & + ,test_result_t & + ,test_t +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : diagnosis_function_i +#endif implicit none private - public :: test_prif_co_sum - -contains - function test_prif_co_sum() result(tests) - type(test_item_t) tests - - tests = describe( & - "The prif_co_sum subroutine computes the sum across images for corresponding elements for", & - [ it("a 1D default integer array", check_default_integer) & - , it("a 1D 8-bit integer array", check_8_bit_integer) & - , it("a 1D 16-bit integer array", check_16_bit_integer) & - , it("32-bit integer scalars", check_32_bit_integer) & - , it("a 1D 64-bit integer array", check_64_bit_integer) & - , it("a 2D 32-bit real array", check_32_bit_real) & - , it("a 1D 64-bit real array", check_64_bit_real) & - , it("a 2D complex array with 32-bit components", check_32_bit_complex) & - , it("a 1D complex array with 64-bit components", check_64_bit_complex) & - ]) - end function - - function check_default_integer() result(result_) - type(result_t) :: result_ - - integer, parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) - integer :: me, ni, i - integer, dimension(size(values,1)) :: my_val, expected - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) - - my_val = values(:, mod(me-1, size(values,2))+1) - call prif_co_sum(my_val) + public :: prif_co_sum_test_t - expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(int(expected), int(my_val)) - end function + type, extends(test_t) :: prif_co_sum_test_t + contains + procedure, nopass, non_overridable :: subject + procedure, nopass, non_overridable :: results + end type - function check_8_bit_integer() result(result_) - type(result_t) :: result_ - - integer(c_int8_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int8_t), [2, 4]) - integer :: me, ni, i - integer(c_int8_t), dimension(size(values,1)) :: my_val, expected - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) - - my_val = values(:, mod(me-1, size(values,2))+1) - call prif_co_sum(my_val) - - expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(int(expected), int(my_val)) - end function - - function check_16_bit_integer() result(result_) - type(result_t) :: result_ - - integer(c_int16_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int16_t), [2, 4]) - integer :: me, ni, i - integer(c_int16_t), dimension(size(values,1)) :: my_val, expected +contains - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = "The prif_co_sum subroutine" + end function + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_co_sum_test_t) prif_co_sum_test + + test_results = prif_co_sum_test%run([ & + test_description_t("computing the element-wise sum of a 1D default integer array", check_default_integer) & + ,test_description_t("computing the element-wise sum of a 1D 8-bit integer(c_int8_t) array", check_8_bit_integer) & + ,test_description_t("computing the element-wise sum of a 1D 16-bit integer(c_int16_t) array", check_16_bit_integer) & + ,test_description_t("computing the element-wise sum of integer(c_int32_t) scalars", check_32_bit_integer) & + ,test_description_t("computing the element-wise sum of a 1D 64-bit integer(c_int64_t) array", check_64_bit_integer) & + ,test_description_t("computing the element-wise sum of a 2D 32-bit real(c_float) array", check_32_bit_real) & + ,test_description_t("computing the element-wise sum of a 1D 64-bit real(c_double) array", check_64_bit_real) & + ,test_description_t("computing the element-wise sum of a 2D complex(c_float) array", check_32_bit_complex) & + ,test_description_t("computing the element-wise sum of a 1D complex(c_double) array", check_64_bit_complex) & + ]) + end function + +#else + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_co_sum_test_t) prif_co_sum_test + procedure(diagnosis_function_i), pointer :: & + check_default_integer_ptr => check_default_integer & + ,check_8_bit_integer_ptr => check_8_bit_integer & + ,check_16_bit_integer_ptr => check_16_bit_integer & + ,check_32_bit_integer_ptr => check_32_bit_integer & + ,check_64_bit_integer_ptr => check_64_bit_integer & + ,check_32_bit_real_ptr => check_32_bit_real & + ,check_64_bit_real_ptr => check_64_bit_real & + ,check_32_bit_complex_ptr => check_32_bit_complex & + ,check_64_bit_complex_ptr => check_64_bit_complex + + test_results = prif_co_sum_test%run([ & + test_description_t("computing the element-wise sum of a 1D default integer array", check_default_integer_ptr) & + ,test_description_t("computing the element-wise sum of a 1D 8-bit integer(c_int8_t) array", check_8_bit_integer_ptr) & + ,test_description_t("computing the element-wise sum of a 1D 16-bit integer(c_int16_t) array", check_16_bit_integer_ptr) & + ,test_description_t("computing the element-wise sum of integer(c_int32_t) scalars", check_32_bit_integer_ptr) & + ,test_description_t("computing the element-wise sum of a 1D 64-bit integer(c_int64_t) array", check_64_bit_integer_ptr) & + ,test_description_t("computing the element-wise sum of a 2D 32-bit real(c_float) array", check_32_bit_real_ptr) & + ,test_description_t("computing the element-wise sum of a 1D 64-bit real(c_double) array", check_64_bit_real_ptr) & + ,test_description_t("computing the element-wise sum of a 2D complex(c_float) array", check_32_bit_complex_ptr) & + ,test_description_t("computing the element-wise sum of a 1D complex(c_double) array", check_64_bit_complex_ptr) & + ]) + end function + +#endif + + function check_default_integer() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis - my_val = values(:, mod(me-1, size(values,2))+1) - call prif_co_sum(my_val) + integer, parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) + integer :: me, ni, i + integer, dimension(size(values,1)) :: my_val, expected - expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(int(expected), int(my_val)) - end function + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) + + my_val = values(:, mod(me-1, size(values,2))+1) + call prif_co_sum(my_val) + + expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) + test_diagnosis = .all. (int(my_val) .equalsExpected. int(expected)) + end function - function check_32_bit_integer() result(result_) - type(result_t) :: result_ + function check_8_bit_integer() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + + integer(c_int8_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int8_t), [2, 4]) + integer :: me, ni, i + integer(c_int8_t), dimension(size(values,1)) :: my_val, expected - integer(c_int32_t), parameter :: values(*) = [1, -19, 5, 13, 11, 7, 17, 3] - integer :: me, ni, i - integer(c_int32_t) :: my_val, expected + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) + my_val = values(:, mod(me-1, size(values,2))+1) + call prif_co_sum(my_val) + + expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) + test_diagnosis = .all. (int(my_val) .equalsExpected. int(expected)) + end function + + function check_16_bit_integer() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + + integer(c_int16_t), parameter :: values(*,*) = reshape(int([1, -19, 5, 13, 11, 7, 17, 3],c_int16_t), [2, 4]) + integer :: me, ni, i + integer(c_int16_t), dimension(size(values,1)) :: my_val, expected + + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) + + my_val = values(:, mod(me-1, size(values,2))+1) + call prif_co_sum(my_val) + + expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) + test_diagnosis = .all. (int(my_val) .equalsExpected. int(expected)) + end function + + function check_32_bit_integer() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + + integer(c_int32_t), parameter :: values(*) = [1, -19, 5, 13, 11, 7, 17, 3] + integer :: me, ni, i + integer(c_int32_t) :: my_val, expected + + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) + + my_val = values(mod(me-1, size(values))+1) + call prif_co_sum(my_val) + + expected = sum([(values(mod(i-1,size(values))+1), i = 1, ni)]) + test_diagnosis = int(my_val) .equalsExpected. int(expected) + end function - my_val = values(mod(me-1, size(values))+1) - call prif_co_sum(my_val) + function check_64_bit_integer() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis - expected = sum([(values(mod(i-1,size(values))+1), i = 1, ni)]) - result_ = assert_equals(expected, my_val) - end function + integer(c_int64_t), parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) + integer :: me, ni, i + integer(c_int64_t), dimension(size(values,1)) :: my_val, expected - function check_64_bit_integer() result(result_) - type(result_t) :: result_ + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) - integer(c_int64_t), parameter :: values(*,*) = reshape([1, -19, 5, 13, 11, 7, 17, 3], [2, 4]) - integer :: me, ni, i - integer(c_int64_t), dimension(size(values,1)) :: my_val, expected + my_val = values(:, mod(me-1, size(values,2))+1) + call prif_co_sum(my_val) - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) + expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) + test_diagnosis = .all. (int(my_val) .equalsExpected. int(expected)) + end function - my_val = values(:, mod(me-1, size(values,2))+1) - call prif_co_sum(my_val) + function check_32_bit_real() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis - expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(int(expected), int(my_val)) - end function + real(c_float), parameter :: values(*,*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2,2,2]) + real(c_float), parameter :: tolerance = 0_c_float + integer :: me, ni, i + real(c_float), dimension(size(values,1), size(values,2)) :: my_val, expected - function check_32_bit_real() result(result_) - type(result_t) :: result_ + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) - real(c_float), parameter :: values(*,*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2,2,2]) - integer :: me, ni, i - real(c_float), dimension(size(values,1), size(values,2)) :: my_val, expected + my_val = values(:, :, mod(me-1, size(values,3))+1) + call prif_co_sum(my_val) - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) + expected = sum(reshape([(values(:,:,mod(i-1,size(values,3))+1), i = 1, ni)], [size(values,1), size(values,2), ni]), dim=3) + test_diagnosis = .all. (my_val .approximates. expected .within. tolerance) + end function - my_val = values(:, :, mod(me-1, size(values,3))+1) - call prif_co_sum(my_val) + function check_64_bit_real() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis - expected = sum(reshape([(values(:,:,mod(i-1,size(values,3))+1), i = 1, ni)], [size(values,1), size(values,2), ni]), dim=3) - result_ = assert_equals(real(expected,kind=c_double), real(my_val,kind=c_double)) - end function + real(c_double), parameter :: values(*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2, 4]) + real(c_double), parameter :: tolerance = 0_c_double + integer :: me, ni, i + real(c_double), dimension(size(values,1)) :: my_val, expected - function check_64_bit_real() result(result_) - type(result_t) :: result_ + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) - real(c_double), parameter :: values(*,*) = reshape([1, 19, 5, 13, 11, 7, 17, 3], [2, 4]) - integer :: me, ni, i - real(c_double), dimension(size(values,1)) :: my_val, expected + my_val = values(:, mod(me-1, size(values,2))+1) + call prif_co_sum(my_val) - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) + expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) + test_diagnosis = .all. (my_val .approximates. expected .within. tolerance) + end function - my_val = values(:, mod(me-1, size(values,2))+1) - call prif_co_sum(my_val) + function check_32_bit_complex() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis - expected = sum(reshape([(values(:, mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1),ni]), dim=2) - result_ = assert_equals(expected, my_val) - end function + complex(c_float), parameter :: values(*,*,*) = reshape( & + [ cmplx(1., 53.), cmplx(3., 47.) & + , cmplx(5., 43.), cmplx(7., 41.) & + , cmplx(11., 37.), cmplx(13., 31.) & + , cmplx(17., 29.), cmplx(19., 23.) & + ], & + [2,2,2]) + real(c_float), parameter :: tolerance = 0_c_float + integer :: me, ni, i + complex(c_float), dimension(size(values,1),size(values,2)) :: my_val, expected - function check_32_bit_complex() result(result_) - type(result_t) :: result_ + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) - complex(c_float), parameter :: values(*,*,*) = reshape( & - [ cmplx(1., 53.), cmplx(3., 47.) & - , cmplx(5., 43.), cmplx(7., 41.) & - , cmplx(11., 37.), cmplx(13., 31.) & - , cmplx(17., 29.), cmplx(19., 23.) & - ], & - [2,2,2]) - integer :: me, ni, i - complex(c_float), dimension(size(values,1),size(values,2)) :: my_val, expected + my_val = values(:, :, mod(me-1, size(values,3))+1) + call prif_co_sum(my_val) - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) + expected = sum(reshape([(values(:,:,mod(i-1,size(values,3))+1), i = 1, ni)], [size(values,1), size(values,2), ni]), dim=3) - my_val = values(:, :, mod(me-1, size(values,3))+1) - call prif_co_sum(my_val) + test_diagnosis = & + .all. (real(my_val) .approximates. real(expected) .within. tolerance) & + .also. (.all. (aimag(my_val) .approximates. aimag(expected) .within. tolerance)) + end function - expected = sum(reshape([(values(:,:,mod(i-1,size(values,3))+1), i = 1, ni)], [size(values,1), size(values,2), ni]), dim=3) - result_ = & - assert_equals(real(expected, kind=c_double), real(my_val, kind=c_double)) & - .and.assert_equals(real(aimag(expected), kind=c_double), real(aimag(my_val), kind=c_double)) - end function + function check_64_bit_complex() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis - function check_64_bit_complex() result(result_) - type(result_t) :: result_ + complex(c_double), parameter :: values(*,*) = reshape( & + [ cmplx(1., 53.), cmplx(3., 47.) & + , cmplx(5., 43.), cmplx(7., 41.) & + , cmplx(11., 37.), cmplx(13., 31.) & + , cmplx(17., 29.), cmplx(19., 23.) & + ], & + [2,4]) + real(c_double), parameter :: tolerance = 0_c_double + integer me, ni, i + complex(c_double), dimension(size(values,1)) :: my_val, expected - complex(c_double), parameter :: values(*,*) = reshape( & - [ cmplx(1., 53.), cmplx(3., 47.) & - , cmplx(5., 43.), cmplx(7., 41.) & - , cmplx(11., 37.), cmplx(13., 31.) & - , cmplx(17., 29.), cmplx(19., 23.) & - ], & - [2,4]) - integer :: me, ni, i - complex(c_double), dimension(size(values,1)) :: my_val, expected + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(ni) - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(ni) + my_val = values(:, mod(me-1, size(values,2))+1) + call prif_co_sum(my_val) - my_val = values(:, mod(me-1, size(values,2))+1) - call prif_co_sum(my_val) + expected = sum(reshape([(values(:,mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1), ni]), dim=2) - expected = sum(reshape([(values(:,mod(i-1,size(values,2))+1), i = 1, ni)], [size(values,1), ni]), dim=2) - result_ = & - assert_equals(real(expected), real(my_val)) & - .and.assert_equals(aimag(expected), aimag(my_val)) - end function + test_diagnosis = & + .all. (real(my_val, c_double) .approximates. real(expected, c_double) .within. tolerance) & + .also. (.all. (real(aimag(my_val), c_double) .approximates. real(aimag(expected), c_double) .within. tolerance)) + end function -end module caf_co_sum_test +end module prif_co_sum_test_m diff --git a/test/prif_coarray_inquiry_test.F90 b/test/prif_coarray_inquiry_test.F90 index f2e1298dd..097430a8e 100644 --- a/test/prif_coarray_inquiry_test.F90 +++ b/test/prif_coarray_inquiry_test.F90 @@ -1,135 +1,159 @@ -module caf_coarray_inquiry_test - use prif, only : & - prif_allocate_coarray, prif_deallocate_coarray, & - prif_coarray_handle, prif_num_images, & - prif_local_data_pointer, prif_size_bytes, & - prif_lcobound_no_dim, prif_lcobound_with_dim, & - prif_ucobound_no_dim, prif_ucobound_with_dim, & - prif_coshape - use veggies, only: result_t, test_item_t, assert_that, describe, it, succeed - use iso_c_binding, only: & - c_ptr, c_null_ptr, c_int64_t, c_int, c_size_t, c_null_funptr, c_associated - - implicit none - private - public :: test_coarray_inquiry +#include "language-support.F90" + +module prif_coarray_inquiry_test_m + use prif, only : & + prif_allocate_coarray, prif_deallocate_coarray, & + prif_coarray_handle, prif_num_images, & + prif_local_data_pointer, prif_size_bytes, & + prif_lcobound_no_dim, prif_lcobound_with_dim, & + prif_ucobound_no_dim, prif_ucobound_with_dim, & + prif_coshape + use julienne_m, only: & + operator(//) & + ,operator(.all.) & + ,operator(.also.) & + ,operator(.equalsExpected.) & + ,operator(.expect.) & + ,test_description_t & + ,test_diagnosis_t & + ,test_result_t & + ,test_t +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only : diagnosis_function_i +#endif + use iso_c_binding, only: & + c_ptr, c_null_ptr, c_int64_t, c_int, c_size_t, c_null_funptr, c_associated + + implicit none + private + public :: prif_coarray_inquiry_test_t + + type, extends(test_t) :: prif_coarray_inquiry_test_t + contains + procedure, nopass, non_overridable :: subject + procedure, nopass, non_overridable :: results + end type + contains - function test_coarray_inquiry() result(tests) - type(test_item_t) :: tests - - tests = & - describe( & - "PRIF coarray inquiry functions", & - [ describe( & - "prif_local_data_pointer", & - [ it( & - "returns the same pointer as when the coarray was allocated", & - check_prif_local_data_pointer) & - ]), & - describe( & - "PRIF coarrays", & - [ it("pass cobounds testing", check_cobounds) ]) & - ]) - end function - - function check_prif_local_data_pointer() result(result_) - type(result_t) :: result_ - - integer(kind=c_int64_t), dimension(1) :: lcobounds, ucobounds - integer :: dummy_element, num_imgs - type(prif_coarray_handle) :: coarray_handle - type(c_ptr) :: allocation_ptr, local_ptr - - call prif_num_images(num_images=num_imgs) - lcobounds(1) = 1 - ucobounds(1) = num_imgs - - call prif_allocate_coarray( & - lcobounds, & - ucobounds, & - int(storage_size(dummy_element)/8, c_size_t), & - c_null_funptr, & - coarray_handle, & - allocation_ptr) - call prif_local_data_pointer(coarray_handle, local_ptr) - result_ = assert_that(c_associated(local_ptr, allocation_ptr)) - call prif_deallocate_coarray([coarray_handle]) - end function - - function check_cobound(corank) result(result_) - type(result_t) :: result_ - integer(c_int), intent(in) :: corank - - ! Allocate memory for an integer scalar coarray with given corank - ! and then test some queries on it - - integer :: num_imgs, i - integer(kind=c_int64_t), dimension(corank) :: lcobounds, ucobounds, tmp_bounds - integer(kind=c_int64_t) :: tmp_bound - integer(kind=c_size_t), dimension(corank) :: sizes + + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = "The PRIF coarray inquiry subroutines" + end function + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_coarray_inquiry_test_t) prif_coarray_inquiry_test + + test_results = prif_coarray_inquiry_test%run([ & + test_description_t("preserving the prif_local_data_pointer for an allocated coarray", check_prif_local_data_pointer) & + ,test_description_t("checking passed cobounds", check_cobounds) & + ]) + end function + +#else + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_coarray_inquiry_test_t) prif_coarray_inquiry_test + procedure(diagnosis_function_i), pointer :: & + check_prif_local_data_pointer_ptr => check_prif_local_data_pointer & + ,check_cobounds_ptr => check_cobounds + + test_results = prif_coarray_inquiry_test%run([ & + test_description_t("preserving the prif_local_data_pointer for an allocated coarray", check_prif_local_data_pointer_ptr) & + ,test_description_t("checking passed cobounds", check_cobounds_ptr) & + ]) + end function + +#endif + + function check_prif_local_data_pointer() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + + integer(kind=c_int64_t), dimension(1) :: lcobounds, ucobounds + integer :: dummy_element, num_imgs type(prif_coarray_handle) :: coarray_handle - type(c_ptr) :: allocated_memory - integer(c_size_t) :: data_size, query_size - - result_ = succeed("") - + type(c_ptr) :: allocation_ptr, local_ptr + call prif_num_images(num_images=num_imgs) lcobounds(1) = 1 ucobounds(1) = num_imgs - do i = 2,corank - lcobounds(i) = i - ucobounds(i) = i*2 - end do - - allocated_memory = c_null_ptr - data_size = 64 * corank - + call prif_allocate_coarray( & - lcobounds, ucobounds, data_size, c_null_funptr, & - coarray_handle, allocated_memory) - - result_ = result_ .and. & - assert_that(c_associated(allocated_memory)) - - call prif_size_bytes(coarray_handle, data_size=query_size) - result_ = result_ .and. & - assert_that(query_size == data_size, "prif_size_bytes is valid") - - call prif_lcobound_no_dim(coarray_handle, tmp_bounds) - result_ = result_ .and. & - assert_that(all(tmp_bounds == lcobounds), "prif_lcobound_no_dim is valid") - - call prif_ucobound_no_dim(coarray_handle, tmp_bounds) - result_ = result_ .and. & - assert_that(all(tmp_bounds == ucobounds), "prif_ucobound_no_dim is valid") - - do i = 1,corank - call prif_lcobound_with_dim(coarray_handle, i, tmp_bound) - result_ = result_ .and. & - assert_that(tmp_bound == lcobounds(i), "prif_lcobound_with_dim is valid") - - call prif_ucobound_with_dim(coarray_handle, i, tmp_bound) - result_ = result_ .and. & - assert_that(tmp_bound == ucobounds(i), "prif_ucobound_with_dim is valid") - end do - - call prif_coshape(coarray_handle, sizes) - result_ = result_ .and. & - assert_that(all(sizes == (ucobounds - lcobounds + 1)), "prif_coshape is valid") - + lcobounds, & + ucobounds, & + int(storage_size(dummy_element)/8, c_size_t), & + c_null_funptr, & + coarray_handle, & + allocation_ptr) + call prif_local_data_pointer(coarray_handle, local_ptr) + test_diagnosis = .expect. c_associated(local_ptr, allocation_ptr) call prif_deallocate_coarray([coarray_handle]) - end function - - function check_cobounds() result(result_) - type(result_t) :: result_ - integer(c_int) :: corank - - result_ = succeed("") - - do corank = 1, 15 - result_ = result_ .and. check_cobound(corank) - end do - - end function - -end module + end function + + impure elemental function check_cobound(corank) result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + integer(c_int), intent(in) :: corank + + ! Allocate memory for an integer scalar coarray with given corank + ! and then test some queries on it + + integer :: num_imgs, i + integer(kind=c_int64_t), dimension(corank) :: lcobounds, ucobounds, tmp_bounds + integer(kind=c_int64_t) :: tmp_bound + integer(kind=c_size_t), dimension(corank) :: sizes + type(prif_coarray_handle) :: coarray_handle + type(c_ptr) :: allocated_memory + integer(c_size_t) :: data_size, query_size + + call prif_num_images(num_images=num_imgs) + lcobounds(1) = 1 + ucobounds(1) = num_imgs + do i = 2,corank + lcobounds(i) = i + ucobounds(i) = i*2 + end do + + allocated_memory = c_null_ptr + data_size = 64 * corank + + call prif_allocate_coarray( & + lcobounds, ucobounds, data_size, c_null_funptr, & + coarray_handle, allocated_memory) + + test_diagnosis = .expect. c_associated(allocated_memory) + + call prif_size_bytes(coarray_handle, data_size=query_size) + test_diagnosis = test_diagnosis .also. (query_size .equalsExpected. data_size) // "prif_size_bytes is valid" + + call prif_lcobound_no_dim(coarray_handle, tmp_bounds) + test_diagnosis = test_diagnosis .also. (.all. (tmp_bounds .equalsExpected. lcobounds)) // "prif_lcobound_no_dim is valid" + + call prif_ucobound_no_dim(coarray_handle, tmp_bounds) + test_diagnosis = test_diagnosis .also. (.all. (tmp_bounds .equalsExpected. ucobounds)) // "prif_ucobound_no_dim is valid" + + do i = 1, corank + call prif_lcobound_with_dim(coarray_handle, i, tmp_bound) + test_diagnosis = test_diagnosis .also. (tmp_bound .equalsExpected. lcobounds(i)) // "prif_lcobound_with_dim is valid" + + call prif_ucobound_with_dim(coarray_handle, i, tmp_bound) + test_diagnosis = test_diagnosis .also. (tmp_bound .equalsExpected. ucobounds(i)) // "prif_ucobound_with_dim is valid" + end do + + call prif_coshape(coarray_handle, sizes) + test_diagnosis = test_diagnosis .also. (.all. ((ucobounds - lcobounds + 1) .equalsExpected. sizes)) // "prif_coshape is valid" + + call prif_deallocate_coarray([coarray_handle]) + end function + + function check_cobounds() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + integer(c_int) :: corank + + test_diagnosis = .all. check_cobound([(corank, corank = 1_c_int, 15_c_int)]) + end function + +end module prif_coarray_inquiry_test_m diff --git a/test/prif_image_queries_test.F90 b/test/prif_image_queries_test.F90 index d416131ad..382f3c023 100644 --- a/test/prif_image_queries_test.F90 +++ b/test/prif_image_queries_test.F90 @@ -1,61 +1,111 @@ -module caf_image_queries_test +#include "language-support.F90" + +module prif_image_queries_test_m use iso_c_binding, only: c_int use prif, only : prif_image_status, prif_stopped_images, prif_failed_images, PRIF_STAT_FAILED_IMAGE, PRIF_STAT_STOPPED_IMAGE use prif, only : prif_num_images - use veggies, only: result_t, test_item_t, assert_that, describe, it, succeed + use julienne_m, only: & + operator(//) & + ,operator(.all.) & + ,operator(.also.) & + ,operator(.isAtLeast.) & + ,operator(.isAtMost.) & + ,operator(.lessThan.) & + ,operator(.expect.) & + ,test_description_t & + ,test_diagnosis_t & + ,test_result_t & + ,test_t +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only: diagnosis_function_i +#endif implicit none private - public :: test_prif_image_queries + public :: prif_image_queries_test_t + + type, extends(test_t) :: prif_image_queries_test_t + contains + procedure, nopass, non_overridable :: subject + procedure, nopass, non_overridable :: results + end type contains - function test_prif_image_queries() result(tests) - type(test_item_t) :: tests - - tests = describe( & - "PRIF image queries", [ & - it("provide valid prif_image_status()", check_image_status), & - it("provide valid prif_stopped_images()", check_stopped_images), & - it("provide valid prif_failed_images()", check_failed_images) & - ]) - end function - - function check_image_status() result(result_) - type(result_t) :: result_ - integer(c_int) :: image_status - - call prif_image_status(1, image_status=image_status) - result_ = assert_that(image_status == 0 .or. & - image_status == PRIF_STAT_FAILED_IMAGE .or. & - image_status == PRIF_STAT_STOPPED_IMAGE, "permitted image status") - end function - - function valid_image_list(nums) result(result_) - integer, allocatable, intent(in) :: nums(:) - type(result_t) :: result_ - integer i, ni - - call prif_num_images(num_images=ni) - result_ = assert_that( allocated(nums) .and. size(nums) <= ni .and. & - all([(nums(i) >= 1 .and. nums(i) <= ni, i = 1, size(nums))]) .and. & - all([(nums(i) < nums(i+1), i = 1, size(nums)-1)]), & - "valid stopped images") - end function - - function check_stopped_images() result(result_) - type(result_t) :: result_ - integer, allocatable :: nums(:) - - call prif_stopped_images(stopped_images=nums) - result_ = valid_image_list(nums) - end function - - function check_failed_images() result(result_) - type(result_t) :: result_ - integer, allocatable :: nums(:) - - call prif_failed_images(failed_images=nums) - result_ = valid_image_list(nums) - end function - -end module caf_image_queries_test + + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = "PRIF image queries" + end function + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_image_queries_test_t) prif_image_queries_test + + test_results = prif_image_queries_test%run([ & + test_description_t("providing valid prif_image_status()", check_image_status) & + ,test_description_t("providing valid prif_stopped_images()", check_stopped_images) & + ,test_description_t("providing valid prif_failed_images()", check_failed_images) & + ]) + end function + +#else + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_image_queries_test_t) prif_image_queries_test + procedure(diagnosis_function_i), pointer :: & + check_image_status_ptr => check_image_status & + ,check_stopped_images_ptr => check_stopped_images & + ,check_failed_images_ptr => check_failed_images + + test_results = prif_image_queries_test%run([ & + test_description_t("providing valid prif_image_status()", check_image_status_ptr) & + ,test_description_t("providing valid prif_stopped_images()", check_stopped_images_ptr) & + ,test_description_t("providing valid prif_failed_images()", check_failed_images_ptr) & + ]) + end function + +#endif + + function check_image_status() result(test_diagnosis) + type(test_diagnosis_t) :: test_diagnosis + integer(c_int) :: image_status + + call prif_image_status(1, image_status=image_status) + test_diagnosis = .expect. (any(image_status == [0, PRIF_STAT_FAILED_IMAGE, PRIF_STAT_STOPPED_IMAGE])) & ! TODO: replace with .any. once Juliennes supports it + // "permitted image status" + end function + + function valid_image_list(nums) result(test_diagnosis) + integer, allocatable, intent(in) :: nums(:) + type(test_diagnosis_t) test_diagnosis + integer ni + + call prif_num_images(num_images=ni) + test_diagnosis = & + .expect. allocated(nums) & + .also. (size(nums) .isAtMost. ni) & + .also. (.all. (nums .isAtLeast. 1)) & + .also. (.all. (nums .isAtMost. ni)) & + .also. (.all. (nums(1:size(nums)-1) .lessThan. nums(2:size(nums)))) // "valid stopped image" + end function + + function check_stopped_images() result(test_diagnosis) + type(test_diagnosis_t) :: test_diagnosis + integer, allocatable :: nums(:) + + call prif_stopped_images(stopped_images=nums) + test_diagnosis = valid_image_list(nums) + end function + + function check_failed_images() result(test_diagnosis) + type(test_diagnosis_t) :: test_diagnosis + integer, allocatable :: nums(:) + + call prif_failed_images(failed_images=nums) + test_diagnosis = valid_image_list(nums) + end function + +end module prif_image_queries_test_m diff --git a/test/prif_init_test.F90 b/test/prif_init_test.F90 new file mode 100644 index 000000000..5933279fd --- /dev/null +++ b/test/prif_init_test.F90 @@ -0,0 +1,86 @@ +#include "language-support.F90" + +module prif_init_test_m + use prif, only : prif_init, PRIF_STAT_ALREADY_INIT + use julienne_m, only: test_description_t, test_diagnosis_t, test_result_t, test_t, operator(.equalsExpected.) +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only: diagnosis_function_i +#endif + + implicit none + private + public :: prif_init_test_t + + type, extends(test_t) :: prif_init_test_t + contains + procedure, nopass, non_overridable :: subject + procedure, nopass, non_overridable :: results + end type + +contains + + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = "The prif_init subroutine" + end function + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_init_test_t) prif_init_test + + test_results = prif_init_test%run([ & + test_description_t("completing successfully", check_caffeination) & + ,test_description_t("returning PRIF_STAT_ALREADY_INIT on a subsequent call ", check_subsequent_prif_init_call) & + ]) + end function + +#else + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_init_test_t) prif_init_test + procedure(diagnosis_function_i), pointer :: & + check_caffeination_ptr => check_caffeination & + ,check_subsequent_prif_init_call_ptr => check_subsequent_prif_init_call + + test_results = prif_init_test%run([ & + test_description_t("completing successfully", check_caffeination_ptr) & + ,test_description_t("returning PRIF_STAT_ALREADY_INIT on a subsequent call ", check_subsequent_prif_init_call_ptr) & + ]) + end function + +#endif + + function check_caffeination() result(test_diagnosis) + ! this test needs to run very early at startup, so we memoize the result + type(test_diagnosis_t) :: test_diagnosis + type(test_diagnosis_t), save :: memo + logical, save :: first_pass = .true. + + if (first_pass) then + first_pass = .false. + write_memo: & + block + integer, parameter :: successful_initiation = 0 + integer init_exit_code + + call prif_init(init_exit_code) + memo = init_exit_code .equalsExpected. successful_initiation + end block write_memo + endif + + test_diagnosis = memo + end function + + function check_subsequent_prif_init_call() result(test_diagnosis) + type(test_diagnosis_t) :: test_diagnosis + integer stat + + call prif_init(stat) + call prif_init(stat) + test_diagnosis = stat .equalsExpected. PRIF_STAT_ALREADY_INIT + end function + +end module prif_init_test_m diff --git a/test/prif_num_images_test.F90 b/test/prif_num_images_test.F90 index 4640a15a7..c62856a07 100644 --- a/test/prif_num_images_test.F90 +++ b/test/prif_num_images_test.F90 @@ -1,27 +1,66 @@ -module caf_num_images_test +#include "language-support.F90" + +module prif_num_images_test_m use prif, only : prif_num_images - use veggies, only: result_t, test_item_t, assert_that, describe, it + use julienne_m, only: & + operator(//) & + ,operator(.isAtLeast.) & + ,test_description_t & + ,test_diagnosis_t & + ,test_result_t & + ,test_t +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only: diagnosis_function_i +#endif implicit none private - public :: test_prif_num_images + public :: prif_num_images_test_t + + type, extends(test_t) :: prif_num_images_test_t + contains + procedure, nopass, non_overridable :: subject + procedure, nopass, non_overridable :: results + end type contains - function test_prif_num_images() result(tests) - type(test_item_t) :: tests - tests = & - describe( & - "The prif_num_images function result", & - [ it("is a valid number of images when invoked with no arguments", check_num_images_valid) & + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = "The prif_num_images function" + end function + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_num_images_test_t) prif_num_images_test + + test_results = prif_num_images_test%run([ & + test_description_t("returning a valid number of images when invoked with no arguments", check_num_images_valid) & ]) end function - function check_num_images_valid() result(result_) - type(result_t) :: result_ - integer :: num_imgs +#else + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_num_images_test_t) prif_num_images_test + procedure(diagnosis_function_i), pointer :: & + check_num_images_valid_ptr => check_num_images_valid + + test_results = prif_num_images_test%run([ & + test_description_t("returning a valid number of images when invoked with no arguments", check_num_images_valid_ptr) & + ]) + end function + +#endif + + function check_num_images_valid() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + integer num_imgs call prif_num_images(num_images=num_imgs) - result_ = assert_that(num_imgs>0, "positive number of images") + test_diagnosis = (num_imgs .isAtLeast. 1) // "positive number of images" end function -end module caf_num_images_test +end module prif_num_images_test_m diff --git a/test/prif_sync_images_test.F90 b/test/prif_sync_images_test.F90 index d719c8dd7..d20d8c4dd 100644 --- a/test/prif_sync_images_test.F90 +++ b/test/prif_sync_images_test.F90 @@ -1,30 +1,69 @@ -module caf_sync_images_test +#include "language-support.F90" + +module prif_sync_images_test_m use iso_c_binding, only: c_int use prif, only : prif_sync_images, prif_this_image_no_coarray, prif_num_images, prif_sync_all - use veggies, only: result_t, test_item_t, assert_that, describe, it, succeed + use julienne_m, only: test_description_t, test_diagnosis_t, test_result_t, test_t, operator(.expect.) + +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only: diagnosis_function_i +#endif implicit none private - public :: test_prif_sync_images + public :: prif_sync_images_test_t + type, extends(test_t) :: prif_sync_images_test_t + contains + procedure, nopass, non_overridable :: subject + procedure, nopass, non_overridable :: results + end type + integer, parameter :: lim = 10 contains - function test_prif_sync_images() result(tests) - type(test_item_t) :: tests - - tests = describe( & - "PRIF sync images", [ & - it("pass serial prif_sync_images test", check_serial), & - it("pass prif_sync_images neighbor test", check_neighbor), & - it("pass prif_sync_images hot-spot test", check_hot) & + + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = "The prif_sync_images subroutine" + end function + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_sync_images_test_t) prif_sync_images_test + + test_results = prif_sync_images_test%run([ & + test_description_t("synchronizing an image with itself", check_serial), & + test_description_t("synchronizing with a neighbor", check_neighbor), & + test_description_t("synchronizing every image with one image", check_hot) & ]) end function - function check_serial() result(result_) - type(result_t) :: result_ +#else + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_sync_images_test_t) prif_sync_images_test + procedure(diagnosis_function_i), pointer :: & + check_serial_ptr => check_serial & + ,check_neighbor_ptr => check_neighbor & + ,check_hot_ptr => check_hot + + test_results = prif_sync_images_test%run([ & + test_description_t("synchronizing an image with itself", check_serial_ptr), & + test_description_t("synchronizing with a neighbor", check_neighbor_ptr), & + test_description_t("synchronizing every image with one image", check_hot_ptr) & + ]) + end function + +#endif + + function check_serial() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer(c_int) :: me - integer :: i + integer i call prif_this_image_no_coarray(this_image=me) call prif_sync_all @@ -35,14 +74,14 @@ function check_serial() result(result_) end do call prif_sync_all - result_ = succeed("") + test_diagnosis = .expect. .true. end function - function check_neighbor() result(result_) - type(result_t) :: result_ - integer(c_int) :: me, num_imgs - integer :: i + function check_neighbor() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + integer(c_int) me, num_imgs + integer i call prif_this_image_no_coarray(this_image=me) call prif_num_images(num_images=num_imgs) @@ -55,11 +94,11 @@ function check_neighbor() result(result_) end do call prif_sync_all - result_ = succeed("") + test_diagnosis = .expect. .true. end function - function check_hot() result(result_) - type(result_t) :: result_ + function check_hot() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis integer(c_int) :: me, num_imgs integer :: i @@ -87,8 +126,7 @@ function check_hot() result(result_) endif call prif_sync_all - result_ = succeed("") + test_diagnosis = .expect. .true. end function - -end module +end module prif_sync_images_test_m diff --git a/test/prif_this_image_test.F90 b/test/prif_this_image_test.F90 index e6bf04ca4..44dc83617 100644 --- a/test/prif_this_image_test.F90 +++ b/test/prif_this_image_test.F90 @@ -1,33 +1,71 @@ -module caf_this_image_test - use prif, only : prif_this_image_no_coarray, prif_num_images, prif_co_sum - use veggies, only: result_t, test_item_t, assert_that, describe, it, succeed +#include "language-support.F90" - implicit none - private - public :: test_prif_this_image_no_coarray +module prif_this_image_no_coarray_test_m + use prif, only : prif_this_image_no_coarray, prif_num_images, prif_co_sum + use julienne_m, only: & + operator(//) & + ,operator(.all.) & + ,operator(.equalsExpected.) & + ,test_description_t & + ,test_diagnosis_t & + ,test_result_t & + ,test_t +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + use julienne_m, only: diagnosis_function_i +#endif + implicit none + + private + public :: prif_this_image_no_coarray_test_t + + type, extends(test_t) :: prif_this_image_no_coarray_test_t + contains + procedure, nopass, non_overridable :: subject + procedure, nopass, non_overridable :: results + end type contains - function test_prif_this_image_no_coarray() result(tests) - type(test_item_t) :: tests - - tests = describe( & - "The prif_this_image_no_coarray function result", & - [ it("is the proper member of the set {1,2,...,num_images()} when invoked as this_image()", check_this_image_set) & - ]) - end function - - function check_this_image_set() result(result_) - type(result_t) :: result_ - integer, allocatable :: image_numbers(:) - integer i, me, ni - - allocate(image_numbers(0)) - - call prif_this_image_no_coarray(this_image=me) - call prif_num_images(num_images=ni) - image_numbers = [(merge(0, me, me/=i), i = 1, ni)] - call prif_co_sum(image_numbers) - result_ = assert_that(all(image_numbers == [(i, i = 1, ni)]) .and. size(image_numbers)>0, "correct image set") - end function - -end module caf_this_image_test + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = "The prif_this_image_no_coarray subroutine" + end function + +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_this_image_no_coarray_test_t) prif_this_image_no_coarray_test + + test_results = prif_this_image_no_coarray_test%run([ & + test_description_t("returning a unique member of {1,...,num_images()} when called without arguments", check_this_image_set) & + ]) + end function + +#else + + function results() result(test_results) + type(test_result_t), allocatable :: test_results(:) + type(prif_this_image_no_coarray_test_t) prif_this_image_no_coarray_test + procedure(diagnosis_function_i), pointer :: & + check_this_image_set_ptr => check_this_image_set + + test_results = prif_this_image_no_coarray_test%run([ & + test_description_t("returning a unique member of {1,...,num_images()} when called without arguments", check_this_image_set_ptr) & + ]) + end function + +#endif + + function check_this_image_set() result(test_diagnosis) + type(test_diagnosis_t) :: test_diagnosis + integer, allocatable :: image_numbers(:) + integer i, me, ni + + call prif_this_image_no_coarray(this_image=me) + call prif_num_images(num_images=ni) + image_numbers = [(merge(0, me, me/=i), i = 1, ni)] + call prif_co_sum(image_numbers) + test_diagnosis = .all. (image_numbers .equalsExpected. [(i, i = 1, ni)]) // "correct image set" + end function + +end module prif_this_image_no_coarray_test_m