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,75 @@ 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]]( other[, value_char,
+value_int8, value_int16, value_int32, value_int64, value_sp, value_dp, value_csp, value_cdp, value_lk,
+exists] )`
+
+##### Class
+
+Subroutine.
+
+##### Arguments
+
+`other`: shall be a scalar expression of type `other_type`. It
+is an `intent(in)` argument.
+
+`value_char`: shall be a scalar `character(len=:), allocatable) variable. It is an
+`intent(out)` `optional` argument.
+
+`value_int8`, `value_int16`, `value_int32`, `value_int64`: shall be a scalar
+`integer` of kind `int8`, `int16`, `int32`, `int64`, respectively. It is an
+`intent(out)` `optional` argument.
+
+`value_sp`, `value_dp`: shall be a scalar `real` of kind `sp`, `dp` respectively.
+It is an `intent(out)` `optional` argument.
+
+`value_csp`, `value_cdp`: shall be a scalar `complex` of kind `sp`, `dp` respectively.
+It is an `intent(out)` `optional` argument.
+
+`value_lk`: shall be a scalar `logical` of kind `lk`. It is an `intent(out)`
+`optional` 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,4 @@
+#:include "common.fypp"
 !! 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 +16,12 @@ module stdlib_hashmap_wrappers
  int16, &
  int32, &
  int64, &
- dp
+ sp, &
+ dp, &
+ xdp, &
+ qp, &
+ lk, &
+ c_bool
 
  implicit none
 
@@ -31,6 +37,7 @@ module stdlib_hashmap_wrappers
  free_key, &
  free_other, &
  get, &
+ get_other_scalar, &
  hasher_fun, &
  operator(==), &
  seeded_nmhash32_hasher, &
@@ -87,6 +94,7 @@ end function hasher_fun
  interface get
 
  module procedure get_char_key, &
+ get_other, &
  get_int8_key
 
  end interface get
@@ -260,6 +268,64 @@ subroutine get_other( other, value )
 
  end subroutine get_other
 
+
+ subroutine get_other_scalar(other, value_char &
+ #:set IRL_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES + LOG_KINDS_TYPES
+ #:for k1, t1 in IRL_KINDS_TYPES
+ , value_${k1}$ &
+ #:endfor
+ #:for k1, t1 in CMPLX_KINDS_TYPES
+ , value_c${k1}$ &
+ #:endfor
+ , 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), optional :: value_char
+ #:for k1, t1 in IRL_KINDS_TYPES
+ ${t1}$, intent(out), optional :: value_${k1}$
+ #:endfor
+ #:for k1, t1 in CMPLX_KINDS_TYPES
+ ${t1}$, intent(out), optional :: value_c${k1}$
+ #:endfor
+ 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(*) )
+ if (present(value_char)) then
+ value_char = d
+ exists_ = .true.
+ end if
+ #:for k1, t1 in IRL_KINDS_TYPES
+ type is ( ${t1}$ )
+ if (present(value_${k1}$)) then
+ value_${k1}$ = d
+ exists_ = .true.
+ end if
+ #:endfor
+ #:for k1, t1 in CMPLX_KINDS_TYPES
+ type is ( ${t1}$ )
+ if (present(value_c${k1}$)) then
+ value_c${k1}$ = d
+ exists_ = .true.
+ end if
+ #:endfor
+ end select
+
+ if (present(exists)) exists = exists_
+
+ end subroutine
 
  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_char = 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_char = 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_${k1}$ = 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_${k1}$ = 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_c${k1}$ = 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_c${k1}$ = 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_lk = 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_lk = 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)