diff --git a/doc/specs/stdlib_hashmaps.md b/doc/specs/stdlib_hashmaps.md index 65dfb1351..00568b4f3 100644 --- a/doc/specs/stdlib_hashmaps.md +++ b/doc/specs/stdlib_hashmaps.md @@ -172,6 +172,10 @@ Procedures to manipulate `other_type` data: * `get( other, value )` - extracts the contents of `other` into the `class(*)` variable `value`. +* `get( other, value [, exists])` - extracts the content of + `other` into the scalar variable `value` of a kind provided by the module + `stdlib_kinds`. + * `set( other, value )` - sets the content of `other` to the `class(*)` variable `value`. @@ -458,7 +462,7 @@ in the variable `value`. or -`call [[stdlib_hashmap_wrappers:get]]( other, value )` +`call [[stdlib_hashmap_wrappers:get]]( other, value[, exists] )` ##### Class @@ -472,18 +476,39 @@ is an `intent(in)` argument. `other`: shall be a scalar expression of type `other_type`. It is an `intent(in)` argument. -`value`: if the the first argument is of `key_type` `value` shall be +`value`: if the first argument is of `key_type` `value` shall be an allocatable default character string variable, or an allocatable vector variable of type integer and kind `int8`, otherwise the first argument is of `other_type` and `value` shall be -an allocatable of `class(*)`. It is an `intent(out)` argument. +an allocatable of `class(*)`, or a scalar of type `character(*)`, +or of any type of `integer`, `real` or `complex`, or of any type of `logical`. +It is an `intent(out)` argument. -##### Example +`exists`: shall be a scalar `logical`. It can be only provided when the +first argument is of `other_type` and the second argument is a scalar of +type `character(*)`, or of any type of `integer`, `real` or `complex`, +or of any type of `logical`. It is an `intent(out)` `optional` +argument. + +#### Result + +When the first argument is of `other_type`, the second argument contains +the value of the `other_type` if both are of the same type; otherwise +the provided scalar variable is undefined. + +The `logical` `exists` is `.true.` if the provided scalar variable and +the value of the `other_type` are of the same type. Otherwise, `exists` is `.false.` +##### Examples + +###### Example 1: ```fortran {!example/hashmaps/example_hashmaps_get.f90!} ``` - +###### Example 2: +```fortran +{!example/hashmaps/example_hashmaps_get_other_scalar.f90!} +``` #### `hasher_fun`- serves as a function prototype. diff --git a/example/hashmaps/CMakeLists.txt b/example/hashmaps/CMakeLists.txt index c3962fcfb..1eafbc987 100644 --- a/example/hashmaps/CMakeLists.txt +++ b/example/hashmaps/CMakeLists.txt @@ -9,6 +9,7 @@ ADD_EXAMPLE(hashmaps_free_key) ADD_EXAMPLE(hashmaps_free_other) ADD_EXAMPLE(hashmaps_get) ADD_EXAMPLE(hashmaps_get_other_data) +ADD_EXAMPLE(hashmaps_get_other_scalar) ADD_EXAMPLE(hashmaps_hasher_fun) ADD_EXAMPLE(hashmaps_init) ADD_EXAMPLE(hashmaps_key_test) diff --git a/example/hashmaps/example_hashmaps_get_other_scalar.f90 b/example/hashmaps/example_hashmaps_get_other_scalar.f90 new file mode 100644 index 000000000..b56c0d3bb --- /dev/null +++ b/example/hashmaps/example_hashmaps_get_other_scalar.f90 @@ -0,0 +1,11 @@ +program example_hashmaps_get_other_scalar + use stdlib_hashmap_wrappers, only: & + get, other_type, set + implicit none + integer :: value, result + type(other_type) :: other + value = 15 + call set( other, value ) + call get( other, result ) + print *, 'RESULT == VALUE = ', ( result == value ) +end program example_hashmaps_get_other_scalar diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 0fb95a2d3..4ae87d330 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -14,6 +14,7 @@ set(fppFiles stdlib_hash_64bit_fnv.fypp stdlib_hash_64bit_pengy.fypp stdlib_hash_64bit_spookyv2.fypp + stdlib_hashmap_wrappers.fypp stdlib_io.fypp stdlib_io_npy.fypp stdlib_io_npy_load.fypp @@ -66,7 +67,6 @@ fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) set(SRC stdlib_array.f90 stdlib_error.f90 - stdlib_hashmap_wrappers.f90 stdlib_hashmaps.f90 stdlib_hashmap_chaining.f90 stdlib_hashmap_open.f90 diff --git a/src/stdlib_hashmap_wrappers.f90 b/src/stdlib_hashmap_wrappers.fypp similarity index 85% rename from src/stdlib_hashmap_wrappers.f90 rename to src/stdlib_hashmap_wrappers.fypp index a2a8b93d2..0fea7c96f 100755 --- a/src/stdlib_hashmap_wrappers.f90 +++ b/src/stdlib_hashmap_wrappers.fypp @@ -1,3 +1,5 @@ +#:include "common.fypp" +#:set IRLC_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES + LOG_KINDS_TYPES + CMPLX_KINDS_TYPES !! The module STDLIB_HASHMAP_WRAPPERS provides wrappers for various !! entities used by the hash map procedures. These include wrappers for the !! `key` and `other` data, and hashing procedures to operate on entities of @@ -15,7 +17,12 @@ module stdlib_hashmap_wrappers int16, & int32, & int64, & - dp + sp, & + dp, & + xdp, & + qp, & + lk, & + c_bool implicit none @@ -90,6 +97,11 @@ end function hasher_fun get_int8_key, & get_other + module procedure get_other_scalar_char + #:for k1, t1 in IRLC_KINDS_TYPES + module procedure get_other_scalar_${t1[0]}$${k1}$ + #:endfor + end interface get @@ -261,6 +273,61 @@ subroutine get_other( other, value ) end subroutine get_other + subroutine get_other_scalar_char(other, value, exists) +!! Version: Experimental +!! +!! Gets the content of the other as a scalar of a type character(*) + class(other_type), intent(in) :: other + character(len=:), allocatable, intent(out) :: value + logical, intent(out), optional :: exists + + logical :: exists_ + + exists_ = .false. + + if (.not.allocated(other % value)) then + if (present(exists)) exists = exists_ + return + end if + + select type(d => other % value) + type is ( character(*) ) + value = d + exists_ = .true. + end select + + if (present(exists)) exists = exists_ + + end subroutine + + #:for k1, t1 in IRLC_KINDS_TYPES + subroutine get_other_scalar_${t1[0]}$${k1}$(other, value, exists) +!! Version: Experimental +!! +!! Gets the content of the other as a scalar of a kind provided by stdlib_kinds + class(other_type), intent(in) :: other + ${t1}$, intent(out) :: value + logical, intent(out), optional :: exists + + logical :: exists_ + + exists_ = .false. + + if (.not.allocated(other % value)) then + if (present(exists)) exists = exists_ + return + end if + + select type(d => other % value) + type is ( ${t1}$ ) + value = d + exists_ = .true. + end select + + if (present(exists)) exists = exists_ + + end subroutine + #:endfor subroutine get_int8_key( key, value ) !! Version: Experimental diff --git a/test/hashmaps/test_maps.fypp b/test/hashmaps/test_maps.fypp index cd1e3a4ee..4940e722f 100644 --- a/test/hashmaps/test_maps.fypp +++ b/test/hashmaps/test_maps.fypp @@ -1,5 +1,146 @@ +#:include "common.fypp" #:set HASH_NAME = ["fnv_1_hasher", "fnv_1a_hasher", "seeded_nmhash32_hasher", "seeded_nmhash32x_hasher", "seeded_water_hasher"] #:set SIZE_NAME = ["16", "256"] + +#:set IR_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES + +module test_stdlib_hashmap_wrappers + use testdrive, only : new_unittest, unittest_type, error_type, check + use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64, lk + + use stdlib_hashmap_wrappers, only: other_type, set, get + + implicit none + private + + public :: collect_stdlib_wrappers + +contains + + !> Collect all exported unit tests + subroutine collect_stdlib_wrappers(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("hashmap-get-other-scalar-char", test_get_other_scalar_char) & + #:for k1, t1 in IR_KINDS_TYPES + , new_unittest("hashmap-get-other-scalar-${k1}$", test_get_other_scalar_${k1}$) & + #:endfor + #:for k1, t1 in CMPLX_KINDS_TYPES + , new_unittest("hashmap-get-other-scalar-c${k1}$", test_get_other_scalar_c${k1}$) & + #:endfor + , new_unittest("hashmap-get-other-scalar-lk", test_get_other_scalar_lk) & + ] + + end subroutine collect_stdlib_wrappers + + subroutine test_get_other_scalar_char(error) + type(error_type), allocatable, intent(out) :: error + + character(len=:), allocatable :: value_in, value_out + type(other_type) :: other + logical :: exists + + value_in = 'abcdef' + + call set ( other, value_in ) + + call get(other, value_out) + + call check(error, value_in, value_out, "get char: value_in not equal to value_out") + return + + call get(other, value_out, exists = exists) + call check(error, value_in, value_out, "get char: value_in not equal to value_out") + return + call check(error, exists, "get char: exists should be .true.") + + end subroutine + + #:for k1, t1 in IR_KINDS_TYPES + subroutine test_get_other_scalar_${k1}$(error) + type(error_type), allocatable, intent(out) :: error + + ${t1}$ :: value_in, value_out + type(other_type) :: other + logical :: exists + + value_in = 13 + + call set ( other, value_in ) + + call get(other, value_out) + + call check(error, value_in, value_out, "get ${k1}$: value_in not equal to value_out") + return + + call get(other, value_out, exists = exists) + + call check(error, value_in, value_out, "get ${k1}$: value_in not equal to value_out") + return + call check(error, exists, "get ${k1}$: exists should be .true.") + return + + end subroutine + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + subroutine test_get_other_scalar_c${k1}$(error) + type(error_type), allocatable, intent(out) :: error + + ${t1}$ :: value_in, value_out + type(other_type) :: other + logical :: exists + + value_in = (13._${k1}$, -3._${k1}$) + + call set ( other, value_in ) + + call get(other, value_out) + + call check(error, value_in, value_out, "get c${k1}$: value_in not equal to value_out") + return + + call get(other, value_out, exists = exists) + + call check(error, value_in, value_out, "get c${k1}$: value_in not equal to value_out") + return + call check(error, exists, "get c${k1}$: exists should be .true.") + return + + end subroutine + #:endfor + + + subroutine test_get_other_scalar_lk(error) + type(error_type), allocatable, intent(out) :: error + + logical(lk) :: value_in, value_out + type(other_type) :: other + logical :: exists + + value_in = .true. + + call set ( other, value_in ) + + call get(other, value_out) + + call check(error, value_in .eqv. value_out, "get lk: value_in not equal to value_out") + return + + call get(other, value_out, exists = exists) + + call check(error, value_in .eqv. value_out, "get lk: value_in not equal to value_out") + return + call check(error, exists, "get lk: exists should be .true.") + return + + end subroutine + +end module + + module test_stdlib_chaining_maps !! Test various aspects of the runtime system. !! Running this program may require increasing the stack size to above 48 MBytes @@ -354,6 +495,7 @@ program tester use testdrive, only : run_testsuite, new_testsuite, testsuite_type use test_stdlib_open_maps, only : collect_stdlib_open_maps use test_stdlib_chaining_maps, only : collect_stdlib_chaining_maps + use test_stdlib_hashmap_wrappers, only : collect_stdlib_wrappers implicit none integer :: stat, is type(testsuite_type), allocatable :: testsuites(:) @@ -364,6 +506,7 @@ program tester testsuites = [ & new_testsuite("stdlib-open-maps", collect_stdlib_open_maps) & , new_testsuite("stdlib-chaining-maps", collect_stdlib_chaining_maps) & + , new_testsuite("stdlib-hashmap-wrappers", collect_stdlib_wrappers) & ] do is = 1, size(testsuites)