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_scalar( 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`. 
 
@@ -584,6 +588,60 @@ an allocatable of `class(*)`. It is an `intent(out)` argument.
     end program demo_get
 ```
 
+#### `get_other_scalar` - extracts a scalar value from a derived type
+
+##### Status
+
+Experimental
+
+##### Description
+
+Extracts a scalar value from a `other_type` and stores it in the scalar variable
+`value`.
+
+##### Syntax
+
+`call [[stdlib_hashmap_wrappers:get_other_scalar(interface)]]( other, value[, exists] )`
+
+##### Class
+
+Subroutine.
+
+##### Arguments
+
+`other`: shall be a scalar expression of type `other_type`. It
+is an `intent(in)` argument.
+
+`value`: shall be 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.
+
+`exists`: shall be a scalar `logical`. It is an `intent(out)` `optional`
+argument.
+
+#### Result
+
+The provided scalar variable contains the value of the `other_type` if both are of
+the same type; otherwise the provided scalar variable is undefined.
+
+`exists` is `.true.` if the provided scalar variable and the value of the
+`other_type` are of the same type. Otherwise, `exists` is `.false.`
+
+##### Example
+
+```fortran
+    program demo_get_other_scalar
+      use stdlib_hashmap_wrappers, only: &
+          get_other_scalar, other_type, set
+      use stdlib_kinds, only: int32
+      implicit none
+      integer(int32) :: value, result
+      type(other_type) :: other
+      value = 15
+      call set( other, value )
+      call get_other_scalar( other, result )
+      print *, 'RESULT == VALUE = ', ( value == result )
+    end program demo_get
+```
 
 #### `hasher_fun`- serves aa a function prototype.
 

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
@@ -84,7 +85,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
 
@@ -31,6 +38,7 @@ module stdlib_hashmap_wrappers
         free_key,                &
         free_other,              &
         get,                     &
+        get_other_scalar,        &
         hasher_fun,              &
         operator(==),            &
         seeded_nmhash32_hasher,  &
@@ -87,10 +95,20 @@ end function hasher_fun
     interface get
 
         module procedure get_char_key,   &
+                         get_other, &
                          get_int8_key
 
     end interface get
 
+    interface get_other_scalar
+
+        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_other_scalar
+
 
     interface operator(==)
         module procedure equal_keys
@@ -260,6 +278,63 @@ 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 kind provided by stdlib_kinds
+!! ([Specifications](../page/specs/stdlib_hashmaps.html#get_other_scalar-extracts-a-scalar-value-from-a-derived-type))
+        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
+!! ([Specifications](../page/specs/stdlib_hashmaps.html#get_other_scalar-extracts-a-scalar-value-from-a-derived-type))
+        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

src/tests/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_other_scalar
+
+    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_scalar(other, value_out)
+
+        call check(error, value_in, value_out, "get_other_scalar char: value_in not equal to value_out")
+        return
+
+        call get_other_scalar(other, value_out, exists = exists)
+        call check(error, value_in, value_out, "get_other_scalar char: value_in not equal to value_out")
+        return
+        call check(error, exists, "get_other_scalar 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_scalar(other, value_out)
+
+        call check(error, value_in, value_out, "get_other_scalar ${k1}$: value_in not equal to value_out")
+        return
+
+        call get_other_scalar(other, value_out, exists = exists)
+
+        call check(error, value_in, value_out, "get_other_scalar ${k1}$: value_in not equal to value_out")
+        return
+        call check(error, exists, "get_other_scalar ${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_scalar(other, value_out)
+
+        call check(error, value_in, value_out, "get_other_scalar c${k1}$: value_in not equal to value_out")
+        return
+
+        call get_other_scalar(other, value_out, exists = exists)
+
+        call check(error, value_in, value_out, "get_other_scalar c${k1}$: value_in not equal to value_out")
+        return
+        call check(error, exists, "get_other_scalar 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_scalar(other, value_out)
+
+        call check(error, value_in .eqv. value_out, "get_other_scalar lk: value_in not equal to value_out")
+        return
+
+        call get_other_scalar(other, value_out, exists = exists)
+
+        call check(error, value_in .eqv. value_out, "get_other_scalar lk: value_in not equal to value_out")
+        return
+        call check(error, exists, "get_other_scalar 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)