WIP: Addition of a subroutine get_other_scalar in stdlib_hashmap_wrappers

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.
 

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)

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

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

src/stdlib_hashmap_wrappers.f90 → 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

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)