From 53ffd582148d6e0f73c34468ce65a1ee0d237b82 Mon Sep 17 00:00:00 2001 From: "Nakib H. Protik" Date: Thu, 7 Nov 2024 11:30:22 +0100 Subject: [PATCH] Now shipping fhash in the thirdparty directory. --- fpm.toml | 6 +- .../.github/workflows/deploy_api_docs.yml | 31 + thirdparty/fhash/.github/workflows/test.yml | 84 +++ thirdparty/fhash/.gitignore | 5 + thirdparty/fhash/CMakeLists.txt | 138 ++++ thirdparty/fhash/Config.cmake.in | 9 + thirdparty/fhash/LICENSE | 21 + thirdparty/fhash/README.md | 52 ++ thirdparty/fhash/app/0-simple-demo/main.f90 | 31 + thirdparty/fhash/app/1-methods-demo/index.md | 22 + thirdparty/fhash/app/1-methods-demo/main.f90 | 44 ++ .../fhash/app/2-derived-type-demo/index.md | 21 + .../fhash/app/2-derived-type-demo/main.f90 | 54 ++ .../fhash/app/3-custom-key-demo/index.md | 22 + .../3-custom-key-demo/key_implementation.md | 9 + .../fhash/app/3-custom-key-demo/main.f90 | 45 ++ .../app/3-custom-key-demo/my_key_type.f90 | 125 ++++ thirdparty/fhash/app/4-iter-demo/index.md | 8 + thirdparty/fhash/app/4-iter-demo/main.f90 | 58 ++ thirdparty/fhash/app/bench/main.f90 | 40 ++ thirdparty/fhash/app/index.md | 88 +++ thirdparty/fhash/ford.md | 11 + thirdparty/fhash/fpm.toml | 37 ++ thirdparty/fhash/src/CMakeLists.txt | 7 + thirdparty/fhash/src/fhash.f90 | 13 + thirdparty/fhash/src/fhash_data_container.f90 | 243 +++++++ thirdparty/fhash/src/fhash_fnv.f90 | 193 ++++++ thirdparty/fhash/src/fhash_key/base.f90 | 42 ++ thirdparty/fhash/src/fhash_key/char.f90 | 81 +++ thirdparty/fhash/src/fhash_key/int32.f90 | 81 +++ thirdparty/fhash/src/fhash_key/int32_1d.f90 | 87 +++ thirdparty/fhash/src/fhash_key/int64.f90 | 81 +++ thirdparty/fhash/src/fhash_key/int64_1d.f90 | 87 +++ thirdparty/fhash/src/fhash_sll.f90 | 285 +++++++++ thirdparty/fhash/src/fhash_tbl.f90 | 597 ++++++++++++++++++ thirdparty/fhash/src/fhash_tbl_iter.f90 | 87 +++ thirdparty/fhash/test/CMakeLists.txt | 25 + thirdparty/fhash/test/TestLite.f90 | 113 ++++ thirdparty/fhash/test/TestLite_error.f90 | 152 +++++ thirdparty/fhash/test/TestLite_suite.f90 | 309 +++++++++ thirdparty/fhash/test/main.f90 | 27 + thirdparty/fhash/test/test_container.f90 | 86 +++ thirdparty/fhash/test/test_fnv.f90 | 284 +++++++++ thirdparty/fhash/test/test_key.f90 | 235 +++++++ thirdparty/fhash/test/test_sll.f90 | 350 ++++++++++ thirdparty/fhash/test/test_tbl.f90 | 475 ++++++++++++++ thirdparty/fhash/test/test_tbl_iter.f90 | 128 ++++ 47 files changed, 5028 insertions(+), 1 deletion(-) create mode 100644 thirdparty/fhash/.github/workflows/deploy_api_docs.yml create mode 100644 thirdparty/fhash/.github/workflows/test.yml create mode 100644 thirdparty/fhash/.gitignore create mode 100644 thirdparty/fhash/CMakeLists.txt create mode 100644 thirdparty/fhash/Config.cmake.in create mode 100644 thirdparty/fhash/LICENSE create mode 100644 thirdparty/fhash/README.md create mode 100644 thirdparty/fhash/app/0-simple-demo/main.f90 create mode 100644 thirdparty/fhash/app/1-methods-demo/index.md create mode 100644 thirdparty/fhash/app/1-methods-demo/main.f90 create mode 100644 thirdparty/fhash/app/2-derived-type-demo/index.md create mode 100644 thirdparty/fhash/app/2-derived-type-demo/main.f90 create mode 100644 thirdparty/fhash/app/3-custom-key-demo/index.md create mode 100644 thirdparty/fhash/app/3-custom-key-demo/key_implementation.md create mode 100644 thirdparty/fhash/app/3-custom-key-demo/main.f90 create mode 100644 thirdparty/fhash/app/3-custom-key-demo/my_key_type.f90 create mode 100644 thirdparty/fhash/app/4-iter-demo/index.md create mode 100644 thirdparty/fhash/app/4-iter-demo/main.f90 create mode 100644 thirdparty/fhash/app/bench/main.f90 create mode 100644 thirdparty/fhash/app/index.md create mode 100644 thirdparty/fhash/ford.md create mode 100644 thirdparty/fhash/fpm.toml create mode 100644 thirdparty/fhash/src/CMakeLists.txt create mode 100644 thirdparty/fhash/src/fhash.f90 create mode 100644 thirdparty/fhash/src/fhash_data_container.f90 create mode 100644 thirdparty/fhash/src/fhash_fnv.f90 create mode 100644 thirdparty/fhash/src/fhash_key/base.f90 create mode 100644 thirdparty/fhash/src/fhash_key/char.f90 create mode 100644 thirdparty/fhash/src/fhash_key/int32.f90 create mode 100644 thirdparty/fhash/src/fhash_key/int32_1d.f90 create mode 100644 thirdparty/fhash/src/fhash_key/int64.f90 create mode 100644 thirdparty/fhash/src/fhash_key/int64_1d.f90 create mode 100644 thirdparty/fhash/src/fhash_sll.f90 create mode 100644 thirdparty/fhash/src/fhash_tbl.f90 create mode 100644 thirdparty/fhash/src/fhash_tbl_iter.f90 create mode 100644 thirdparty/fhash/test/CMakeLists.txt create mode 100644 thirdparty/fhash/test/TestLite.f90 create mode 100644 thirdparty/fhash/test/TestLite_error.f90 create mode 100644 thirdparty/fhash/test/TestLite_suite.f90 create mode 100644 thirdparty/fhash/test/main.f90 create mode 100644 thirdparty/fhash/test/test_container.f90 create mode 100644 thirdparty/fhash/test/test_fnv.f90 create mode 100644 thirdparty/fhash/test/test_key.f90 create mode 100644 thirdparty/fhash/test/test_sll.f90 create mode 100644 thirdparty/fhash/test/test_tbl.f90 create mode 100644 thirdparty/fhash/test/test_tbl_iter.f90 diff --git a/fpm.toml b/fpm.toml index 617da86e..524fc867 100644 --- a/fpm.toml +++ b/fpm.toml @@ -16,8 +16,12 @@ source-dir="src" [dependencies] #Pull from github #testify = { git = "git@github.com:nakib/testify.git" } +#Use local copy testify = {path = "thirdparty/testify"} -fhash = { git = "https://github.com/LKedward/fhash.git" } +#Pull from github +#fhash = {git = "https://github.com/LKedward/fhash.git"} +#Use local copy +fhash = {path = "thirdparty/fhash"} #Use local copy from thirdparty directory spglib = {path = "thirdparty/spglib"} diff --git a/thirdparty/fhash/.github/workflows/deploy_api_docs.yml b/thirdparty/fhash/.github/workflows/deploy_api_docs.yml new file mode 100644 index 00000000..bbc11149 --- /dev/null +++ b/thirdparty/fhash/.github/workflows/deploy_api_docs.yml @@ -0,0 +1,31 @@ +name: Build FORD docs & deploy to gh-pages +on: + push: + branches: + - master + +jobs: + build: + name: Deploy docs + runs-on: ubuntu-latest + steps: + - name: Set up Python + uses: actions/setup-python@v2 + with: + python-version: '3.x' + + - name: Install dependencies + run: python -m pip install --upgrade pip ford + + - name: Checkout master + uses: actions/checkout@v1 + + - name: Build docs + run: ford ford.md + + - name: Deploy + uses: JamesIves/github-pages-deploy-action@releases/v3 + with: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + BRANCH: gh-pages + FOLDER: api-doc \ No newline at end of file diff --git a/thirdparty/fhash/.github/workflows/test.yml b/thirdparty/fhash/.github/workflows/test.yml new file mode 100644 index 00000000..8e103a65 --- /dev/null +++ b/thirdparty/fhash/.github/workflows/test.yml @@ -0,0 +1,84 @@ +name: fpm test + +on: [push, pull_request] + +jobs: + test: + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest, macos-latest, windows-latest] + toolchain: + - {compiler: gcc, version: 10} + include: + - os: ubuntu-latest + toolchain: {compiler: intel, version: '2023.1'} + - os: ubuntu-latest + toolchain: {compiler: gcc, version: 12} + + steps: + - uses: awvwgk/setup-fortran@v1 + id: setup-fortran + with: + compiler: ${{ matrix.toolchain.compiler }} + version: ${{ matrix.toolchain.version }} + + - run: ${{ env.FC }} --version + env: + FC: ${{ steps.setup-fortran.outputs.fc }} + + - name: Install fpm + uses: fortran-lang/setup-fpm@v5 + with: + github-token: ${{ secrets.GITHUB_TOKEN }} + + - name: Checkout code + uses: actions/checkout@v1 + + - name: Run tests and demo programs (debug) + run: | + fpm test + fpm run *-demo + + - name: Run tests and demo programs (release) + run: | + fpm test --profile release + fpm run *-demo --profile release + + + gfortran-windows-msys2-mingw64: + runs-on: windows-latest + steps: + - name: Checkout code + uses: actions/checkout@v1 + + - name: Setup MinGW (MSYS2) + uses: msys2/setup-msys2@v2 + with: + msystem: MINGW64 + update: false + install: >- + git + wget + mingw-w64-x86_64-gcc-fortran + + - name: Install fpm + shell: msys2 {0} + run: | + wget https://github.com/awvwgk/mingw-w64-fpm-pkgbuild/releases/download/current/mingw-w64-x86_64-fpm-0.2.0-1-any.pkg.tar.zst + pacman -U --noconfirm mingw-w64-x86_64-fpm-*-any.pkg.tar.zst + + - name: Run tests and demo programs (debug) + shell: msys2 {0} + run: | + gfortran --version + fpm test + fpm run *-demo + + - name: Run tests and demo programs (release) + shell: msys2 {0} + run: | + gfortran --version + fpm test --profile release + fpm run *-demo --profile release diff --git a/thirdparty/fhash/.gitignore b/thirdparty/fhash/.gitignore new file mode 100644 index 00000000..8cfa12f1 --- /dev/null +++ b/thirdparty/fhash/.gitignore @@ -0,0 +1,5 @@ +build* +api-doc* +*~ +.\#* +\#*\# diff --git a/thirdparty/fhash/CMakeLists.txt b/thirdparty/fhash/CMakeLists.txt new file mode 100644 index 00000000..5a82d979 --- /dev/null +++ b/thirdparty/fhash/CMakeLists.txt @@ -0,0 +1,138 @@ +cmake_minimum_required(VERSION 3.0.2) + +project(fhash Fortran) + +if(DEFINED CMAKE_Fortran_COMPILER_VERSION) + set(Fortran_MODULE_DIRECTORY include/fortran_modules/${CMAKE_Fortran_COMPILER_ID}/${CMAKE_Fortran_COMPILER_VERSION}) +else() + set(Fortran_MODULE_DIRECTORY include/fortran_modules/${CMAKE_Fortran_COMPILER_ID}) +endif() + +set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/${Fortran_MODULE_DIRECTORY}) + +add_subdirectory(src) + +include(CMakePackageConfigHelpers) + +# Add all targets to the build-tree export set +export(TARGETS fhash + FILE "${PROJECT_BINARY_DIR}/fhashTargets.cmake") + +# Export the package for use from the build-tree +# (this registers the build-tree with a global CMake-registry) +export(PACKAGE fhash) + +configure_package_config_file(${CMAKE_CURRENT_SOURCE_DIR}/Config.cmake.in + "${CMAKE_CURRENT_BINARY_DIR}/fhashConfig.cmake" + INSTALL_DESTINATION lib/cmake/fhash + ) + +install(FILES + "${CMAKE_CURRENT_BINARY_DIR}/fhashConfig.cmake" + DESTINATION lib/cmake/fhash +) + +install(DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY}/ DESTINATION ${Fortran_MODULE_DIRECTORY}) + +install(EXPORT fhash + FILE fhashTargets.cmake + DESTINATION lib/cmake/fhash +) + +# ------------------- +# Build documentation +# ------------------- + +set ( SKIP_DOC_GEN FALSE CACHE BOOL + "Disable building the API documentation with FORD" ) +if ( NOT SKIP_DOC_GEN ) + find_program(FORD ford) + + find_package(PythonInterp) + + if(NOT PYTHON_VERSION_STRING VERSION_LESS 3.5) + set(MARKDOWN_SUPPORTED_PYTHON true) + endif() + + if(NOT MARKDOWN_SUPPORTED_PYTHON) + message(WARNING "Python version ${PYTHON_VERSION_STRING} is not supported by Python-Markdown, not attempting to build documentation.") + endif() + + if(FORD AND MARKDOWN_SUPPORTED_PYTHON) + + set(DOC_ROOT "${PROJECT_BINARY_DIR}/doc") + set(DOC_DIR "${DOC_ROOT}/fhash") + set(PROJ_DIR "${PROJECT_SOURCE_DIR}") + set(FORD_PROJECT_FILE "${CMAKE_CURRENT_SOURCE_DIR}/ford.md") + set(FORD_PROJECT_EXCLUDE_DIRS "${MPI_Fortran_INCLUDE_DIRS};${PROJECT_BINARY_DIR};${PROJ_DIR}/build;${PROJ_DIR}/tests;${PROJ_DIR}/sphinx") + set(FORD_PROJECT_EXCLUDE_FILES "random.f90;random_integer.f90") + set(MACRO_FLAG "") + string(REPLACE ";" "\ninclude:" FORD_PROJECT_INCLUDES "${PROJ_DIR}/src") + string(REPLACE ";" "\nexclude_dir:" FORD_PROJECT_EXCLUDE_DIRS "${FORD_PROJECT_EXCLUDE_DIRS}") + string(REPLACE ";" "\nexclude:" FORD_PROJECT_EXCLUDE_FILES "${FORD_PROJECT_EXCLUDE_FILES}") + + # Pick the preprocessor to use based on the Fortran compiler + if ( "${CMAKE_Fortran_COMPILER_ID}" MATCHES "Intel" ) + set ( FPP "fpp\n" ) + else () + set ( FPP "gfortran -E\n" ) # default to gfortran -E for gfortran and unsupported compilers + endif () + file ( WRITE "${PROJECT_BINARY_DIR}/.PREPROCESSOR" "${FPP}" ) + + # Dynamically generate the FORD outputs list + message ( STATUS "Dynamically computing FORD output information..." ) + if ( NOT (DEFINED FORD_OUTPUTS_CACHED) ) + message ( STATUS "Running FORD to dynamically compute documentation outputs, this could take a while..." ) + execute_process ( COMMAND ${CMAKE_COMMAND} -E remove_directory ${DOC_DIR} + COMMAND ${CMAKE_COMMAND} -E make_directory ${DOC_DIR} + COMMAND "${FORD}" --debug -q ${MACRO_FLAG} -d "${PROJ_DIR}" -o "${DOC_DIR}" -p "${PAGE_DIR}" "${FORD_PROJECT_FILE}" OUTPUT_QUIET ) + else () + message ( STATUS "Re-using cached FORD outputs, rather than regenerating them" ) + endif() + + # Compile a list of FORD output files + file ( GLOB_RECURSE FORD_OUTPUTS + "${DOC_DIR}/*.*" ) + file ( GLOB_RECURSE FORD_CLEAN_OUTPUTS + "${DOC_DIR}/*.*" ) + + # Cache FORD outputs + if ( (DEFINED FORD_OUTPUTS) AND ( NOT ( "${FORD_OUTPUTS}" STREQUAL "" ) ) ) + message ( STATUS "Caching FORD outputs" ) + set ( FORD_OUTPUTS_CACHED "${FORD_OUTPUTS}" + CACHE STRING "variable containing FORD outputs to prevent rebuilding FORD docs" FORCE ) + endif () + message ( STATUS "Done dynamically computing FORD outputs." ) + + foreach ( DOC_SRC_FILE ${PROJECT_SOURCE_DIR}/ford.md ${FHASH_SOURCES} ) + list ( APPEND FORD_DEPENDS "${DOC_SRC_FILE}" ) + endforeach () + + # Re-build FORD output if needed + add_custom_command ( OUTPUT ${FORD_OUTPUTS_CACHED} + COMMAND "${FORD}" --debug ${MACRO_FLAG} -d "${PROJ_DIR}" -o "${DOC_DIR}" "${FORD_PROJECT_FILE}" + MAIN_DEPENDENCY "${FORD_PROJECT_FILE}" + DEPENDS ${FORD_DEPENDS} + COMMENT "Building HTML documentation for ${PROJECT_NAME} using FORD" ) + + add_custom_target ( documentation ALL + DEPENDS ${FORD_OUTPUTS_CACHED} ) + + # Install documentation + set ( INSTALL_API_DOCUMENTATION TRUE + CACHE BOOL "Install FORD generated documentation?" ) + if ( INSTALL_API_DOCUMENTATION ) + install ( DIRECTORY "${DOC_ROOT}/" DESTINATION share/doc ) + else () + + # FORD Not found + message ( WARNING + "FORD not found. Please set the CMake cache variable FORD to point to the installed FORD executable, and reconfigure or disable building the documentation. FORD can be installed from PYPI with `sudo pip install FORD` or from If you do not wish to install FORD and build the JSON-Fortran documentation, then please set the CMake cache variable SKIP_DOC_GEN to TRUE." ) + + endif () + endif () + +endif() + +enable_testing() +add_subdirectory(test) diff --git a/thirdparty/fhash/Config.cmake.in b/thirdparty/fhash/Config.cmake.in new file mode 100644 index 00000000..b6c69a3b --- /dev/null +++ b/thirdparty/fhash/Config.cmake.in @@ -0,0 +1,9 @@ +@PACKAGE_INIT@ + +include("${CMAKE_CURRENT_LIST_DIR}/fhashTargets.cmake") + +include(CMakeFindDependencyMacro) + +check_required_components(fhash) + +set(fhash_DOCDIR @CMAKE_INSTALL_PREFIX@/share/doc/fhash) diff --git a/thirdparty/fhash/LICENSE b/thirdparty/fhash/LICENSE new file mode 100644 index 00000000..26246e83 --- /dev/null +++ b/thirdparty/fhash/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2020 Laurence Kedward + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/thirdparty/fhash/README.md b/thirdparty/fhash/README.md new file mode 100644 index 00000000..87e8db19 --- /dev/null +++ b/thirdparty/fhash/README.md @@ -0,0 +1,52 @@ +# fhash +__[fpm](https://github.com/fortran-lang/fpm) package implementing a hash table with support for generic keys and values.__ + +[![License: MIT](https://img.shields.io/badge/License-MIT-blue.svg)](https://opensource.org/licenses/MIT) +[![fpm test](https://github.com/LKedward/fhash/workflows/fpm%20test/badge.svg?branch=master&event=push)](https://github.com/LKedward/fhash/actions) +[![ford docs](https://img.shields.io/badge/FORD%20API%20Docs-Deployed-green)](https://lkedward.github.io/fhash/) + + + +## fpm usage + +To use *fhash* within your *fpm* project, add the following to your package manifest file (`fpm.toml`): + +```toml +[dependencies] +fhash = { git = "https://github.com/LKedward/fhash.git" } +``` + + +## Simple example: scalar intrinsics + +The package provides a `fhash_tbl_t` type with `set` and `get` methods for storing and retrieving key-value pairs. +The `fhash_key` interface (aliased to `key` below) is used to define a valid key from different inputs. + +```fortran +program fhash_demo1 + use fhash, only: fhash_tbl_t, key=>fhash_key + implicit none + type(fhash_tbl_t) :: tbl + integer :: val + + call tbl%set(key('my_key_1'), value=10) + call tbl%set(key('my_key_2'), value=1.0) + call tbl%set(key(123456), value='a string value') + call tbl%set(key([1,2,3,4,5]), value=.false.) + + call tbl%get(key('my_key_1'),val) + +end program fhash_demo1 +``` + +See the [Quickstart Guide](https://lkedward.github.io/fhash/page/index.html) for an explanation of this example and the API methods used. + + +## Advanced usage + +- [More table methods](https://lkedward.github.io/fhash/page/1-methods-demo/index.html) +- [Storing custom derived types as values](https://lkedward.github.io/fhash/page/2-derived-type-demo/index.html) +- [Using custom derived types as keys](https://lkedward.github.io/fhash/page/3-custom-key-demo/index.html) + + +See for the full API documentation. \ No newline at end of file diff --git a/thirdparty/fhash/app/0-simple-demo/main.f90 b/thirdparty/fhash/app/0-simple-demo/main.f90 new file mode 100644 index 00000000..350c09f8 --- /dev/null +++ b/thirdparty/fhash/app/0-simple-demo/main.f90 @@ -0,0 +1,31 @@ +!> Example program demonstrating basic set/get usage +!> for different key/value types +program fhash_demo + use fhash, only: fhash_tbl_t, key=>fhash_key + implicit none + + type(fhash_tbl_t) :: tbl + integer :: i + real :: r + character(:), allocatable :: char + logical :: bool + + print *, '# fhash demo program: simple-demo' + + call tbl%set(key('my_key_1'), value=10) + call tbl%set(key('my_key_2'), value=1.0) + call tbl%set(key(123456), value='a string value') + call tbl%set(key([1,2,3,4,5]), value=.false.) + + call tbl%get(key('my_key_1'),i) + call tbl%get(key('my_key_2'),r) + call tbl%get(key(123456),char) + call tbl%get(key([1,2,3,4,5]),bool) + + print *, 'Key = "my_key_1" Value = ',i + print *, 'Key = "my_key_2" Value = ',r + print *, 'Key = 123456 Value = "',char,'"' + print *, 'Key = [1,2,3,4,5] Value = ', bool + print * + +end program fhash_demo \ No newline at end of file diff --git a/thirdparty/fhash/app/1-methods-demo/index.md b/thirdparty/fhash/app/1-methods-demo/index.md new file mode 100644 index 00000000..84ccf944 --- /dev/null +++ b/thirdparty/fhash/app/1-methods-demo/index.md @@ -0,0 +1,22 @@ +--- +title: Hash table methods +--- + +## Hash table methods + +Other hash table methods, in addition to `[[fhash_tbl_t(type):set(bound)]]` and `[[fhash_tbl_t(type):get(bound)]]`, are: + +- `[[fhash_tbl_t(type):allocate(bound)]]`: manually allocate the number of table buckets + +- `[[fhash_tbl_t(type):check_key(bound)]]`: determine whether a given key exists within the table + +- `[[fhash_tbl_t(type):unset(bound)]]`: remove a key-value pair from the table + +- `[[fhash_tbl_t(type):stats(bound)]]`: query information about the table instance + + +### Example + +```fortran +{!app/1-methods-demo/main.f90!} +``` diff --git a/thirdparty/fhash/app/1-methods-demo/main.f90 b/thirdparty/fhash/app/1-methods-demo/main.f90 new file mode 100644 index 00000000..6c24ba64 --- /dev/null +++ b/thirdparty/fhash/app/1-methods-demo/main.f90 @@ -0,0 +1,44 @@ +!> Example program demonstrating useful +!> fhash_tbl_t methods +program fhash_demo + use fhash, only: fhash_tbl_t, key=>fhash_key + implicit none + + type(fhash_tbl_t) :: tbl + integer :: i, stat + integer :: num_buckets, num_items, num_collisions, max_depth + + print *, '# fhash demo program: methods-demo' + + !> Manually specify number of table buckets + call tbl%allocate(301) + + print *, 'Setting keys... ' + do i=0,256 + + call tbl%set(key(i),i*i) + + end do + + !> Query information about the hash table + print *, 'Querying table info...' + call tbl%stats(num_buckets,num_items,num_collisions,max_depth) + write(*,'(A,T40,I0)') ' Number of buckets allocated: ',num_buckets + write(*,'(A,T40,I0)') ' Number of key-value pairs stored: ',num_items + write(*,'(A,T40,I0)') ' Total number of hash-collisions: ',num_collisions + write(*,'(A,T40,I0)') ' The worst case bucket depth is ',max_depth + print * + + !> Check for existence of a key + call tbl%check_key(key(0),stat) + print *, 'Check key 0: ',merge('FOUND ','NOT FOUND',stat==0) + + !> Unset a key in the table + print *, 'Removing key 0...' + call tbl%unset(key(0)) + + call tbl%check_key(key(0),stat) + print *, 'Check key 0: ',merge('FOUND ','NOT FOUND',stat==0) + print * + +end program fhash_demo \ No newline at end of file diff --git a/thirdparty/fhash/app/2-derived-type-demo/index.md b/thirdparty/fhash/app/2-derived-type-demo/index.md new file mode 100644 index 00000000..fbd5d147 --- /dev/null +++ b/thirdparty/fhash/app/2-derived-type-demo/index.md @@ -0,0 +1,21 @@ +--- +title: Example: Custom value types +--- + +## Example: Custom value types + +Since an unlimited polymorphic argument is used when storing hash table +values, no modification is required to set custom derived types as values. + +However, when retrieving values it is convenient to define a custom getter +routine to correctly obtain the derived type value from the table. + +In this demo, a custom getter is defined for a `string_t` type. +The getter must obtain a raw polymorphic allocatable from the hash table, +and determine the type using the `select type` construct. The getter +should therefore implement some form of error handling for the case when +the requested key is not of the expected derived type. + +```fortran +{!app/2-derived-type-demo/main.f90!} +``` diff --git a/thirdparty/fhash/app/2-derived-type-demo/main.f90 b/thirdparty/fhash/app/2-derived-type-demo/main.f90 new file mode 100644 index 00000000..85b14f9d --- /dev/null +++ b/thirdparty/fhash/app/2-derived-type-demo/main.f90 @@ -0,0 +1,54 @@ +!> Example program demonstrating how to store and retrieve +!> custom derived types using `fhash` +program fhash_demo + use fhash, only: fhash_tbl_t, key=>fhash_key, fhash_key_t + implicit none + + type string_t + character(:), allocatable :: s + end type string_t + + type(fhash_tbl_t) :: tbl + character(:), allocatable :: key_str + type(string_t) :: str1, str2 + + print *, '# fhash demo program: derived-type-demo' + + str1%s = 'Hello fhash' + key_str = 'my_key' + + print *, 'Storing value "',str1%s,'" with key: "',key_str,'"' + call tbl%set(key(key_str), value=str1) + + print *, 'Retrieving value with key: "',key_str,'"' + call fhash_get_string(tbl,key(key_str),str2) + print *, ' value = "',str2%s,'"' + + print * + + contains + + !> Define custom getter for string_t type + subroutine fhash_get_string(tbl,k,string) + type(fhash_tbl_t), intent(in) :: tbl + class(fhash_key_t), intent(in) :: k + type(string_t), intent(out) :: string + + integer :: stat + class(*), allocatable :: data + + call tbl%get_raw(k,data,stat) + + if (stat /= 0) print *, 'error ', stat! Error handling: key not found + + select type(d=>data) + type is (string_t) + string = d + class default + ! Error handling: found wrong type + print *, 'error' + end select + + end subroutine fhash_get_string + +end program fhash_demo \ No newline at end of file diff --git a/thirdparty/fhash/app/3-custom-key-demo/index.md b/thirdparty/fhash/app/3-custom-key-demo/index.md new file mode 100644 index 00000000..9f4fefc0 --- /dev/null +++ b/thirdparty/fhash/app/3-custom-key-demo/index.md @@ -0,0 +1,22 @@ +--- +title: Example: Custom key types +--- + +## Example: Custom Key Types + +Custom key types can be defined simply by extension of the abstract `fhash_key_t` type +defined in [`fhash_key_base`](../../src/fhash_key/base.f90). +Extensions of this type must implement the `equals`, `hash` and `to_string` procedures. +Optionally, you may also override the `fhash_key` interface with a helper function to +generate a key from your custom type. + +To perform the hashing, the included `fhash_fnv` module provides the `fnv_1a` interface +which supports default scalar characters and 32bit/64bit scalar/1D integers. +You can use this interface to generate a hash from the components of your derived type. + +In this example, a `key_string_t` key container type is defined as an extension +of `fhash_key_T` which allows the `string_t` derived type to be used as a key. + +```fortran +{!app/3-custom-key-demo/main.f90!} +``` diff --git a/thirdparty/fhash/app/3-custom-key-demo/key_implementation.md b/thirdparty/fhash/app/3-custom-key-demo/key_implementation.md new file mode 100644 index 00000000..e04450d3 --- /dev/null +++ b/thirdparty/fhash/app/3-custom-key-demo/key_implementation.md @@ -0,0 +1,9 @@ +--- +title: Key implementation +--- + +### Custom key type implementation + +```fortran +{!app/3-custom-key-demo/my_key_type.f90!} +``` diff --git a/thirdparty/fhash/app/3-custom-key-demo/main.f90 b/thirdparty/fhash/app/3-custom-key-demo/main.f90 new file mode 100644 index 00000000..86809edf --- /dev/null +++ b/thirdparty/fhash/app/3-custom-key-demo/main.f90 @@ -0,0 +1,45 @@ +!> Example program demonstrating how a custom key-type +!> can be used. +!> See the `my_key_type` module for the definition of the +!> custom key type. +!> +!> See README.md for an explanation +!> +program fhash_demo + use fhash, only: fhash_tbl_t + use my_key_type, only: string_t, key_string_t, key=>fhash_key + implicit none + + type(fhash_tbl_t) :: tbl + type(string_t) :: str1, str2 + integer :: val + + print *, '# fhash demo program: custom-key-demo' + + str1%s = 'Hello world' + str2%s = 'Hello fhash' + + print *, 'Storing value 10 with key: "',str1%s,'"' + call tbl%set(key([str1]), value=10) + + print *, 'Storing value 20 with key: "',str2%s,'"' + call tbl%set(key([str2]), value=20) + + print *, 'Storing value 30 with key: ["',str1%s,'", "',str2%s,'"]' + call tbl%set(key([str1,str2]), value=30) + + print *, 'Retrieving value with key: "',str1%s,'"' + call tbl%get(key([str1]),val) + print *, ' value = ',val + + print *, 'Retrieving value with key: "',str2%s,'"' + call tbl%get(key([str2]),val) + print *, ' value = ',val + + print *, 'Retrieving value with key: ["',str1%s,'", "',str2%s,'"]' + call tbl%get(key([str1,str2]),val) + print *, ' value = ',val + + print * + +end program fhash_demo diff --git a/thirdparty/fhash/app/3-custom-key-demo/my_key_type.f90 b/thirdparty/fhash/app/3-custom-key-demo/my_key_type.f90 new file mode 100644 index 00000000..cfcbd303 --- /dev/null +++ b/thirdparty/fhash/app/3-custom-key-demo/my_key_type.f90 @@ -0,0 +1,125 @@ +!> Example module demonstrating how a custom key-type +!> can be made. +!> +!> See README.md for an explanation +!> +module my_key_type + use iso_fortran_env, only: int64 + use fhash_key_base, only: fhash_key_t + use fhash_fnv, only: fnv_1a + implicit none + + private + public :: string_t, key_string_t + public :: fhash_key + + !> The custom type for which we wish to create a key + type :: string_t + + character(:), allocatable :: s + + end type string_t + + !> A key type container for our custom type + type, extends(fhash_key_t) :: key_string_t + + type(string_t), allocatable :: value(:) + + contains + + procedure :: hash => key_hash_string_t + procedure :: equals => key_equals_string_t + procedure, pass :: to_string => key_to_string + + end type key_string_t + + !> Override the existing `fhash_key` interface to additionally + !> support our custom key type + interface fhash_key + module procedure :: key_from_string_t + end interface fhash_key + +contains + + !> Implements equality operator for custom key type. + !> + !> NB. Keys of different types are always not equal. + !> + pure function key_equals_string_t(key1,key2) result(keys_equal) + class(key_string_t), intent(in) :: key1 + class(fhash_key_t), intent(in) :: key2 + logical :: keys_equal + + integer :: i + keys_equal = .false. + + select type(k2=>key2) + type is (key_string_t) + + if (size(key1%value) /= size(k2%value)) return + + do i=1,size(key1%value) + if (key1%value(i)%s /= k2%value(i)%s) then + return + end if + end do + + keys_equal = .true. + return + + end select + + end function key_equals_string_t + + + !> Implements hashing of the custom key type. + !> + !> NB. Elementary hash function `fnv_1a` provides support for + !> default scalar characters and 32bit/64bit scalar and 1D integers + !> + pure function key_hash_string_t(key) result(hash) + class(key_string_t), intent(in) :: key + integer(int64) :: hash + + integer :: i + + do i=1,size(key%value) + + if (i == 1) then + hash = fnv_1a(key%value(i)%s) + else + hash = fnv_1a(hash, key%value(i)%s) + end if + + end do + + end function key_hash_string_t + + + !> Generate string representation of hash + pure function key_to_string(key) result(str) + class(key_string_t), intent(in) :: key + character(:), allocatable :: str + + integer :: i + + str = '' + do i=1,size(key%value) + str = str//','//key%value(i)%s + end do + + end function key_to_string + + + !> Helper function to create new key container from + !> some set of inputs + function key_from_string_t(source) result(key) + type(string_t), intent(in) :: source(:) + type(key_string_t) :: key + + key%value = source + + end function key_from_string_t + + +end module my_key_type \ No newline at end of file diff --git a/thirdparty/fhash/app/4-iter-demo/index.md b/thirdparty/fhash/app/4-iter-demo/index.md new file mode 100644 index 00000000..d771c4cc --- /dev/null +++ b/thirdparty/fhash/app/4-iter-demo/index.md @@ -0,0 +1,8 @@ +--- +title: Example: Iterating over hash table items +--- + + +```fortran +{!app/4-iter-demo/main.f90!} +``` diff --git a/thirdparty/fhash/app/4-iter-demo/main.f90 b/thirdparty/fhash/app/4-iter-demo/main.f90 new file mode 100644 index 00000000..fe9cc2f7 --- /dev/null +++ b/thirdparty/fhash/app/4-iter-demo/main.f90 @@ -0,0 +1,58 @@ +!> Example program demonstrating how to iterate over items in hash table +program fhash_demo + use fhash, only: fhash_tbl_t, key=>fhash_key, fhash_iter_t, fhash_key_t + implicit none + + type(fhash_tbl_t) :: tbl + type(fhash_iter_t) :: iter + class(fhash_key_t), allocatable :: ikey + class(*), allocatable :: idata + + print *, '# fhash demo program: iter-demo' + + call tbl%set(key('my_key_1'), value=10) + call tbl%set(key('my_key_2'), value=1.0) + call tbl%set(key(123456), value='a string value') + call tbl%set(key([1,2,3,4,5]), value=.false.) + + !> Iterate over all items in table + iter = fhash_iter_t(tbl) + do while(iter%next(ikey,idata)) + + write(*,*) 'Key = "'//ikey%to_string()//'"' + + call print_polymorphic(idata) + + end do + +! call iter%reset() ! (Reset if iterator needed again) + + +contains + + !> Helper routine to print out polymorphic variable for intrinsics data types + subroutine print_polymorphic(data) + class(*), intent(in) :: data + + select type(d=>data) + + type is(integer) + write(*,*) d + + type is(real) + write(*,*) d + + type is(character(*)) + write(*,*) d + + type is(logical) + write(*,*) d + + class default + write(*,*) '[unknown data type, print not implemented]' + + end select + + end subroutine print_polymorphic + +end program fhash_demo \ No newline at end of file diff --git a/thirdparty/fhash/app/bench/main.f90 b/thirdparty/fhash/app/bench/main.f90 new file mode 100644 index 00000000..7fe9cb46 --- /dev/null +++ b/thirdparty/fhash/app/bench/main.f90 @@ -0,0 +1,40 @@ +!> Benchmark program +program fhash_demo + use fhash, only: fhash_tbl_t, key=>fhash_key + implicit none + + type(fhash_tbl_t) :: tbl + integer :: i, stat + integer :: num_buckets, num_items, num_collisions, max_depth + + integer, parameter :: n = 1e7 + real(kind(0.d0)) :: t0, t1 + + print *, '# fhash demo program: benchmark' + + !> Manually specify number of table buckets + call tbl%allocate(2*n) + + print *, 'Setting keys... ' + call cpu_time(t0) + do i=1,n + + call tbl%set(key([1,2,3,4,5,6,7,8,9,10,11,12,13,i]),0.0d0) + + end do + call cpu_time(t1) + + print *, 'Time: ', (t1-t0) + print *, 'Items per second: ', n/(t1-t0) + print * + + !> Query information about the hash table + print *, 'Querying table info...' + call tbl%stats(num_buckets,num_items,num_collisions,max_depth) + write(*,'(A,T40,I0)') ' Number of buckets allocated: ',num_buckets + write(*,'(A,T40,I0)') ' Number of key-value pairs stored: ',num_items + write(*,'(A,T40,I0)') ' Total number of hash-collisions: ',num_collisions + write(*,'(A,T40,I0)') ' The worst case bucket depth is ',max_depth + print * + +end program fhash_demo \ No newline at end of file diff --git a/thirdparty/fhash/app/index.md b/thirdparty/fhash/app/index.md new file mode 100644 index 00000000..0adc2ab5 --- /dev/null +++ b/thirdparty/fhash/app/index.md @@ -0,0 +1,88 @@ +--- +title: User Guide +--- + +## Basic usage + +The package provides a `[[fhash_tbl_t]]` type with `[[fhash_tbl_t(type):set(bound)]]` and `[[fhash_tbl_t(type):get(bound)]]` methods for storing and retrieving key-value pairs. + +__e.g.__ *Declare a table instance* + +```fortran +use fhash +... +type(fhash_tbl_t) :: tbl +``` + + +### The `fhash_key` interface + +A extensible interface for generating an instance of `[[fhash_key_t]]` needed to set and get key-value pairs. + +The library provides generic support for generating keys from scalar or 1D arrays of integers (`integer(int32)`, `integer(int64)`) or from scalar `character(*)` + +__e.g.__ *Create a key from a string* + +```fortran +use fhash, only: key=>fhash_key +... +key('key_string') +``` + +__For how to extend the `[[fhash_key_t]]` interface to other types, see the [custom key demo](|url|/page/3-custom-key-demo/index.html)__ + + + + +### The `[[fhash_tbl_t(type):set(bound)]]` method + +Stores (or overwrites) a key-value pair into the hash table. + +Will accept __any scalar variable__ as a value, including (scalar) derived types. + +__e.g.__ *Set key value pair* + +```fortran +use fhash, only: fhash_tbl_t, key=>fhash_key +... +type(fhash_tbl_t) :: tbl + +tbl%set(key('key'),value=1) +``` + +To store a pointer instead of copying the value, use `[[fhash_tbl_t(type):set_ptr(bound)]]`. + + +### The `[[fhash_tbl_t(type):get(bound)]]` method + +A generic interface for __retrieving intrinsic scalar__ values from the table. + +The library provides generic support for retrieving scalar values of the following types: + +- `integer(int32)`, `integer(int64)` +- `real(real32)`, `real(real64)` +- `character(*)` +- `logical` + +__e.g.__ *Get integer value for a key* + +```fortran +use fhash, only: fhash_tbl_t, key=>fhash_key +... +type(fhash_tbl_t) :: tbl +integer :: v + +tbl%get(key('key'),value=v) +``` + +An optional integer `stat` argument may be passed which is non-zero on exit if the retrieval was unsuccessful. Non-zero return values may be one of: `FHASH_KEY_NOT_FOUND`, `FHASH_FOUND_WRONG_TYPE`, or `FHASH_EMPTY_TABLE`. + +__For how to retrieve derived types see the [derived type demo](|url|/page/2-derived-type-demo/index.html).__ + +To retrieve a pointer instead of copying the value, use `[[fhash_tbl_t(type):get_ptr(bound)]]`. + + +### A simple example program +```fortran +{!app/0-simple-demo/main.f90!} +``` diff --git a/thirdparty/fhash/ford.md b/thirdparty/fhash/ford.md new file mode 100644 index 00000000..fc9a789f --- /dev/null +++ b/thirdparty/fhash/ford.md @@ -0,0 +1,11 @@ +project: fhash API Reference +src_dir: ./src/ +dbg: True +output_dir: ./api-doc +summary: An fpm package implementing a hash table with support for generic keys and values. +author: L. Kedward +author_description: +github: https://github.com/LKedward/fhash +page_dir: ./app/ + +{!README.md!} \ No newline at end of file diff --git a/thirdparty/fhash/fpm.toml b/thirdparty/fhash/fpm.toml new file mode 100644 index 00000000..bbaf2d39 --- /dev/null +++ b/thirdparty/fhash/fpm.toml @@ -0,0 +1,37 @@ +name="fhash" +version="0.1.0" +license="MIT" +author="Laurence Kedward" +maintainer="laurencekedward@gmail.com" +copyright="Laurence Kedward 2020" +description="Implements a hash table type with support for generic keys and values." + +[[executable]] +source-dir="app/0-simple-demo" +main="main.f90" +name="simple-demo" + +[[executable]] +source-dir="app/1-methods-demo" +main="main.f90" +name="methods-demo" + +[[executable]] +source-dir="app/2-derived-type-demo" +main="main.f90" +name="derived-type-demo" + +[[executable]] +source-dir="app/bench" +main="main.f90" +name="benchmark" + +[[executable]] +source-dir="app/3-custom-key-demo" +main="main.f90" +name="custom-key-demo" + +[[executable]] +source-dir="app/4-iter-demo" +main="main.f90" +name="iter-demo" diff --git a/thirdparty/fhash/src/CMakeLists.txt b/thirdparty/fhash/src/CMakeLists.txt new file mode 100644 index 00000000..ee5ada62 --- /dev/null +++ b/thirdparty/fhash/src/CMakeLists.txt @@ -0,0 +1,7 @@ +set(FHASH_SOURCES fhash.f90 fhash_sll.f90 fhash_data_container.f90 fhash_tbl.f90 fhash_tbl_iter.f90 fhash_fnv.f90 fhash_key/base.f90 fhash_key/int32.f90 fhash_key/int64.f90 fhash_key/char.f90 fhash_key/int32_1d.f90 fhash_key/int64_1d.f90) +add_library(fhash SHARED ${FHASH_SOURCES}) +target_include_directories(fhash PUBLIC + $ + $) +install(TARGETS fhash EXPORT fhash + LIBRARY DESTINATION lib ${CMAKE_INSTALL_LIBDIR}) diff --git a/thirdparty/fhash/src/fhash.f90 b/thirdparty/fhash/src/fhash.f90 new file mode 100644 index 00000000..6cb1f85c --- /dev/null +++ b/thirdparty/fhash/src/fhash.f90 @@ -0,0 +1,13 @@ +module fhash +use fhash_tbl, only: fhash_tbl_t +use fhash_tbl_iter, only: fhash_iter_t +use fhash_key_base, only: fhash_key_t +use fhash_key_char, only: fhash_key_char_t, fhash_key +use fhash_key_int32, only: fhash_key_int32_t, fhash_key +use fhash_key_int64, only: fhash_key_int64_t, fhash_key +use fhash_key_int32_1d, only: fhash_key_int32_1d_t, fhash_key +use fhash_key_int64_1d, only: fhash_key_int64_1d_t, fhash_key +implicit none + + +end module fhash \ No newline at end of file diff --git a/thirdparty/fhash/src/fhash_data_container.f90 b/thirdparty/fhash/src/fhash_data_container.f90 new file mode 100644 index 00000000..33b5f520 --- /dev/null +++ b/thirdparty/fhash/src/fhash_data_container.f90 @@ -0,0 +1,243 @@ +!> Implements simple container type +!> for polymorphic scalars and 1D arrays +module fhash_data_container + use iso_fortran_env, only: sp=>real32, dp=>real64, int32, int64 + implicit none + + private + public fhash_container_t + public fhash_container + + !> Generic container for scalar and 1D data + type fhash_container_t + + class(*), allocatable :: scalar_data + class(*), pointer :: scalar_ptr => NULL() + + contains + + procedure :: allocated => fhash_container_allocated + procedure :: get => fhash_container_get_scalar + procedure :: get_ptr => fhash_container_get_scalar_ptr + + end type fhash_container_t + + !> Create a fhash_container object from a polymorphic value + interface fhash_container + module procedure fhash_container_scalar + end interface fhash_container + +contains + + !> Helper to initialise a polymorphic data container with scalar + function fhash_container_scalar(value,pointer) result(container) + + !> Value to store + class(*), intent(in), target :: value + + !> If .true., store pointer to value instead of copying + logical, intent(in), optional :: pointer + + type(fhash_container_t) :: container + + if (present(pointer)) then + if (pointer) then + container%scalar_ptr => value + else + if (allocated(container%scalar_data)) deallocate(container%scalar_data) + allocate(container%scalar_data, source = value) + end if + else + if (allocated(container%scalar_data)) deallocate(container%scalar_data) + allocate(container%scalar_data, source = value) + end if + + end function fhash_container_scalar + + + !> Helper to determine if container contains anything + function fhash_container_allocated(container) result(alloc) + class(fhash_container_t), intent(in) :: container + logical :: alloc + + alloc = allocated(container%scalar_data) .OR. & + associated(container%scalar_ptr) + + end function fhash_container_allocated + + + !> Helper to return container value as intrinsic type + subroutine fhash_container_get_scalar(container,i32,i64,r32,r64,char,bool,raw,match,type_string) + class(fhash_container_t), intent(in), target :: container + integer(int32), intent(out), optional :: i32 + integer(int64), intent(out), optional :: i64 + real(sp), intent(out), optional :: r32 + real(dp), intent(out), optional :: r64 + character(:), allocatable, intent(out), optional :: char + logical, intent(out), optional :: bool + class(*), allocatable, intent(out), optional :: raw + logical, intent(out), optional :: match + character(:), allocatable, intent(out), optional :: type_string + + class(*), pointer :: data + + if (present(match)) match = .false. + + if (.not.container%allocated()) return + + if (allocated(container%scalar_data)) then + data => container%scalar_data + else + data => container%scalar_ptr + end if + + if (present(raw)) then + if (present(match)) match = .true. + allocate(raw, source=data) + end if + + select type(d=>data) + type is(integer(int32)) + if (present(type_string)) type_string = 'integer32' + if (present(i32)) then + if (present(match)) match = .true. + i32 = d + return + end if + + type is (integer(int64)) + if (present(type_string)) type_string = 'integer64' + if (present(i64)) then + if (present(match)) match = .true. + i64 = d + return + end if + + type is (real(sp)) + if (present(type_string)) type_string = 'real32' + if (present(r32)) then + if (present(match)) match = .true. + r32 = d + return + end if + + type is (real(dp)) + if (present(type_string)) type_string = 'real64' + if (present(r64)) then + if (present(match)) match = .true. + r64 = d + return + end if + + type is (character(*)) + if (present(type_string)) type_string = 'character*' + if (present(char)) then + if (present(match)) match = .true. + char = d + return + end if + + type is (logical) + if (present(type_string)) type_string = 'logical' + if (present(bool)) then + if (present(match)) match = .true. + bool = d + return + end if + + class default + if (present(type_string)) type_string = 'unknown' + + end select + + end subroutine fhash_container_get_scalar + + + !> Helper to return pointer to container value as intrinsic type + subroutine fhash_container_get_scalar_ptr(container,i32,i64,r32,r64,char,bool,raw,match,type_string) + class(fhash_container_t), intent(in), target :: container + integer(int32), pointer, intent(out), optional :: i32 + integer(int64), pointer, intent(out), optional :: i64 + real(sp), pointer, intent(out), optional :: r32 + real(dp), pointer, intent(out), optional :: r64 + character(:), pointer, intent(out), optional :: char + logical, pointer, intent(out), optional :: bool + class(*), pointer, intent(out), optional :: raw + logical, intent(out), optional :: match + character(:), allocatable, intent(out), optional :: type_string + + class(*), pointer :: data + + if (present(match)) match = .false. + + if (.not.container%allocated()) return + + if (allocated(container%scalar_data)) then + data => container%scalar_data + else + data => container%scalar_ptr + end if + + if (present(raw)) then + if (present(match)) match = .true. + raw => data + end if + + select type(d=>data) + type is(integer(int32)) + if (present(i32)) then + if (present(match)) match = .true. + if (present(type_string)) type_string = 'integer32' + i32 => d + return + end if + + type is (integer(int64)) + if (present(i64)) then + if (present(match)) match = .true. + if (present(type_string)) type_string = 'integer64' + i64 => d + return + end if + + type is (real(sp)) + if (present(r32)) then + if (present(match)) match = .true. + if (present(type_string)) type_string = 'real32' + r32 => d + return + end if + + type is (real(dp)) + if (present(r64)) then + if (present(match)) match = .true. + if (present(type_string)) type_string = 'real64' + r64 => d + return + end if + + type is (character(*)) + if (present(char)) then + if (present(match)) match = .true. + if (present(type_string)) type_string = 'character*' + char => d + return + end if + + type is (logical) + if (present(bool)) then + if (present(match)) match = .true. + if (present(type_string)) type_string = 'logical' + bool => d + return + end if + + class default + if (present(type_string)) type_string = 'unknown' + + end select + + end subroutine fhash_container_get_scalar_ptr + + +end module fhash_data_container \ No newline at end of file diff --git a/thirdparty/fhash/src/fhash_fnv.f90 b/thirdparty/fhash/src/fhash_fnv.f90 new file mode 100644 index 00000000..4e9d9c37 --- /dev/null +++ b/thirdparty/fhash/src/fhash_fnv.f90 @@ -0,0 +1,193 @@ +!> A module for Fowler–Noll–Vo (FNV) hashing +!> +!> Implements the FNV 1a algorithm for 32bit hashes +!> +!> Supports hashing of: +!> - 32bit integers (scalar & 1D array) +!> - 64bit integers (scalar & 1D array) +!> - character(*), default kind +!> +!> The lack of unsigned arithmetic in Fortran means that +!> 64bit arithmetic is needed to perform 32bit hashing. +!> Hashes are therefore returned as int64. +!> +module fhash_fnv + use iso_fortran_env, only: int32, int64 + use iso_c_binding, only: c_char + implicit none + + private + public :: fnv_1a, hash_string + + !> Starting seed + integer(int64), parameter :: FNV_OFFSET_32 = 2166136261_int64 + + !> Hashing prime + integer(int64), parameter :: FNV_PRIME_32 = 16777619_int64 + + !> Generic interface to perform hashing + !> + !> Usage: + !>```fortran + !> fnv_1a([seed],input) + !>``` + !> where `input` is any of the supported types + interface fnv_1a + module procedure fnv_1a_char_scalar + module procedure fnv_1a_char_scalar_seed + module procedure fnv_1a_int32_scalar + module procedure fnv_1a_int32_scalar_seed + module procedure fnv_1a_int32_1d + module procedure fnv_1a_int32_1d_seed + module procedure fnv_1a_int64_scalar + module procedure fnv_1a_int64_scalar_seed + module procedure fnv_1a_int64_1d + module procedure fnv_1a_int64_1d_seed + end interface fnv_1a + +contains + + + !> Hash a single default kind character variable + pure function fnv_1a_char_scalar(input) result(hash) + character(*), intent(in) :: input + integer(int64) :: hash + + hash = fnv_1a(FNV_OFFSET_32,input) + + end function fnv_1a_char_scalar + + + !> Hash a character(*) string of default kind + pure function fnv_1a_char_scalar_seed(seed, input) result(hash) + integer(int64), intent(in) :: seed + character(*), intent(in) :: input + integer(int64) :: hash + + integer :: i + integer(int64) :: item + + hash = seed + + do i=1,len(input) + item = transfer([iachar(input(i:i),int32),0_int32],item) + hash = ieor(hash,item) * fnv_prime_32 + end do + + end function fnv_1a_char_scalar_seed + + + !> Hash a single 32bit integer + pure function fnv_1a_int32_scalar(input) result(hash) + integer(int32), intent(in) :: input + integer(int64) :: hash + + hash = fnv_1a(FNV_OFFSET_32,input) + + end function fnv_1a_int32_scalar + + + !> Hash a single 32bit integer with a starting seed + pure function fnv_1a_int32_scalar_seed(seed,input) result(hash) + integer(int64), intent(in) :: seed + integer(int32), intent(in) :: input + integer(int64) :: hash + + character(len=4,kind=c_char) :: chars + + chars = transfer(input,chars) + + hash = fnv_1a(seed,chars) + + end function fnv_1a_int32_scalar_seed + + + !> Hash a 1D array of 32bit integers + pure function fnv_1a_int32_1d(input) result(hash) + integer(int32), intent(in) :: input(:) + integer(int64) :: hash + + hash = fnv_1a(FNV_OFFSET_32,input) + + end function fnv_1a_int32_1d + + + !> Hash a 1D array of 32bit integers with a starting seed + pure function fnv_1a_int32_1d_seed(seed,input) result(hash) + integer(int64), intent(in) :: seed + integer(int32), intent(in) :: input(:) + integer(int64) :: hash + + integer :: i + + hash = seed + do i=1,size(input) + hash = fnv_1a(hash,input(i)) + end do + + end function fnv_1a_int32_1d_seed + + + !> Hash a single 64bit integer + pure function fnv_1a_int64_scalar(input) result(hash) + integer(int64), intent(in) :: input + integer(int64) :: hash + + hash = fnv_1a(FNV_OFFSET_32,input) + + end function fnv_1a_int64_scalar + + + !> Hash a single 64bit integer with a starting seed + pure function fnv_1a_int64_scalar_seed(seed,input) result(hash) + integer(int64), intent(in) :: seed + integer(int64), intent(in) :: input + integer(int64) :: hash + + character(len=8,kind=c_char) :: chars + + chars = transfer(input,chars) + + hash = fnv_1a(seed,chars) + + end function fnv_1a_int64_scalar_seed + + + !> Hash a 1D array of 64bit integers + pure function fnv_1a_int64_1d(input) result(hash) + integer(int64), intent(in) :: input(:) + integer(int64) :: hash + + hash = fnv_1a(FNV_OFFSET_32,input) + + end function fnv_1a_int64_1d + + + !> Hash a 1D array of 64bit integers with a starting seed + pure function fnv_1a_int64_1d_seed(seed,input) result(hash) + integer(int64), intent(in) :: seed + integer(int64), intent(in) :: input(:) + integer(int64) :: hash + + integer :: i + + hash = seed + do i=1,size(input) + hash = fnv_1a(hash,input(i)) + end do + + end function fnv_1a_int64_1d_seed + + + !> Help fcn to convert hash to hex representation + function hash_string(hash_value) result(str) + integer(int64), intent(in) :: hash_value + character(:), allocatable :: str + + allocate(character(len=10) :: str) + write(str,'(Z0)') int(hash_value,int32) + + end function hash_string + + +end module fhash_fnv \ No newline at end of file diff --git a/thirdparty/fhash/src/fhash_key/base.f90 b/thirdparty/fhash/src/fhash_key/base.f90 new file mode 100644 index 00000000..bc49f468 --- /dev/null +++ b/thirdparty/fhash/src/fhash_key/base.f90 @@ -0,0 +1,42 @@ +!> Implements an abstract type for hash keys +!> +module fhash_key_base + use iso_fortran_env, only: int32, int64 + implicit none + + private + public fhash_key_t + + !> Abstract base type for defining hash keys + type, abstract :: fhash_key_t + contains + procedure(hash_proc), deferred :: hash + procedure(equality_proc), deferred :: equals + procedure(to_string_proc), deferred :: to_string + generic, public :: operator(==) => equals + end type fhash_key_t + + abstract interface + + pure function equality_proc(key1,key2) result(keys_equal) + import + class(fhash_key_t), intent(in) :: key1 + class(fhash_key_t), intent(in) :: key2 + logical :: keys_equal + end function equality_proc + + pure function hash_proc(key) result(hash) + import + class(fhash_key_t), intent(in) :: key + integer(int64) :: hash + end function hash_proc + + function to_string_proc(key) result(str) + import + class(fhash_key_t), intent(in) :: key + character(:), allocatable :: str + end function to_string_proc + + end interface + +end module fhash_key_base \ No newline at end of file diff --git a/thirdparty/fhash/src/fhash_key/char.f90 b/thirdparty/fhash/src/fhash_key/char.f90 new file mode 100644 index 00000000..4c790858 --- /dev/null +++ b/thirdparty/fhash/src/fhash_key/char.f90 @@ -0,0 +1,81 @@ +!> Implements a concrete type for scalar int32 hash keys +!> +module fhash_key_char + use iso_fortran_env, only: int32, int64 + use fhash_key_base, only: fhash_key_t + use fhash_fnv, only: fnv_1a + implicit none + + private + public fhash_key_char_t + public fhash_key + + !> Hash table key container + type, extends(fhash_key_t) :: fhash_key_char_t + private + character(:), allocatable :: value + contains + procedure, pass :: hash => key_hash_char + procedure, pass :: equals => key_equal_char + procedure, pass :: to_string => key_char_to_string + end type fhash_key_char_t + + interface fhash_key + module procedure :: key_from_char + end interface fhash_key + + contains + + + !> Check if two keys are equal + pure function key_equal_char(key1,key2) result(keys_equal) + class(fhash_key_char_t), intent(in) :: key1 + class(fhash_key_t), intent(in) :: key2 + logical :: keys_equal + + keys_equal = .false. + + select type(k2=>key2) + type is (fhash_key_char_t) + if (allocated(key1%value) .and. allocated(k2%value)) then + if (key1%value == k2%value) then + keys_equal = .true. + return + end if + end if + end select + + end function key_equal_char + + + !> Generate hash of key + pure function key_hash_char(key) result(hash) + class(fhash_key_char_t), intent(in) :: key + integer(int64) :: hash + + hash = fnv_1a(key%value) + + end function key_hash_char + + + !> Generate string representation of hash + function key_char_to_string(key) result(str) + class(fhash_key_char_t), intent(in) :: key + character(:), allocatable :: str + + str = key%value + + end function key_char_to_string + + + !> Create new key container from a scalar int32 + function key_from_char(source) result(key) + character(*), intent(in) :: source + type(fhash_key_char_t) :: key + + key%value = source + + end function key_from_char + + +end module fhash_key_char \ No newline at end of file diff --git a/thirdparty/fhash/src/fhash_key/int32.f90 b/thirdparty/fhash/src/fhash_key/int32.f90 new file mode 100644 index 00000000..1b67ce81 --- /dev/null +++ b/thirdparty/fhash/src/fhash_key/int32.f90 @@ -0,0 +1,81 @@ +!> Implements a concrete type for scalar int32 hash keys +!> +module fhash_key_int32 + use iso_fortran_env, only: int32, int64 + use fhash_key_base, only:fhash_key_t + use fhash_fnv, only: fnv_1a + implicit none + + private + public fhash_key_int32_t + public fhash_key + + !> Hash table key container + type, extends(fhash_key_t) :: fhash_key_int32_t + private + integer(int32) :: value + contains + procedure, pass :: hash => key_hash_int32 + procedure, pass :: equals => key_equal_int32 + procedure, pass :: to_string => key_int32_to_string + end type fhash_key_int32_t + + interface fhash_key + module procedure :: key_from_int32 + end interface fhash_key + +contains + + + !> Check if two keys are equal + pure function key_equal_int32(key1,key2) result(keys_equal) + class(fhash_key_int32_t), intent(in) :: key1 + class(fhash_key_t), intent(in) :: key2 + logical :: keys_equal + + keys_equal = .false. + + select type(k2=>key2) + type is (fhash_key_int32_t) + if (key1%value == k2%value) then + keys_equal = .true. + return + end if + end select + + end function key_equal_int32 + + + !> Generate hash of key + pure function key_hash_int32(key) result(hash) + class(fhash_key_int32_t), intent(in) :: key + integer(int64) :: hash + + hash = fnv_1a(key%value) + + end function key_hash_int32 + + + !> Generate string representation of hash + pure function key_int32_to_string(key) result(str) + class(fhash_key_int32_t), intent(in) :: key + character(:), allocatable :: str + + allocate(character(1024) :: str) + write(str,*) key%value + str = trim(str) + + end function key_int32_to_string + + + !> Create new key container from a scalar int32 + function key_from_int32(source) result(key) + integer(int32), intent(in) :: source + type(fhash_key_int32_t) :: key + + key%value = source + + end function key_from_int32 + + +end module fhash_key_int32 \ No newline at end of file diff --git a/thirdparty/fhash/src/fhash_key/int32_1d.f90 b/thirdparty/fhash/src/fhash_key/int32_1d.f90 new file mode 100644 index 00000000..35d5645a --- /dev/null +++ b/thirdparty/fhash/src/fhash_key/int32_1d.f90 @@ -0,0 +1,87 @@ +!> Implements a concrete type for 1D int32 array hash keys +!> +module fhash_key_int32_1d + use iso_fortran_env, only: int32, int64 + use fhash_key_base, only: fhash_key_t + use fhash_fnv, only: fnv_1a + implicit none + + private + public fhash_key_int32_1d_t + public fhash_key + + !> Hash table key container + type, extends(fhash_key_t) :: fhash_key_int32_1d_t + private + integer(int32), allocatable :: value(:) + contains + procedure, pass :: hash => key_hash_int32_1d + procedure, pass :: equals => key_equal_int32_1d + procedure, pass :: to_string => key_int32_1d_to_string + end type fhash_key_int32_1d_t + + interface fhash_key + module procedure :: key_from_int32_1d + end interface fhash_key + +contains + + + !> Check if two keys are equal + pure function key_equal_int32_1d(key1,key2) result(keys_equal) + class(fhash_key_int32_1d_t), intent(in) :: key1 + class(fhash_key_t), intent(in) :: key2 + logical :: keys_equal + + keys_equal = .false. + + select type(k2=>key2) + type is (fhash_key_int32_1d_t) + if (.not.(allocated(key1%value) .and. allocated(k2%value))) then + return + end if + if (size(key1%value) /= size(k2%value)) then + return + end if + if (all(key1%value == k2%value)) then + keys_equal = .true. + return + end if + end select + + end function key_equal_int32_1d + + + !> Generate hash of key + pure function key_hash_int32_1d(key) result(hash) + class(fhash_key_int32_1d_t), intent(in) :: key + integer(int64) :: hash + + hash = fnv_1a(key%value) + + end function key_hash_int32_1d + + + !> Generate string representation of hash + pure function key_int32_1d_to_string(key) result(str) + class(fhash_key_int32_1d_t), intent(in) :: key + character(:), allocatable :: str + + allocate(character(1024) :: str) + write(str,*) key%value + str = trim(str) + + end function key_int32_1d_to_string + + + !> Create new key container from a scalar int32 + function key_from_int32_1d(source) result(key) + integer(int32), intent(in) :: source(:) + type(fhash_key_int32_1d_t) :: key + + key%value = source + + end function key_from_int32_1d + + +end module fhash_key_int32_1d \ No newline at end of file diff --git a/thirdparty/fhash/src/fhash_key/int64.f90 b/thirdparty/fhash/src/fhash_key/int64.f90 new file mode 100644 index 00000000..2c55a46a --- /dev/null +++ b/thirdparty/fhash/src/fhash_key/int64.f90 @@ -0,0 +1,81 @@ +!> Implements a concrete type for scalar int64 hash keys +!> +module fhash_key_int64 + use iso_fortran_env, only: int64 + use fhash_key_base, only:fhash_key_t + use fhash_fnv, only: fnv_1a + implicit none + + private + public fhash_key_int64_t + public fhash_key + + !> Hash table key container + type, extends(fhash_key_t) :: fhash_key_int64_t + private + integer(int64) :: value + contains + procedure, pass :: hash => key_hash_int64 + procedure, pass :: equals => key_equal_int64 + procedure, pass :: to_string => key_int64_to_string + end type fhash_key_int64_t + + interface fhash_key + module procedure :: key_from_int64 + end interface fhash_key + +contains + + + !> Check if two keys are equal + pure function key_equal_int64(key1,key2) result(keys_equal) + class(fhash_key_int64_t), intent(in) :: key1 + class(fhash_key_t), intent(in) :: key2 + logical :: keys_equal + + keys_equal = .false. + + select type(k2=>key2) + type is (fhash_key_int64_t) + if (key1%value == k2%value) then + keys_equal = .true. + return + end if + end select + + end function key_equal_int64 + + + !> Generate hash of key + pure function key_hash_int64(key) result(hash) + class(fhash_key_int64_t), intent(in) :: key + integer(int64) :: hash + + hash = fnv_1a(key%value) + + end function key_hash_int64 + + + !> Generate string representation of hash + pure function key_int64_to_string(key) result(str) + class(fhash_key_int64_t), intent(in) :: key + character(:), allocatable :: str + + allocate(character(1024) :: str) + write(str,*) key%value + str = trim(str) + + end function key_int64_to_string + + + !> Create new key container from a scalar int64 + function key_from_int64(source) result(key) + integer(int64), intent(in) :: source + type(fhash_key_int64_t) :: key + + key%value = source + + end function key_from_int64 + + +end module fhash_key_int64 \ No newline at end of file diff --git a/thirdparty/fhash/src/fhash_key/int64_1d.f90 b/thirdparty/fhash/src/fhash_key/int64_1d.f90 new file mode 100644 index 00000000..58c473ea --- /dev/null +++ b/thirdparty/fhash/src/fhash_key/int64_1d.f90 @@ -0,0 +1,87 @@ +!> Implements a concrete type for 1D int64 array hash keys +!> +module fhash_key_int64_1d + use iso_fortran_env, only: int64 + use fhash_key_base, only: fhash_key_t + use fhash_fnv, only: fnv_1a + implicit none + + private + public fhash_key_int64_1d_t + public fhash_key + + !> Hash table key container + type, extends(fhash_key_t) :: fhash_key_int64_1d_t + private + integer(int64), allocatable :: value(:) + contains + procedure, pass :: hash => key_hash_int64_1d + procedure, pass :: equals => key_equal_int64_1d + procedure, pass :: to_string => key_int64_1d_to_string + end type fhash_key_int64_1d_t + + interface fhash_key + module procedure :: key_from_int64_1d + end interface fhash_key + +contains + + + !> Check if two keys are equal + pure function key_equal_int64_1d(key1,key2) result(keys_equal) + class(fhash_key_int64_1d_t), intent(in) :: key1 + class(fhash_key_t), intent(in) :: key2 + logical :: keys_equal + + keys_equal = .false. + + select type(k2=>key2) + type is (fhash_key_int64_1d_t) + if (.not.(allocated(key1%value) .and. allocated(k2%value))) then + return + end if + if (size(key1%value) /= size(k2%value)) then + return + end if + if (all(key1%value == k2%value)) then + keys_equal = .true. + return + end if + end select + + end function key_equal_int64_1d + + + !> Generate hash of key + pure function key_hash_int64_1d(key) result(hash) + class(fhash_key_int64_1d_t), intent(in) :: key + integer(int64) :: hash + + hash = fnv_1a(key%value) + + end function key_hash_int64_1d + + + !> Generate string representation of hash + pure function key_int64_1d_to_string(key) result(str) + class(fhash_key_int64_1d_t), intent(in) :: key + character(:), allocatable :: str + + allocate(character(1024) :: str) + write(str,*) key%value + str = trim(str) + + end function key_int64_1d_to_string + + + !> Create new key container from a scalar int64 + function key_from_int64_1d(source) result(key) + integer(int64), intent(in) :: source(:) + type(fhash_key_int64_1d_t) :: key + + key%value = source + + end function key_from_int64_1d + + +end module fhash_key_int64_1d \ No newline at end of file diff --git a/thirdparty/fhash/src/fhash_sll.f90 b/thirdparty/fhash/src/fhash_sll.f90 new file mode 100644 index 00000000..d754467e --- /dev/null +++ b/thirdparty/fhash/src/fhash_sll.f90 @@ -0,0 +1,285 @@ +!> Implements singly-linked list (sll) node with generic data container +!> +module fhash_sll + use iso_fortran_env, only: int32, int64 + use fhash_key_base, only: fhash_key_t + use fhash_data_container, only: fhash_container_t + implicit none + + !> Node type for hash table singly linked list + type fhash_node_t + + class(fhash_key_t), allocatable :: key + type(fhash_container_t) :: value + type(fhash_node_t), pointer :: next => NULL() + + end type fhash_node_t + +contains + + !> Append node to SLL + recursive subroutine sll_push_node(node,key,value,pointer) + + !> Node to which to add data + type(fhash_node_t), intent(inout) :: node + + !> Key to add + class(fhash_key_t), intent(in) :: key + + !> Value to add + class(*), intent(in), target :: value + + !> Store only a point if .true. + logical, intent(in), optional :: pointer + + + if (allocated(node%key)) then + + if (node%key == key) then + + call sll_node_set(node,value,pointer) + return + + end if + + if (.not.associated(node%next)) then + allocate(node%next) + end if + + call sll_push_node(node%next,key,value,pointer) + + else + + node%key = key + call sll_node_set(node,value,pointer) + + end if + + end subroutine sll_push_node + + + !> Set container value in node + !> + subroutine sll_node_set(node,value,pointer) + + !> Node to which to add data + type(fhash_node_t), intent(inout) :: node + + !> Value to set + class(*), intent(in), target :: value + + !> Store only a pointer if .true. + logical, intent(in), optional :: pointer + + if (present(pointer)) then + if (pointer) then + node%value%scalar_ptr => value + return + end if + end if + + if (allocated(node%value%scalar_data)) deallocate(node%value%scalar_data) + allocate(node%value%scalar_data, source = value) + + end subroutine sll_node_set + + + !> Search for a node with a specific key. + !> Returns a pointer to the 'data' component of the corresponding node. + !> Pointer is not associated if node cannot be found + recursive subroutine sll_find_in(node,key,data,found) + + !> Node to search in + type(fhash_node_t), intent(in), target :: node + + !> Key to look for + class(fhash_key_t) :: key + + !> Pointer to value container if found. + !> (Unassociated if the key is not found in node) + type(fhash_container_t), pointer, intent(out) :: data + + logical, intent(out), optional :: found + + data => NULL() + + if (present(found)) found = .false. + + if (.not.allocated(node%key)) then + + return + + else if (node%key == key) then + + if (present(found)) found = .true. + data => node%value + return + + else if (associated(node%next)) then + + call sll_find_in(node%next,key,data,found) + + end if + + end subroutine sll_find_in + + + !> Return a node at a specific depth in the sll + recursive subroutine sll_get_at(node,depth,key,data,found) + + !> Node to search in + type(fhash_node_t), intent(in), target :: node + + !> Node depth to access + integer, intent(in) :: depth + + !> Key of found item + !> (Unallocated if no node is found at specified depth) + class(fhash_key_t), intent(out), allocatable :: key + + !> Pointer to value container if found. + !> (Unassociated if no node is found at specified depth) + type(fhash_container_t), pointer, intent(out) :: data + + logical, intent(out), optional :: found + + data => NULL() + + if (present(found)) found = .false. + + if (.not.allocated(node%key)) then + + return + + else if (depth == 1) then + + if (present(found)) found = .true. + key = node%key + data => node%value + return + + else if (associated(node%next)) then + + call sll_get_at(node%next,depth-1,key,data,found) + + end if + + end subroutine sll_get_at + + + !> Search for a node with a specific key and remove + recursive subroutine sll_remove(node,key,found,parent_node) + + !> Node to remove from + type(fhash_node_t), intent(inout) :: node + + !> Key to remove + class(fhash_key_t) :: key + + !> Indicates if the key was found in node and removed + logical, optional, intent(out) :: found + + !> Used internally + type(fhash_node_t), intent(inout), optional :: parent_node + + type(fhash_node_t), pointer :: next_temp + + if (present(found)) then + found = .false. + end if + + if (.not.allocated(node%key)) then + + return + + else if (node%key == key) then + + if (present(found)) then + found = .true. + end if + + if (.not.present(parent_node)) then + ! This is the top-level node + if (associated(node%next)) then + ! Replace with next + next_temp => node%next + node = next_temp + deallocate(next_temp) + return + else + ! No children, just deallocate + deallocate(node%key) + return + end if + + else + ! Not top-level node + if (associated(node%next)) then + ! Join previous with next + next_temp => node%next + deallocate(parent_node%next) + parent_node%next => next_temp + return + else + ! No children, just deallocate + deallocate(node%key) + deallocate(parent_node%next) + return + end if + end if + + else if (associated(node%next)) then + ! Look further down + call sll_remove(node%next,key,found,node) + + end if + + end subroutine sll_remove + + + !> Deallocate node components and those of its children + recursive subroutine sll_clean(node) + + !> Node to search in + type(fhash_node_t), intent(inout) :: node + + if (associated(node%next)) then + + call sll_clean(node%next) + deallocate(node%next) + + end if + + end subroutine sll_clean + + + !> Determine depth of SLL + function node_depth(node) result(depth) + + !> Node to check depth + type(fhash_node_t), intent(in), target :: node + + integer :: depth + + type(fhash_node_t), pointer :: current + + if (.not.allocated(node%key)) then + + depth = 0 + return + + else + + depth = 1 + current => node + do while(associated(current%next)) + depth = depth + 1 + current => current%next + end do + + end if + + end function node_depth + + +end module fhash_sll \ No newline at end of file diff --git a/thirdparty/fhash/src/fhash_tbl.f90 b/thirdparty/fhash/src/fhash_tbl.f90 new file mode 100644 index 00000000..126e2084 --- /dev/null +++ b/thirdparty/fhash/src/fhash_tbl.f90 @@ -0,0 +1,597 @@ +module fhash_tbl + use iso_fortran_env, only: int32, int64, sp=>real32, dp=>real64 + use fhash_data_container, only: fhash_container + use fhash_sll + implicit none + + private + public fhash_tbl_t + + !> This condition should be unreachable by the public interface + integer, parameter, public :: FHASH_INTERNAL_ERROR = -4 + + !> Error flag for operating on an unallocated table + integer, parameter, public :: FHASH_EMPTY_TABLE = -3 + + !> Error flag for when retrieved data-type does not + !> match that expected by the invoked getter function + !> (`get_int32`,`get_int63`,`get_float`,'get_double`,`get_char`) + integer, parameter, public :: FHASH_FOUND_WRONG_TYPE = -2 + + !> Error flag for when specified key is not found in the hash table + integer, parameter, public :: FHASH_KEY_NOT_FOUND = -1 + + !> Default allocation size + integer, parameter :: FHASH_DEFAULT_ALLOCATION = 127 + + type fhash_tbl_t + + type(fhash_node_t), allocatable :: buckets(:) + + contains + + procedure :: allocate => fhash_tbl_allocate + procedure :: unset => fhash_tbl_unset + procedure :: check_key => fhash_tbl_check_key + procedure :: stats => fhash_tbl_stats + + procedure :: fhash_tbl_set_scalar + generic :: set => fhash_tbl_set_scalar + + procedure :: fhash_tbl_set_scalar_ptr + generic :: set_ptr => fhash_tbl_set_scalar_ptr + + procedure :: fhash_tbl_get_int32, fhash_tbl_get_int64 + procedure :: fhash_tbl_get_float, fhash_tbl_get_double + procedure :: fhash_tbl_get_char,fhash_tbl_get_logical + procedure :: fhash_tbl_get_data,fhash_tbl_get_raw + + generic :: get => fhash_tbl_get_int32, fhash_tbl_get_int64 + generic :: get => fhash_tbl_get_float, fhash_tbl_get_double + generic :: get => fhash_tbl_get_char, fhash_tbl_get_logical + generic :: get => fhash_tbl_get_data + generic :: get_raw => fhash_tbl_get_raw + + procedure :: fhash_tbl_get_int32_ptr, fhash_tbl_get_int64_ptr + procedure :: fhash_tbl_get_float_ptr, fhash_tbl_get_double_ptr + procedure :: fhash_tbl_get_char_ptr,fhash_tbl_get_logical_ptr + procedure :: fhash_tbl_get_raw_ptr + + generic :: get_ptr => fhash_tbl_get_int32_ptr, fhash_tbl_get_int64_ptr + generic :: get_ptr => fhash_tbl_get_float_ptr, fhash_tbl_get_double_ptr + generic :: get_ptr => fhash_tbl_get_char_ptr, fhash_tbl_get_logical_ptr + generic :: get_raw_ptr => fhash_tbl_get_raw_ptr + + final :: fhash_tbl_cleanup + + end type fhash_tbl_t + +contains + +!> Allocate hash table +subroutine fhash_tbl_allocate(tbl,size) + + !> Table object to allocate + class(fhash_tbl_t), intent(inout) :: tbl + + !> Number of buckets in hash table + !> If ommited, `tbl` is allocated with `FHASH_DEFAULT_ALLOCATION` + integer, intent(in), optional :: size + + if (present(size)) then + allocate(tbl%buckets(size)) + else + allocate(tbl%buckets(FHASH_DEFAULT_ALLOCATION)) + end if + +end subroutine fhash_tbl_allocate + + +!> Finalizer for fhash_tbl_t +subroutine fhash_tbl_cleanup(tbl) + + !> Table object to allocate + type(fhash_tbl_t), intent(inout) :: tbl + + integer :: i + + if (.not.allocated(tbl%buckets)) return + + do i=1,size(tbl%buckets) + + call sll_clean(tbl%buckets(i)) + + end do + +end subroutine fhash_tbl_cleanup + + +!> Unset a value in the table +!> +subroutine fhash_tbl_unset(tbl,key,stat) + + !> Hash table object + class(fhash_tbl_t), intent(inout) :: tbl + + !> Key to remove + class(fhash_key_t), intent(in) :: key + + !> Status flag. Zero if successful. + !> Unsuccessful: FHASH_EMPTY_TABLE | `FHASH_KEY_NOT_FOUND` + integer, intent(out), optional :: stat + + integer :: index + logical :: found + + if (present(stat)) stat = 0 + + if (.not.allocated(tbl%buckets)) then + if (present(stat)) stat = FHASH_EMPTY_TABLE + return + end if + + index = modulo(key%hash(),size(tbl%buckets,kind=int64)) + 1 + call sll_remove(tbl%buckets(index),key,found) + + if (present(stat)) stat = merge(0,FHASH_KEY_NOT_FOUND,found) + +end subroutine fhash_tbl_unset + + +!> Check if key exists in table +subroutine fhash_tbl_check_key(tbl,key,stat) + + !> Hash table object + class(fhash_tbl_t), intent(in) :: tbl + + !> Key to retrieve + class(fhash_key_t), intent(in) :: key + + !> Status flag. Zero if key is found. + !> Unsuccessful: `FHASH_EMPTY_TABLE` | `FHASH_KEY_NOT_FOUND` + integer, intent(out) :: stat + + integer :: index + logical :: found + type(fhash_container_t), pointer :: data + + if (.not.allocated(tbl%buckets)) then + stat = FHASH_EMPTY_TABLE + return + end if + + stat = 0 + + index = modulo(key%hash(),size(tbl%buckets,kind=int64)) + 1 + + call sll_find_in(tbl%buckets(index),key,data,found) + + stat = merge(0,FHASH_KEY_NOT_FOUND,found) + + return + +end subroutine fhash_tbl_check_key + + +!> Get stats about the hash table +subroutine fhash_tbl_stats(tbl,num_buckets,num_items,num_collisions,max_depth) + + !> Hash table object + class(fhash_tbl_t), intent(in) :: tbl + + !> Number of buckets allocated in table + integer, intent(out), optional :: num_buckets + + !> Number of key-value pairs stored in table + integer, intent(out), optional :: num_items + + !> Number of hash collisions + integer, intent(out), optional :: num_collisions + + !> Maximum depth of bucket in table + integer, intent(out), optional :: max_depth + + integer :: i, depth + + ! Initialise stats + if (present(num_items)) num_items = 0 + if (present(num_collisions)) num_collisions = 0 + if (present(max_depth)) max_depth = 0 + if (present(num_buckets)) num_buckets = 0 + + if (.not.allocated(tbl%buckets)) return + + if (present(num_buckets)) then + num_buckets = size(tbl%buckets) + end if + + do i=1,size(tbl%buckets) + + depth = node_depth(tbl%buckets(i)) + + if (present(num_items)) num_items = num_items + depth + + if (present(num_collisions)) num_collisions = num_collisions + & + merge(depth-1,0,depth > 1) + + if (present(max_depth)) max_depth = max(max_depth,depth) + + end do + +end subroutine fhash_tbl_stats + + +!> Set/update a polymorphic scalar value in the table +!> +!> `tbl` is allocated with default size if not already allocated +subroutine fhash_tbl_set_scalar(tbl,key,value,pointer) + + !> Hash table object + class(fhash_tbl_t), intent(inout) :: tbl + + !> Key to set/update + class(fhash_key_t), intent(in) :: key + + !> Value for key + class(*), intent(in), target :: value + + !> If .true., store a pointer to value instead of copying + logical, intent(in), optional :: pointer + + integer :: index + + if (.not.allocated(tbl%buckets)) call fhash_tbl_allocate(tbl) + + index = modulo(key%hash(),size(tbl%buckets,kind=int64)) + 1 + + call sll_push_node(tbl%buckets(index),key,value,pointer) + +end subroutine fhash_tbl_set_scalar + + +!> Get wrapper routine for generic 'set_ptr' +!> +!> `tbl` is allocated with default size if not already allocated +subroutine fhash_tbl_set_scalar_ptr(tbl,key,value) + + !> Hash table object + class(fhash_tbl_t), intent(inout) :: tbl + + !> Key to set/update + class(fhash_key_t), intent(in) :: key + + !> Value for key + class(*), intent(in), target :: value + + call fhash_tbl_set_scalar(tbl,key,value,pointer=.true.) + +end subroutine fhash_tbl_set_scalar_ptr + + + +!> Retrieve data container from the hash table +subroutine fhash_tbl_get_data(tbl,key,data,stat) + + !> Hash table object + class(fhash_tbl_t), intent(in) :: tbl + + !> Key to retrieve + class(fhash_key_t), intent(in) :: key + + !> Copy of value retrieved for key + type(fhash_container_t), pointer :: data + + !> Status flag. Zero if successful. + !> Unsuccessful: `FHASH_EMPTY_TABLE` | `FHASH_KEY_NOT_FOUND` + integer, intent(out), optional :: stat + + integer :: index + logical :: found + + if (.not.allocated(tbl%buckets)) then + if (present(stat)) stat = FHASH_EMPTY_TABLE + return + end if + + if (present(stat)) stat = 0 + + index = modulo(key%hash(),size(tbl%buckets,kind=int64)) + 1 + + call sll_find_in(tbl%buckets(index),key,data,found) + + if (.not.found) then + + if (present(stat)) stat = FHASH_KEY_NOT_FOUND + return + + end if + +end subroutine fhash_tbl_get_data + + + +!> Get wrapper to retrieve a scalar intrinsic type value +subroutine fhash_tbl_get_intrinsic_scalar(tbl,key,i32,i64,r32,r64,char,raw,bool,stat) + + !> Hash table object + class(fhash_tbl_t), intent(in) :: tbl + + !> Key to retrieve + class(fhash_key_t), intent(in) :: key + + !> Value to retrieve + integer(int32), intent(out), optional :: i32 + integer(int64), intent(out), optional :: i64 + real(sp), intent(out), optional :: r32 + real(dp), intent(out), optional :: r64 + character(:), allocatable, intent(out), optional :: char + logical, intent(out), optional :: bool + class(*), allocatable, intent(out), optional :: raw + + !> Status flag. Zero if successful. + !> Unsuccessful: `FHASH_EMPTY_TABLE` | + !> `FHASH_FOUND_WRONG_TYPE` | `FHASH_KEY_NOT_FOUND` + integer, intent(out), optional :: stat + + logical :: type_match + integer :: local_stat + type(fhash_container_t), pointer :: data + + character(:), allocatable :: char_temp + + if (present(stat)) stat = 0 + + call fhash_tbl_get_data(tbl,key,data,local_stat) + + if (local_stat /= 0) then + if (present(stat)) stat = local_stat + return + end if + + if (present(char)) then ! (Work-around for weird gfortran bug re char dummy) + + call data%get(i32,i64,r32,r64,char_temp,bool,raw,type_match) + + if (type_match) char = char_temp + + else + + call data%get(i32,i64,r32,r64,bool=bool,raw=raw,match=type_match) + + end if + + if (.not.type_match) then + if (present(stat)) stat = FHASH_FOUND_WRONG_TYPE + return + end if + +end subroutine fhash_tbl_get_intrinsic_scalar + + +!> Get wrapper to retrieve a scalar intrinsic type pointer +subroutine fhash_tbl_get_intrinsic_scalar_ptr(tbl,key,i32,i64,r32,r64,char,bool,raw,stat) + + !> Hash table object + class(fhash_tbl_t), intent(in) :: tbl + + !> Key to retrieve + class(fhash_key_t), intent(in) :: key + + !> Value to retrieve + integer(int32), pointer, intent(out), optional :: i32 + integer(int64), pointer, intent(out), optional :: i64 + real(sp), pointer, intent(out), optional :: r32 + real(dp), pointer, intent(out), optional :: r64 + character(:), pointer, intent(out), optional :: char + logical, pointer, intent(out), optional :: bool + class(*), pointer, intent(out), optional :: raw + + !> Status flag. Zero if successful. + !> Unsuccessful: `FHASH_EMPTY_TABLE` | + !> `FHASH_FOUND_WRONG_TYPE` | `FHASH_KEY_NOT_FOUND` + integer, intent(out), optional :: stat + + logical :: type_match + integer :: local_stat + type(fhash_container_t), pointer :: data + + character(:), pointer :: char_temp + + if (present(stat)) stat = 0 + + call fhash_tbl_get_data(tbl,key,data,local_stat) + + if (local_stat /= 0) then + if (present(stat)) stat = local_stat + return + end if + + if (present(char)) then ! (Work-around for weird gfortran bug re char dummy) + + call data%get_ptr(i32,i64,r32,r64,char_temp,bool,raw,type_match) + + if (type_match) char => char_temp + + else + + call data%get_ptr(i32,i64,r32,r64,bool=bool,raw=raw,match=type_match) + + end if + + if (.not.type_match) then + if (present(stat)) stat = FHASH_FOUND_WRONG_TYPE + return + end if + +end subroutine fhash_tbl_get_intrinsic_scalar_ptr + + +!> Get wrapper to directly retrieve a scalar int32 value +subroutine fhash_tbl_get_int32(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + integer(int32), intent(out) :: value !! Output value + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar(tbl,key,i32=value,stat=stat) + +end subroutine fhash_tbl_get_int32 + + +!> Get wrapper to directly retrieve a scalar int64 value +subroutine fhash_tbl_get_int64(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + integer(int64), intent(out) :: value !! Output value + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar(tbl,key,i64=value,stat=stat) + +end subroutine fhash_tbl_get_int64 + + +!> Get wrapper to directly retrieve a scalar float value +subroutine fhash_tbl_get_float(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + real(sp), intent(out) :: value !! Output value + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar(tbl,key,r32=value,stat=stat) + +end subroutine fhash_tbl_get_float + + +!> Get wrapper to directly retrieve a scalar double value +subroutine fhash_tbl_get_double(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + real(dp), intent(out) :: value !! Output value + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar(tbl,key,r64=value,stat=stat) + +end subroutine fhash_tbl_get_double + + +!> Get wrapper to directly retrieve a scalar character value +subroutine fhash_tbl_get_char(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + character(:), allocatable, intent(out) :: value !! Output value + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar(tbl,key,char=value,stat=stat) + +end subroutine fhash_tbl_get_char + + +!> Get wrapper to directly retrieve a scalar logical value +subroutine fhash_tbl_get_logical(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + logical, intent(out) :: value !! Output value + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar(tbl,key,bool=value,stat=stat) + +end subroutine fhash_tbl_get_logical + + +!> Get wrapper to directly retrieve underlying polymorhpic scalar value +subroutine fhash_tbl_get_raw(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + class(*), allocatable, intent(out) :: value !! Output value + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar(tbl,key,raw=value,stat=stat) + +end subroutine fhash_tbl_get_raw + + +!> Get wrapper to directly retrieve a scalar int32 value +subroutine fhash_tbl_get_int32_ptr(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + integer(int32), pointer, intent(out) :: value !! Output value pointer + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar_ptr(tbl,key,i32=value,stat=stat) + +end subroutine fhash_tbl_get_int32_ptr + + +!> Get wrapper to directly retrieve a scalar int64 value +subroutine fhash_tbl_get_int64_ptr(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + integer(int64), pointer, intent(out) :: value !! Output value pointer + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar_ptr(tbl,key,i64=value,stat=stat) + +end subroutine fhash_tbl_get_int64_ptr + + +!> Get wrapper to directly retrieve a scalar float value +subroutine fhash_tbl_get_float_ptr(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + real(sp), pointer, intent(out) :: value !! Output value pointer + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar_ptr(tbl,key,r32=value,stat=stat) + +end subroutine fhash_tbl_get_float_ptr + + +!> Get wrapper to directly retrieve a scalar double value +subroutine fhash_tbl_get_double_ptr(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + real(dp), pointer, intent(out) :: value !! Output value pointer + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar_ptr(tbl,key,r64=value,stat=stat) + +end subroutine fhash_tbl_get_double_ptr + + +!> Get wrapper to directly retrieve a scalar character value +subroutine fhash_tbl_get_char_ptr(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + character(:), pointer, intent(out) :: value !! Output value pointer + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar_ptr(tbl,key,char=value,stat=stat) + +end subroutine fhash_tbl_get_char_ptr + + +!> Get wrapper to directly retrieve a scalar logical value +subroutine fhash_tbl_get_logical_ptr(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + logical, pointer, intent(out) :: value !! Output value pointer + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar_ptr(tbl,key,bool=value,stat=stat) + +end subroutine fhash_tbl_get_logical_ptr + + +!> Get wrapper to directly retrieve underlying polymorhpic scalar value +subroutine fhash_tbl_get_raw_ptr(tbl,key,value,stat) + class(fhash_tbl_t), intent(in) :: tbl !! Hash table object + class(fhash_key_t), intent(in) :: key !! Key to retrieve + class(*), pointer, intent(out) :: value !! Output value + integer, intent(out), optional :: stat !! Status flag. Zero if successful. + + call fhash_tbl_get_intrinsic_scalar_ptr(tbl,key,raw=value,stat=stat) + +end subroutine fhash_tbl_get_raw_ptr + + +end module fhash_tbl \ No newline at end of file diff --git a/thirdparty/fhash/src/fhash_tbl_iter.f90 b/thirdparty/fhash/src/fhash_tbl_iter.f90 new file mode 100644 index 00000000..642b48f4 --- /dev/null +++ b/thirdparty/fhash/src/fhash_tbl_iter.f90 @@ -0,0 +1,87 @@ +module fhash_tbl_iter + use fhash_tbl, only: fhash_tbl_t + use fhash_key_base, only: fhash_key_t + use fhash_data_container, only: fhash_container_t + use fhash_sll + implicit none + + private + public fhash_iter_t + + !> Iterator type for iterating over hash table items + type fhash_iter_t + + type(fhash_tbl_t), pointer :: tbl => NULL() + + integer :: bucket = 1 + integer :: depth = 1 + + contains + procedure :: next => fhash_iter_next + procedure :: reset => fhash_iter_reset + end type fhash_iter_t + + + interface fhash_iter_t + module procedure :: fhash_iter_init + end interface fhash_iter_t + + contains + + !> Initialise fhash iterator + function fhash_iter_init(tbl) result(iter) + type(fhash_tbl_t), intent(in), target :: tbl + type(fhash_iter_t) :: iter + + iter%tbl => tbl + + end function fhash_iter_init + + + !> Return next item from iterator + function fhash_iter_next(iter,key,data) result(found) + class(fhash_iter_t), intent(inout) :: iter + class(fhash_key_t), intent(out), allocatable :: key + class(*), allocatable, intent(out) :: data + logical :: found + + type(fhash_container_t), pointer :: data_container + class(*), pointer :: data_out + + found = .false. + + if (.not.associated(iter%tbl)) return + + do while (.not.found) + if (iter%bucket > size(iter%tbl%buckets)) return + if (.not.allocated(iter%tbl%buckets(iter%bucket)%key)) then + iter%bucket = iter%bucket + 1 + cycle + end if + call sll_get_at(iter%tbl%buckets(iter%bucket),iter%depth,key,data_container,found) + if (iter%depth > node_depth(iter%tbl%buckets(iter%bucket))) then + iter%bucket = iter%bucket + 1 + iter%depth = 1 + else + iter%depth = iter%depth + 1 + end if + end do + + if (found) then + call data_container%get(raw=data) ! Extract underlying polymorphic data + end if + + end function fhash_iter_next + + + !> Reset iterator to beginning + subroutine fhash_iter_reset(iter) + class(fhash_iter_t), intent(inout) :: iter + + iter%bucket = 1 + iter%depth = 1 + + end subroutine fhash_iter_reset + + +end module fhash_tbl_iter \ No newline at end of file diff --git a/thirdparty/fhash/test/CMakeLists.txt b/thirdparty/fhash/test/CMakeLists.txt new file mode 100644 index 00000000..f43db27f --- /dev/null +++ b/thirdparty/fhash/test/CMakeLists.txt @@ -0,0 +1,25 @@ +set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}) + +add_library(TestLite TestLite.f90 TestLite_suite.f90 TestLite_error.f90) +target_include_directories(TestLite PUBLIC + $) + +add_library(tests test_container.f90 test_fnv.f90 test_key.f90 test_sll.f90 test_tbl.f90 test_tbl_iter.f90) +target_link_libraries(tests fhash TestLite) + + +add_executable(main main.f90) +target_link_libraries(main PRIVATE fhash TestLite tests) + +add_test(main main) + +add_custom_target(all_tests ALL + DEPENDS main) + +add_custom_command( + TARGET all_tests + COMMENT "Run tests" + POST_BUILD + WORKING_DIRECTORY ${CMAKE_BINARY_DIR} + COMMAND ${CMAKE_CTEST_COMMAND} --output-on-failure -C $ +) diff --git a/thirdparty/fhash/test/TestLite.f90 b/thirdparty/fhash/test/TestLite.f90 new file mode 100644 index 00000000..424683fd --- /dev/null +++ b/thirdparty/fhash/test/TestLite.f90 @@ -0,0 +1,113 @@ +! TestLite: A lightweight testing framework +! +! MIT License +! +! Copyright (c) 2020 fpm contributors +! +! Permission is hereby granted, free of charge, to any person obtaining a copy +! of this software and associated documentation files (the "Software"), to deal +! in the Software without restriction, including without limitation the rights +! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is +! furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in all +! copies or substantial portions of the Software. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +! SOFTWARE. + +module TestLite + use, intrinsic :: iso_fortran_env, only : error_unit + use TestLite_suite, only : run_testsuite, new_testsuite, testsuite_t, & + & select_suite, run_selected + implicit none + + contains + + !> Run a collection of testsuites + subroutine run_tests(testsuite) + type(testsuite_t), intent(in) :: testsuite(:) + + integer :: stat, is + character(len=:), allocatable :: suite_name, test_name + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + call get_argument(1, suite_name) + call get_argument(2, test_name) + + if (allocated(suite_name)) then + is = select_suite(testsuite, suite_name) + if (is > 0 .and. is <= size(testsuite)) then + if (allocated(test_name)) then + write(error_unit, fmt) "Suite:", testsuite(is)%name + call run_selected(testsuite(is)%collect, test_name, error_unit, stat) + if (stat < 0) then + error stop 1 + end if + else + write(error_unit, fmt) "Testing:", testsuite(is)%name + call run_testsuite(testsuite(is)%collect, error_unit, stat) + end if + else + write(error_unit, fmt) "Available testsuites" + do is = 1, size(testsuite) + write(error_unit, fmt) "-", testsuite(is)%name + end do + error stop 1 + end if + else + do is = 1, size(testsuite) + write(error_unit, fmt) "Testing:", testsuite(is)%name + call run_testsuite(testsuite(is)%collect, error_unit, stat) + end do + end if + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop 1 + end if + + end subroutine run_tests + + + !> Obtain the command line argument at a given index + subroutine get_argument(idx, arg) + + !> Index of command line argument, range [0:command_argument_count()] + integer, intent(in) :: idx + + !> Command line argument + character(len=:), allocatable, intent(out) :: arg + + integer :: length, stat + + call get_command_argument(idx, length=length, status=stat) + if (stat /= 0) then + return + endif + + allocate(character(len=length) :: arg, stat=stat) + if (stat /= 0) then + return + endif + + if (length > 0) then + call get_command_argument(idx, arg, status=stat) + if (stat /= 0) then + deallocate(arg) + return + end if + end if + + end subroutine get_argument + + +end module TestLite \ No newline at end of file diff --git a/thirdparty/fhash/test/TestLite_error.f90 b/thirdparty/fhash/test/TestLite_error.f90 new file mode 100644 index 00000000..5e52f69e --- /dev/null +++ b/thirdparty/fhash/test/TestLite_error.f90 @@ -0,0 +1,152 @@ +! TestLite: A lightweight testing framework +! +! MIT License +! +! Copyright (c) 2020 fpm contributors +! +! Permission is hereby granted, free of charge, to any person obtaining a copy +! of this software and associated documentation files (the "Software"), to deal +! in the Software without restriction, including without limitation the rights +! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is +! furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in all +! copies or substantial portions of the Software. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +! SOFTWARE. + +!> Implementation of basic error handling. +module TestLite_error + implicit none + private + + public :: error_t + public :: fatal_error, syntax_error, file_not_found_error + public :: file_parse_error + + + !> Data type defining an error + type :: error_t + + !> Error message + character(len=:), allocatable :: message + + end type error_t + + + !> Alias syntax errors to fatal errors for now + interface syntax_error + module procedure :: fatal_error + end interface syntax_error + + +contains + + + !> Generic fatal runtime error + subroutine fatal_error(error, message) + + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error + + !> Error message + character(len=*), intent(in) :: message + + allocate(error) + error%message = message + + end subroutine fatal_error + + + !> Error created when a file is missing or not found + subroutine file_not_found_error(error, file_name) + + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error + + !> Name of the missing file + character(len=*), intent(in) :: file_name + + allocate(error) + error%message = "'"//file_name//"' could not be found, check if the file exists" + + end subroutine file_not_found_error + + + !> Error created when file parsing fails + subroutine file_parse_error(error, file_name, message, line_num, & + line_string, line_col) + + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error + + !> Name of file + character(len=*), intent(in) :: file_name + + !> Parse error message + character(len=*), intent(in) :: message + + !> Line number of parse error + integer, intent(in), optional :: line_num + + !> Line context string + character(len=*), intent(in), optional :: line_string + + !> Line context column + integer, intent(in), optional :: line_col + + character(50) :: temp_string + + allocate(error) + error%message = 'Parse error: '//message//new_line('a') + + error%message = error%message//file_name + + if (present(line_num)) then + + write(temp_string,'(I0)') line_num + + error%message = error%message//':'//trim(temp_string) + + end if + + if (present(line_col)) then + + if (line_col > 0) then + + write(temp_string,'(I0)') line_col + error%message = error%message//':'//trim(temp_string) + + end if + + end if + + if (present(line_string)) then + + error%message = error%message//new_line('a') + error%message = error%message//' | '//line_string + + if (present(line_col)) then + + if (line_col > 0) then + + error%message = error%message//new_line('a') + error%message = error%message//' | '//repeat(' ',line_col-1)//'^' + + end if + + end if + + end if + + end subroutine file_parse_error + + +end module TestLite_error diff --git a/thirdparty/fhash/test/TestLite_suite.f90 b/thirdparty/fhash/test/TestLite_suite.f90 new file mode 100644 index 00000000..59c0e86e --- /dev/null +++ b/thirdparty/fhash/test/TestLite_suite.f90 @@ -0,0 +1,309 @@ +! TestLite: A lightweight testing framework +! +! MIT License +! +! Copyright (c) 2020 fpm contributors +! +! Permission is hereby granted, free of charge, to any person obtaining a copy +! of this software and associated documentation files (the "Software"), to deal +! in the Software without restriction, including without limitation the rights +! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is +! furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in all +! copies or substantial portions of the Software. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +! SOFTWARE. + +!> Define some procedures to automate collecting and launching of tests +module TestLite_suite + use TestLite_error, only : error_t, test_failed => fatal_error + implicit none + private + + public :: run_testsuite, run_selected, new_unittest, new_testsuite, test_failed + public :: select_test, select_suite + public :: check_string + public :: unittest_t, testsuite_t, error_t + + + abstract interface + !> Entry point for tests + subroutine test_interface(error) + import :: error_t + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + end subroutine test_interface + end interface + + + !> Declaration of a unit test + type :: unittest_t + + !> Name of the test + character(len=:), allocatable :: name + + !> Entry point of the test + procedure(test_interface), pointer, nopass :: test => null() + + !> Whether test is supposed to fail + logical :: should_fail = .false. + + end type unittest_t + + + abstract interface + !> Collect all tests + subroutine collect_interface(testsuite) + import :: unittest_t + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + end subroutine collect_interface + end interface + + + !> Collection of unit tests + type :: testsuite_t + + !> Name of the testsuite + character(len=:), allocatable :: name + + !> Entry point of the test + procedure(collect_interface), pointer, nopass :: collect => null() + + end type testsuite_t + + character(len=*), parameter :: fmt = '("#", a, a, T40, a)' + character(len=*), parameter :: indent = repeat(" ", 5) // repeat(".", 3) + + +contains + + + !> Driver for testsuite + subroutine run_testsuite(collect, unit, stat) + + !> Collect tests + procedure(collect_interface) :: collect + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + type(unittest_t), allocatable :: testsuite(:) + integer :: ii + + call collect(testsuite) + + do ii = 1, size(testsuite) + write(unit, '("#", 3(1x, a), 1x, "(", i0, "/", i0, ")")') & + & "Starting", testsuite(ii)%name, "...", ii, size(testsuite) + call run_unittest(testsuite(ii), unit, stat) + end do + + end subroutine run_testsuite + + + !> Driver for selective testing + subroutine run_selected(collect, name, unit, stat) + + !> Collect tests + procedure(collect_interface) :: collect + + !> Name of the selected test + character(len=*), intent(in) :: name + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + type(unittest_t), allocatable :: testsuite(:) + integer :: ii + + call collect(testsuite) + + ii = select_test(testsuite, name) + + if (ii > 0 .and. ii <= size(testsuite)) then + call run_unittest(testsuite(ii), unit, stat) + else + write(unit, fmt) "Available tests:" + do ii = 1, size(testsuite) + write(unit, fmt) "-", testsuite(ii)%name + end do + stat = -huge(ii) + end if + + end subroutine run_selected + + + !> Run a selected unit test + subroutine run_unittest(test, unit, stat) + + !> Unit test + type(unittest_t), intent(in) :: test + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + type(error_t), allocatable :: error + + call test%test(error) + if (allocated(error) .neqv. test%should_fail) then + if (test%should_fail) then + write(unit, fmt) indent, test%name, "[UNEXPECTED PASS]" + else + write(unit, fmt) indent, test%name, "[FAILED]" + end if + stat = stat + 1 + else + if (test%should_fail) then + write(unit, fmt) indent, test%name, "[EXPECTED FAIL]" + else + write(unit, fmt) indent, test%name, "[PASSED]" + end if + end if + if (allocated(error)) then + write(unit, fmt) "Message:", error%message + end if + + end subroutine run_unittest + + + !> Select a unit test from all available tests + function select_test(tests, name) result(pos) + + !> Name identifying the test suite + character(len=*), intent(in) :: name + + !> Available unit tests + type(unittest_t) :: tests(:) + + !> Selected test suite + integer :: pos + + integer :: it + + pos = 0 + do it = 1, size(tests) + if (name == tests(it)%name) then + pos = it + exit + end if + end do + + end function select_test + + + !> Select a test suite from all available suites + function select_suite(suites, name) result(pos) + + !> Name identifying the test suite + character(len=*), intent(in) :: name + + !> Available test suites + type(testsuite_t) :: suites(:) + + !> Selected test suite + integer :: pos + + integer :: it + + pos = 0 + do it = 1, size(suites) + if (name == suites(it)%name) then + pos = it + exit + end if + end do + + end function select_suite + + + !> Register a new unit test + function new_unittest(name, test, should_fail) result(self) + + !> Name of the test + character(len=*), intent(in) :: name + + !> Entry point for the test + procedure(test_interface) :: test + + !> Whether test is supposed to error or not + logical, intent(in), optional :: should_fail + + !> Newly registered test + type(unittest_t) :: self + + self%name = name + self%test => test + if (present(should_fail)) self%should_fail = should_fail + + end function new_unittest + + + !> Register a new testsuite + function new_testsuite(name, collect) result(self) + + !> Name of the testsuite + character(len=*), intent(in) :: name + + !> Entry point to collect tests + procedure(collect_interface) :: collect + + !> Newly registered testsuite + type(testsuite_t) :: self + + self%name = name + self%collect => collect + + end function new_testsuite + + + !> Check a deferred length character variable against a reference value + subroutine check_string(error, actual, expected, name) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Actual string value + character(len=:), allocatable, intent(in) :: actual + + !> Expected string value + character(len=*), intent(in) :: expected + + !> Name of the string to check + character(len=*), intent(in) :: name + + if (.not.allocated(actual)) then + call test_failed(error, name//" is not set correctly") + return + end if + + if (actual /= expected) then + call test_failed(error, name//" is "//actual// & + & " but should be "//expected) + end if + + end subroutine check_string + + +end module TestLite_suite diff --git a/thirdparty/fhash/test/main.f90 b/thirdparty/fhash/test/main.f90 new file mode 100644 index 00000000..f4f432eb --- /dev/null +++ b/thirdparty/fhash/test/main.f90 @@ -0,0 +1,27 @@ +program test + use iso_fortran_env, only: int32, int64 + use TestLite, only: testsuite_t, new_testsuite, run_tests + use TestLite_suite + use TestLite_error + use test_fnv, only: collect_fnv + use test_key, only: collect_key + use test_container, only: collect_container + use test_sll, only: collect_sll + use test_tbl, only: collect_tbl + use test_tbl_iter, only: collect_tbl_iter + implicit none + + type(testsuite_t), allocatable :: testsuite(:) + + testsuite = [ & + & new_testsuite("fhash_fnv", collect_fnv), & + & new_testsuite("fhash_key", collect_key), & + & new_testsuite("fhash_container", collect_container), & + & new_testsuite("fhash_sll", collect_sll), & + & new_testsuite("fhash_tbl", collect_tbl), & + & new_testsuite("fhash_tbl_iter", collect_tbl_iter) & + ] + + call run_tests(testsuite) + +end program test \ No newline at end of file diff --git a/thirdparty/fhash/test/test_container.f90 b/thirdparty/fhash/test/test_container.f90 new file mode 100644 index 00000000..e821300e --- /dev/null +++ b/thirdparty/fhash/test/test_container.f90 @@ -0,0 +1,86 @@ +module test_container + use iso_fortran_env, only: int32, int64 + use TestLite_suite, only : new_unittest, unittest_t, error_t, test_failed + use fhash_data_container + implicit none + + private + public collect_container + + contains + + !> Collect all exported unit tests + subroutine collect_container(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("container-scalar", test_container_scalar), & + & new_unittest("container-scalar-ptr", test_container_scalar_ptr) & + ] + + end subroutine collect_container + + + !> Set & update scalar data + subroutine test_container_scalar(error) + type(error_t), allocatable, intent(out) :: error + + type(fhash_container_t) :: container + + ! Set value + container = fhash_container(int(9,int32)) + + if (.not.allocated(container%scalar_data)) then + call test_failed(error,'Scalar_data not allocated.') + return + end if + + select type(v=>container%scalar_data) + type is (integer(int32)) + if (v /= 9) then + call test_failed(error,'Wrong value for container%scalar_data.') + return + end if + class default + call test_failed(error,'Wrong data type for container%scalar_data.') + return + end select + + end subroutine test_container_scalar + + + !> Set & update scalar pointer + subroutine test_container_scalar_ptr(error) + type(error_t), allocatable, intent(out) :: error + + integer(int32), target :: my_int, new_int + type(fhash_container_t) :: container + + my_int = 9 + + ! Set value + container = fhash_container(my_int,pointer=.true.) + + if (.not.associated(container%scalar_ptr)) then + call test_failed(error,'Scalar_ptr not associated.') + return + end if + + my_int = 10 + + select type(v=>container%scalar_ptr) + type is (integer(int32)) + if (v /= my_int) then + call test_failed(error,'Wrong value for container%scalar_ptr.') + return + end if + class default + call test_failed(error,'Wrong data type for container%scalar_ptr.') + return + end select + + end subroutine test_container_scalar_ptr + +end module test_container \ No newline at end of file diff --git a/thirdparty/fhash/test/test_fnv.f90 b/thirdparty/fhash/test/test_fnv.f90 new file mode 100644 index 00000000..63fc4935 --- /dev/null +++ b/thirdparty/fhash/test/test_fnv.f90 @@ -0,0 +1,284 @@ +module test_fnv + use iso_fortran_env, only: int32, int64 + use TestLite_suite, only : new_unittest, unittest_t, error_t, test_failed + use fhash_fnv + implicit none + + private + public collect_fnv + + contains + + !> Collect all exported unit tests + subroutine collect_fnv(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("string-hashing", test_string_hashing), & + & new_unittest("string-hash-with-seed", test_string_hash_with_seed), & + & new_unittest("int32-hashing", test_int32_hashing), & + & new_unittest("int32-array-hashing", test_int32_array_hashing), & + & new_unittest("int64-hashing", test_int64_hashing), & + & new_unittest("int64-array-hashing", test_int64_array_hashing) & + ] + + end subroutine collect_fnv + + + !> Some simple string hashes checked against https://md5calc.com/hash + subroutine test_string_hashing(error) + type(error_t), allocatable, intent(out) :: error + + call check_hash('a','E40C292C') + if (allocated(error)) return + + call check_hash('z','FF0C53AD') + if (allocated(error)) return + + call check_hash('ab','4D2505CA') + if (allocated(error)) return + + call check_hash('abc','1A47E90B') + if (allocated(error)) return + + call check_hash('abcdefghijklmnopqrstuvwxyz','B0BC0C82') + if (allocated(error)) return + + call check_hash('ABCDEFGHIJKLMNOPQRSTUVWXYZ','8A88DD82') + if (allocated(error)) return + + call check_hash('0123456789','F9808FF2') + if (allocated(error)) return + + call check_hash('`¬!"£$%^&*()_+-=[]{};''#:@~,./<>? ','62BB758C') + if (allocated(error)) return + + call check_hash('A much longer string to hash;'// & + ' look, it continues onto the next line.'// & + ' And again onto another line!'// & + ' I can do this all day!'//& + ' I can do this all day!'//& + ' I can do this all day!','FA05C37E') + if (allocated(error)) return + + contains + + subroutine check_hash(string,hash) + character(*), intent(in) :: string + character(*), intent(in) :: hash + + character(:), allocatable :: actual + actual = hash_string(fnv_1a(string)) + + if (trim(actual) /= hash) then + + allocate(error) + error%message = 'String hash check failed for string "'//string//'"'//new_line('a')//& + ' expected "'//trim(hash)//'" but got "'//trim(actual)//'"' + + return + + end if + + end subroutine check_hash + + end subroutine test_string_hashing + + + !> Check custom hashing of character strings + subroutine test_string_hash_with_seed(error) + type(error_t), allocatable, intent(out) :: error + + integer(int64) :: hash1, hash2 + + hash1 = fnv_1a('a') + hash1 = fnv_1a(hash1,'b') + + hash2 = fnv_1a('ab') + + if (hash1 /= hash2) then + allocate(error) + error%message = 'Custom hash with seed failed.' + end if + + end subroutine test_string_hash_with_seed + + + !> Check for int32 hash regression + subroutine test_int32_hashing(error) + type(error_t), allocatable, intent(out) :: error + + call check_hash(int(0,int32),'4B95F515') + if (allocated(error)) return + + call check_hash(int(1,int32),'FB69B604') + if (allocated(error)) return + + call check_hash(int(-1,int32),'E3160FB1') + if (allocated(error)) return + + call check_hash(huge(int(1,int32)),'6316D931') + if (allocated(error)) return + + call check_hash(-1*huge(int(1,int32)),'7B6A7F84') + if (allocated(error)) return + + contains + + subroutine check_hash(input,hash) + integer(int32), intent(in) :: input + character(*), intent(in) :: hash + + character(50) :: int_string + + character(:), allocatable :: actual + actual = hash_string(fnv_1a(input)) + + if (trim(actual) /= hash) then + + write(int_string,*) input + allocate(error) + error%message = 'String hash check failed for 32bit integer "'//trim(int_string)//'"'//new_line('a')//& + ' expected "'//trim(hash)//'" but got "'//trim(actual)//'"' + + return + + end if + + end subroutine check_hash + + end subroutine test_int32_hashing + + + !> Check for int32 array hash regression + subroutine test_int32_array_hashing(error) + type(error_t), allocatable, intent(out) :: error + + integer :: i + + call check_hash(int([0,1,2,3,4,5],int32),'40964454') + if (allocated(error)) return + + call check_hash(int([(i,i=100,1000,100)],int32),'2C6E00E3') + if (allocated(error)) return + + call check_hash(int([(i,i=-10000,10000,1000)],int32),'945FF111') + if (allocated(error)) return + + contains + + subroutine check_hash(input,hash) + integer(int32), intent(in) :: input(:) + character(*), intent(in) :: hash + + character(:), allocatable :: actual + actual = hash_string(fnv_1a(input)) + + if (trim(actual) /= hash) then + + allocate(error) + error%message = 'String hash check failed for 32bit integer array'//new_line('a')//& + ' expected "'//trim(hash)//'" but got "'//trim(actual)//'"' + + return + + end if + + end subroutine check_hash + + end subroutine test_int32_array_hashing + + + !> Check for int64 hash regression + subroutine test_int64_hashing(error) + type(error_t), allocatable, intent(out) :: error + + call check_hash(int(0,int64),'9BE17165') + if (allocated(error)) return + + call check_hash(int(1,int64),'3E801244') + if (allocated(error)) return + + call check_hash(int(-1,int64),'6CAE0A5D') + if (allocated(error)) return + + call check_hash(int(huge(int(1,int32)),int64),'D8637B41') + if (allocated(error)) return + + call check_hash(int(-1*huge(int(1,int32)),int64),'2AD47C60') + if (allocated(error)) return + + call check_hash(huge(int(1,int64)),'ECAED3DD') + if (allocated(error)) return + + call check_hash(-1*huge(int(1,int64)),'BE80DBC4') + if (allocated(error)) return + + contains + + subroutine check_hash(input,hash) + integer(int64), intent(in) :: input + character(*), intent(in) :: hash + + character(50) :: int_string + + character(:), allocatable :: actual + actual = hash_string(fnv_1a(input)) + + if (trim(actual) /= hash) then + + write(int_string,'(I0)') input + allocate(error) + error%message = 'String hash check failed for 64bit integer "'//trim(int_string)//'"'//new_line('a')//& + ' expected "'//trim(hash)//'" but got "'//trim(actual)//'"' + + return + + end if + + end subroutine check_hash + + end subroutine test_int64_hashing + + + !> Check for int64 array hash regression + subroutine test_int64_array_hashing(error) + type(error_t), allocatable, intent(out) :: error + + integer :: i + + call check_hash(int([0,1,2,3,4,5],int64),'67C5CFE4') + if (allocated(error)) return + + call check_hash(int([(i,i=100,1000,100)],int64),'83CE0AD3') + if (allocated(error)) return + + call check_hash(int([(i,i=-10000,10000,1000)],int64),'BC95B561') + if (allocated(error)) return + + contains + + subroutine check_hash(input,hash) + integer(int64), intent(in) :: input(:) + character(*), intent(in) :: hash + + character(:), allocatable :: actual + actual = hash_string(fnv_1a(input)) + + if (trim(actual) /= hash) then + + allocate(error) + error%message = 'String hash check failed for 32bit integer array'//new_line('a')//& + ' expected "'//trim(hash)//'" but got "'//trim(actual)//'"' + + return + + end if + + end subroutine check_hash + + end subroutine test_int64_array_hashing + +end module test_fnv \ No newline at end of file diff --git a/thirdparty/fhash/test/test_key.f90 b/thirdparty/fhash/test/test_key.f90 new file mode 100644 index 00000000..f0eb88a5 --- /dev/null +++ b/thirdparty/fhash/test/test_key.f90 @@ -0,0 +1,235 @@ +module test_key + use iso_fortran_env, only: int32, int64 + use TestLite_suite, only : new_unittest, unittest_t, error_t, test_failed + use fhash_fnv, only: hash_string + use fhash_key_base + use fhash_key_char + use fhash_key_int32 + use fhash_key_int64 + use fhash_key_int32_1d + use fhash_key_int64_1d + + implicit none + + private + public collect_key + + contains + + !> Collect all exported unit tests + subroutine collect_key(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("key-char", test_key_char), & + & new_unittest("key-int32", test_key_int32), & + & new_unittest("key-int32-1d", test_key_int32_1d), & + & new_unittest("key-int64", test_key_int64), & + & new_unittest("key-int64-1d", test_key_int64_1d) & + ] + + end subroutine collect_key + + + !> Test character(*) hash key implementation + subroutine test_key_char(error) + type(error_t), allocatable, intent(out) :: error + + class(fhash_key_t), allocatable :: my_key1 + + !> Create key from character(*) + allocate(my_key1, source = fhash_key('abc')) + + !> Check new key + select type(k=>my_key1) + type is (fhash_key_char_t) + + if (.not.(k == fhash_key('abc'))) then + call test_failed(error,'Character key equality test failed.') + return + end if + + if (k == fhash_key('a')) then + call test_failed(error,'Character key inequality test failed.') + return + end if + + if (k == fhash_key(int(iachar('a'),int32))) then + call test_failed(error,'Character key type inequality test failed.') + return + end if + + class default + + call test_failed(error, 'Wrong type for new key, expected fhash_key_char_t') + return + + end select + + !> Check hashing + if (hash_string(my_key1%hash()) /= '1A47E90B') then + call test_failed(error, 'Wrong hash for new character key.') + return + end if + + end subroutine test_key_char + + + !> Test scalar int32 hash key implementation + subroutine test_key_int32(error) + type(error_t), allocatable, intent(out) :: error + + class(fhash_key_t), allocatable :: my_key1 + + !> Create key from scalar int32 + my_key1 = fhash_key(int(0,int32)) + + !> Check new key + select type(k=>my_key1) + type is (fhash_key_int32_t) + + if (.not.(k == fhash_key(int(0,int32)))) then + call test_failed(error,'int32 key equality test failed.') + return + end if + + if (k == fhash_key(int(1,int32))) then + call test_failed(error,'int32 key inequality test failed.') + return + end if + + class default + + call test_failed(error, 'Wrong type for new key, expected fhash_key_int32_t') + return + + end select + + !> Check hashing + if (hash_string(my_key1%hash()) /= '4B95F515') then + call test_failed(error, 'Wrong hash for new int32 key.') + return + end if + + end subroutine test_key_int32 + + + !> Test 1d int32 array hash key implementation + subroutine test_key_int32_1d(error) + type(error_t), allocatable, intent(out) :: error + + class(fhash_key_t), allocatable :: my_key1 + + !> Create key from scalar int32 + allocate(my_key1, source = fhash_key(int([0,1,2,3,4,5],int32))) + + !> Check new key + select type(k=>my_key1) + type is (fhash_key_int32_1d_t) + + if (.not.(k == fhash_key(int([0,1,2,3,4,5],int32)))) then + call test_failed(error,'int32 1d key equality test failed.') + return + end if + + if (k == fhash_key(int([0,1],int32))) then + call test_failed(error,'int32 1d key inequality test failed.') + return + end if + + class default + + call test_failed(error, 'Wrong type for new key, expected fhash_key_int32_1d_t') + return + + end select + + !> Check hashing + if (hash_string(my_key1%hash()) /= '40964454') then + call test_failed(error, 'Wrong hash for new int32 1d key.') + return + end if + + end subroutine test_key_int32_1d + + + !> Test scalar int64 hash key implementation + subroutine test_key_int64(error) + type(error_t), allocatable, intent(out) :: error + + class(fhash_key_t), allocatable :: my_key1 + + !> Create key from scalar int64 + my_key1 = fhash_key(int(0,int64)) + + !> Check new key + select type(k=>my_key1) + type is (fhash_key_int64_t) + + if (.not.(k == fhash_key(int(0,int64)))) then + call test_failed(error,'int64 key equality test failed.') + return + end if + + if (k == fhash_key(int(1,int64))) then + call test_failed(error,'int64 key inequality test failed.') + return + end if + + class default + + call test_failed(error, 'Wrong type for new key, expected fhash_key_int64_t') + return + + end select + + !> Check hashing + if (hash_string(my_key1%hash()) /= '9BE17165') then + call test_failed(error, 'Wrong hash for new int64 key.') + return + end if + + end subroutine test_key_int64 + + + !> Test 1d int64 array hash key implementation + subroutine test_key_int64_1d(error) + type(error_t), allocatable, intent(out) :: error + + class(fhash_key_t), allocatable :: my_key1 + + !> Create key from scalar int64 + allocate(my_key1, source = fhash_key(int([0,1,2,3,4,5],int64))) + + !> Check new key + select type(k=>my_key1) + type is (fhash_key_int64_1d_t) + + if (.not.(k == fhash_key(int([0,1,2,3,4,5],int64)))) then + call test_failed(error,'int64 1d key equality test failed.') + return + end if + + if (k == fhash_key(int([0,1],int64))) then + call test_failed(error,'int64 1d key inequality test failed.') + return + end if + + class default + + call test_failed(error, 'Wrong type for new key, expected fhash_key_int64_1d_t') + return + + end select + + !> Check hashing + if (hash_string(my_key1%hash()) /= '67C5CFE4') then + call test_failed(error, 'Wrong hash for new int64 1d key.') + return + end if + + end subroutine test_key_int64_1d + +end module test_key \ No newline at end of file diff --git a/thirdparty/fhash/test/test_sll.f90 b/thirdparty/fhash/test/test_sll.f90 new file mode 100644 index 00000000..d3353b38 --- /dev/null +++ b/thirdparty/fhash/test/test_sll.f90 @@ -0,0 +1,350 @@ +module test_sll + use iso_fortran_env, only: int32, int64 + use TestLite_suite, only : new_unittest, unittest_t, error_t, test_failed + use fhash_sll + use fhash_data_container + use fhash_key_char + use fhash_key_int32 + implicit none + + private + public collect_sll + + contains + + !> Collect all exported unit tests + subroutine collect_sll(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("sll-set", test_sll_set), & + & new_unittest("sll-get", test_sll_get), & + & new_unittest("sll-get_at", test_sll_get_at), & + & new_unittest("sll-update", test_sll_update), & + & new_unittest("sll-remove", test_sll_remove) & + ] + + end subroutine collect_sll + + !> Test node set + subroutine test_sll_set(error) + type(error_t), allocatable, intent(out) :: error + + type(fhash_node_t) :: node + + if (allocated(node%key)) then + call test_failed(error,'Key already allocated.') + return + end if + + if (node%value%allocated()) then + call test_failed(error,'Value already allocated.') + return + end if + + call sll_push_node(node,fhash_key('key'),value=9) + + if (.not.allocated(node%key)) then + call test_failed(error,'Key not allocated.') + return + end if + + if (.not.node%value%allocated()) then + call test_failed(error,'Value not allocated.') + return + end if + + if (associated(node%next)) then + call test_failed(error,'Next should not allocated.') + return + end if + + ! Set child nodes + call sll_push_node(node,fhash_key('key2'),value=10) + call sll_push_node(node,fhash_key('key3'),value=11) + + if (.not.associated(node%next) .OR. & + .not.associated(node%next%next)) then + call test_failed(error,'node%next not associated.') + return + end if + + if (node_depth(node) /= 3) then + call test_failed(error,'Incorrect node depth, expecting 3.') + return + end if + + call sll_clean(node) + + end subroutine test_sll_set + + + !> Get node data + subroutine test_sll_get(error) + type(error_t), allocatable, intent(out) :: error + + type(fhash_node_t) :: node + + ! Set value + call sll_push_node(node,fhash_key('key'),value=int(9,int32)) + + ! Get value + call check_node_get_int32(error,node,'key',expect=9) + if (allocated(error)) return + + ! Set child nodes + call sll_push_node(node,fhash_key('key2'),value=10) + call sll_push_node(node,fhash_key('key3'),value=11) + + ! Check child node get + call check_node_get_int32(error,node,'key2',expect=10) + if (allocated(error)) return + + call check_node_get_int32(error,node,'key3',expect=11) + if (allocated(error)) return + + ! Check for non-existent node + call check_node_get_int32(error,node,'key4',should_exist=.false.) + if (allocated(error)) return + + call sll_clean(node) + + end subroutine test_sll_get + + + !> Get node data at specific depth + subroutine test_sll_get_at(error) + type(error_t), allocatable, intent(out) :: error + + type(fhash_node_t) :: node + type(fhash_container_t), pointer :: data + class(*), allocatable :: data_raw + integer(int32) :: depth, data_values(3) + class(fhash_key_t), allocatable :: key_out + logical :: found + + ! Set value + data_values = [9_int32,10_int32,11_int32] + do depth=1,3 + call sll_push_node(node,fhash_key(depth),value=data_values(depth)) + end do + + ! Get nodes + do depth=1,3 + + call sll_get_at(node, depth=depth, key=key_out, data=data, found=found) + + if (.not.found) then + call test_failed(error,'Could not find node at specified depth') + return + end if + + call data%get(raw=data_raw) + + select type(d=>data_raw) + + type is(integer(int32)) + + if (d /= data_values(depth)) then + call test_failed(error,'Incorrect values returned from sll_get_at') + return + end if + + class default + call test_failed(error,'Retrieved data is not int32') + return + end select + + end do + + call sll_clean(node) + + end subroutine test_sll_get_at + + + !> Update node data + subroutine test_sll_update(error) + type(error_t), allocatable, intent(out) :: error + + type(fhash_node_t) :: node + + ! Set value + call sll_push_node(node,fhash_key('key'),value=int(9,int32)) + call sll_push_node(node,fhash_key('key2'),value=10) + call sll_push_node(node,fhash_key('key3'),value=11) + + ! Update value + call sll_push_node(node,fhash_key('key'),value=int(1,int32)) + call sll_push_node(node,fhash_key('key2'),value=int(2,int32)) + call sll_push_node(node,fhash_key('key3'),value=int(3,int32)) + + ! Check updated get value + call check_node_get_int32(error,node,key='key',expect=1) + if (allocated(error)) return + + call check_node_get_int32(error,node,key='key2',expect=2) + if (allocated(error)) return + + call check_node_get_int32(error,node,key='key3',expect=3) + if (allocated(error)) return + + call sll_clean(node) + + end subroutine test_sll_update + + + !> Remove node data + subroutine test_sll_remove(error) + type(error_t), allocatable, intent(out) :: error + + type(fhash_node_t) :: node + logical :: found + + ! Set value + call sll_push_node(node,fhash_key('key'),value=int(9,int32)) + call sll_push_node(node,fhash_key('key2'),value=int(10,int32)) + call sll_push_node(node,fhash_key('key3'),value=int(11,int32)) + call sll_push_node(node,fhash_key('key4'),value=int(12,int32)) + + ! Try to remove non-existent node + call sll_remove(node,fhash_key('key5'),found) + if (found) then + call test_failed(error,'Non-existent node return found=true during removal') + return + end if + + ! Remove middle node + call remove_and_check('key2') + if (allocated(error)) return + + ! Check other nodes unaffected + call check_node_get_int32(error,node,key='key',expect=9) + if (allocated(error)) return + + call check_node_get_int32(error,node,key='key3',expect=11) + if (allocated(error)) return + + call check_node_get_int32(error,node,key='key4',expect=12) + if (allocated(error)) return + + ! Remove bottom node + call remove_and_check('key4') + if (allocated(error)) return + + ! Check other nodes unaffected + call check_node_get_int32(error,node,key='key',expect=9) + if (allocated(error)) return + + call check_node_get_int32(error,node,key='key3',expect=11) + if (allocated(error)) return + + ! Remove top node + call remove_and_check('key') + if (allocated(error)) return + + ! Check other nodes unaffected + call check_node_get_int32(error,node,key='key3',expect=11) + if (allocated(error)) return + + ! Remove last node + call remove_and_check('key3') + if (allocated(error)) return + + if (node_depth(node) /= 0) then + call test_failed(error,'Incorrect node depth, expecting 0.') + return + end if + + call sll_clean(node) + + contains + + !> Remove node and check for proper removal + subroutine remove_and_check(key) + character(*), intent(in) :: key + + type(fhash_container_t), pointer :: data + logical :: found + + call sll_remove(node,fhash_key(key),found) + + if (.not.found) then + call test_failed(error,'Node not found while removing (key="'//key//'")') + return + end if + + ! Try to get value + call check_node_get_int32(error,node,key,should_exist=.false.) + if (allocated(error)) then + error%message = 'Node data still found, not removed (key="'//key//'")' + return + end if + + end subroutine remove_and_check + + end subroutine test_sll_remove + + + !> Test helper to retrieve and test and int32 data value + subroutine check_node_get_int32(error,node,key,expect,should_exist) + type(error_t), allocatable, intent(out) :: error + type(fhash_node_t) :: node + character(*), intent(in) :: key + integer(int32), intent(in), optional :: expect + logical, intent(in), optional :: should_exist + + logical :: expect_exists, found + type(fhash_container_t), pointer :: data + + if (present(should_exist)) then + expect_exists = should_exist + else + expect_exists = .true. + end if + + call sll_find_in(node,fhash_key(key),data,found) + + if (found .neqv. expect_exists) then + call test_failed(error,'Node data not found for key "'//key//'"') + return + end if + + if (found .and. present(expect)) then + call check_int32_data(error,data,expect) + if (allocated(error)) then + error%message = 'Error while retrieving key "'//key//'"' // new_line('a') // error%message + end if + end if + + end subroutine check_node_get_int32 + + + !> Test helper to check for type and value of int32 data + subroutine check_int32_data(error,data,expect) + type(error_t), allocatable, intent(out) :: error + type(fhash_container_t), intent(in) :: data + integer(int32), intent(in) :: expect + + character(500) :: message + + select type(v=>data%scalar_data) + type is (integer(int32)) + if (v /= expect) then + + write(message,'(A,I0,A,A,I0,A)') 'Wrong value for int32 data, expecting "',expect,'"',& + ' but got "',v,'"' + + call test_failed(error,trim(message)) + return + + end if + class default + call test_failed(error,'Wrong type for retrieved data.') + return + end select + + end subroutine check_int32_data + +end module test_sll \ No newline at end of file diff --git a/thirdparty/fhash/test/test_tbl.f90 b/thirdparty/fhash/test/test_tbl.f90 new file mode 100644 index 00000000..b8ca5c98 --- /dev/null +++ b/thirdparty/fhash/test/test_tbl.f90 @@ -0,0 +1,475 @@ +module test_tbl + use iso_fortran_env, only: sp=>real32, dp=>real64, int32, int64 + use TestLite_suite, only : new_unittest, unittest_t, error_t, test_failed + use fhash, only: key=>fhash_key, fhash_tbl_t + implicit none + + private + public collect_tbl + + contains + + !> Collect all exported unit tests + subroutine collect_tbl(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("fhash-tbl-intrinsics", test_fhash_intrinsics), & + & new_unittest("fhash-tbl-intrinsic-pointers", test_fhash_intrinsic_ptrs), & + & new_unittest("fhash-tbl-value-pointer", test_fhash_value_pointer), & + & new_unittest("fhash-tbl-pointer-value", test_fhash_pointer_value), & + & new_unittest("fhash-tbl-derived-type-value", test_fhash_derived_type_value), & + & new_unittest("fhash-tbl-invalid-keys", test_fhash_invalid_keys), & + & new_unittest("fhash-tbl-stats-empty", test_fhash_stats_empty), & + & new_unittest("fhash-tbl-unset", test_fhash_unset), & + & new_unittest("fhash-tbl-high-load", test_fhash_balanced_load) & + ] + + end subroutine collect_tbl + + !> Test intrinsic set and retrieve + subroutine test_fhash_intrinsics(error) + type(error_t), allocatable, intent(out) :: error + + type(fhash_tbl_t) :: tbl + integer(int32) :: set_int32, get_int32 + integer(int64) :: set_int64, get_int64 + real(sp) :: set_float, get_float + real(dp) :: set_double, get_double + character(:), allocatable :: set_char, get_char + logical :: set_bool, get_bool + + ! Set values + set_int32 =123 + call tbl%set(key('int32'),set_int32) + + set_int64 = 456 + call tbl%set(key('int64'),set_int64) + + set_float = 1.0_sp + call tbl%set(key('float'),set_float) + + set_double = 2.0_dp + call tbl%set(key('double'),set_double) + + set_char = 'Hello world' + call tbl%set(key('char'),set_char) + + set_bool = .false. + call tbl%set(key('bool'),set_bool) + + ! Get values + call tbl%get(key('int32'),get_int32) + if (get_int32 /= set_int32) then + call test_failed(error,'int32 value retrieved does not match value set.') + return + end if + + call tbl%get(key('int64'),get_int64) + if (get_int64 /= set_int64) then + call test_failed(error,'int64 value retrieved does not match value set.') + return + end if + + call tbl%get(key('float'),get_float) + if (get_float /= set_float) then + call test_failed(error,'float value retrieved does not match value set.') + return + end if + + call tbl%get(key('double'),get_double) + if (get_double /= set_double) then + call test_failed(error,'double value retrieved does not match value set.') + return + end if + + call tbl%get(key('char'),get_char) + if (get_char /= set_char) then + call test_failed(error,'char value retrieved does not match value set.') + return + end if + + call tbl%get(key('bool'),get_bool) + if (get_bool .neqv. set_bool) then + call test_failed(error,'logical value retrieved does not match value set.') + return + end if + + end subroutine test_fhash_intrinsics + + + !> Test intrinsic pointer set and retrieve + subroutine test_fhash_intrinsic_ptrs(error) + type(error_t), allocatable, intent(out) :: error + + type(fhash_tbl_t) :: tbl + integer(int32), target :: set_int32 + integer(int64), target :: set_int64 + real(sp), target :: set_float + real(dp), target :: set_double + character(:), allocatable, target :: set_char + logical, target :: set_bool + + integer(int32), pointer :: get_int32 + integer(int64), pointer :: get_int64 + real(sp), pointer :: get_float + real(dp), pointer :: get_double + character(:), pointer :: set_r, get_char + logical, pointer :: get_bool + + ! Set pointers + set_int32 =123 + call tbl%set_ptr(key('int32'),set_int32) + + set_int64 = 456 + call tbl%set_ptr(key('int64'),set_int64) + + set_float = 1.0_sp + call tbl%set_ptr(key('float'),set_float) + + set_double = 2.0_dp + call tbl%set_ptr(key('double'),set_double) + + set_char = 'Hello world' + call tbl%set_ptr(key('char'),set_char) + + set_bool = .false. + call tbl%set_ptr(key('bool'),set_bool) + + ! Get pointers + call tbl%get_ptr(key('int32'),get_int32) + if (.not.associated(get_int32,set_int32)) then + call test_failed(error,'int32 pointer retrieved is not associated with variable set.') + return + end if + + call tbl%get_ptr(key('int64'),get_int64) + if (.not.associated(get_int64,set_int64)) then + call test_failed(error,'int64 pointer retrieved is not associated with variable set.') + return + end if + + call tbl%get_ptr(key('float'),get_float) + if (.not.associated(get_float,set_float)) then + call test_failed(error,'float pointer retrieved is not associated with variable set.') + return + end if + + call tbl%get_ptr(key('double'),get_double) + if (.not.associated(get_double,set_double)) then + call test_failed(error,'double pointer retrieved is not associated with variable set.') + return + end if + + call tbl%get_ptr(key('char'),get_char) + if (.not.associated(get_char,set_char)) then + call test_failed(error,'char pointer retrieved is not associated with variable set.') + return + end if + + call tbl%get_ptr(key('bool'),get_bool) + if (.not.associated(get_bool,set_bool)) then + call test_failed(error,'bool pointer retrieved is not associated with variable set.') + return + end if + + end subroutine test_fhash_intrinsic_ptrs + + + !> Store a value and retrieve a pointer + subroutine test_fhash_value_pointer(error) + type(error_t), allocatable, intent(out) :: error + + type(fhash_tbl_t) :: tbl + integer :: stat + character(:), pointer :: ptr + + call tbl%set(key('key'),'A string to store') + + call tbl%check_key(key('key'),stat) + if (stat /= 0) then + call test_failed(error,'Key check failed, error setting key-value.') + return + end if + + call tbl%get_ptr(key('key'),ptr) + + if (.not.associated(ptr)) then + call test_failed(error,'Retrieved pointer is not associated.') + return + end if + + if (ptr /= 'A string to store') then + call test_failed(error,'Retrieved pointer has the wrong value.') + return + end if + + end subroutine test_fhash_value_pointer + + + !> Store a pointer and retrieve a value + subroutine test_fhash_pointer_value(error) + type(error_t), allocatable, intent(out) :: error + + type(fhash_tbl_t) :: tbl + integer :: stat + character(:), allocatable :: set_char + character(:), allocatable :: get_char + + set_char = 'A string to store' + + call tbl%set_ptr(key('key'),set_char) + + call tbl%check_key(key('key'),stat) + if (stat /= 0) then + call test_failed(error,'Key check failed, error setting key-value.') + return + end if + + ! Mutate value + set_char(:) = 'An updated string' + + call tbl%get(key('key'),get_char,stat) + + if (stat /= 0 .OR. .not.allocated(get_char)) then + call test_failed(error,'Retrieved pointer is not associated.') + return + end if + + if (get_char /= set_char) then + call test_failed(error,'Retrieved pointer has the wrong value.') + return + end if + + end subroutine test_fhash_pointer_value + + + !> Test set and unset + subroutine test_fhash_unset(error) + use fhash_tbl, only: FHASH_KEY_NOT_FOUND + type(error_t), allocatable, intent(out) :: error + + type(fhash_tbl_t) :: tbl + integer :: var, stat + + call tbl%set(key('key'),'A string to store') + + call tbl%check_key(key('key'),stat) + if (stat /= 0) then + call test_failed(error,'Key check failed, error setting key-value.') + return + end if + + call tbl%unset(key('key')) + + call tbl%get(key('key'),var,stat) + if (stat /= FHASH_KEY_NOT_FOUND) then + print *, 'Stat = ',stat + call test_failed(error,'Key unset failed, tbl%get: expecting stat = FHASH_KEY_NOT_FOUND') + return + end if + + call tbl%check_key(key('key'),stat) + if (stat /= FHASH_KEY_NOT_FOUND) then + print *, 'Stat = ',stat + call test_failed(error,'Key unset failed, tbl%check_key: expecting stat = FHASH_KEY_NOT_FOUND') + return + end if + + end subroutine test_fhash_unset + + + subroutine test_fhash_derived_type_value(error) + type(error_t), allocatable, intent(out) :: error + + type string_t + character(:), allocatable :: s + end type string_t + + type(fhash_tbl_t) :: tbl + type(string_t) :: str1, str2 + + str1%s = 'Hello fhash' + call tbl%set(key('key_1'), value=str1) + + call fhash_get_string(tbl,key('key_1'),str2,error) + + if (str1%s /= str2%s) then + call test_failed(error,'Retrieved derived type does not match value set') + return + end if + + contains + + !> Custom getter for string_t type + subroutine fhash_get_string(tbl,k,string,error) + use fhash, only: fhash_key_t + type(fhash_tbl_t), intent(in) :: tbl + class(fhash_key_t), intent(in) :: k + type(string_t), intent(out) :: string + type(error_t), allocatable, intent(out) :: error + + integer :: stat + class(*), allocatable :: data + + call tbl%get_raw(k,data,stat) + + if (stat /= 0) then + call test_failed(error,'Error while trying to retrieve derived type') + return + end if + + select type(d=>data) + type is (string_t) + string = d + class default + call test_failed(error,'Retrieved value type does not match expected derived type') + return + end select + + end subroutine fhash_get_string + + end subroutine test_fhash_derived_type_value + + + !> Try to retrieve invalid keys + subroutine test_fhash_invalid_keys(error) + use fhash_tbl, only: FHASH_EMPTY_TABLE, FHASH_KEY_NOT_FOUND, FHASH_FOUND_WRONG_TYPE + type(error_t), allocatable, intent(out) :: error + + type(fhash_tbl_t) :: tbl + integer :: var, stat + + call tbl%get(key('key1'),var,stat) + + if (stat /= FHASH_EMPTY_TABLE) then + call test_failed(error,'Wrong stat value returned, expecting FHASH_EMPTY_TABLE.') + return + end if + + call tbl%set(key('key2'),'A string to store') + + call tbl%get(key('key3'),var,stat) + + if (stat /= FHASH_KEY_NOT_FOUND) then + call test_failed(error,'Wrong stat value returned, expecting FHASH_KEY_NOT_FOUND.') + return + end if + + call tbl%get(key('key2'),var,stat) + + if (stat /= FHASH_FOUND_WRONG_TYPE) then + print *, 'stat = ',stat + call test_failed(error,'Wrong stat value returned, expecting FHASH_FOUND_WRONG_TYPE.') + return + end if + + end subroutine test_fhash_invalid_keys + + !> Check stats for empty table + subroutine test_fhash_stats_empty(error) + type(error_t), allocatable, intent(out) :: error + + type(fhash_tbl_t) :: tbl + integer :: num_buckets, num_items, num_collisions, max_depth + + call tbl%stats(num_buckets,num_items,num_collisions,max_depth) + + if (num_buckets /= 0) then + print *, 'num_buckets: ', num_buckets + call test_failed(error,'empty table returned non-zero for num_buckets') + return + end if + + if (num_items /= 0) then + print *, 'num_items: ', num_items + call test_failed(error,'empty table returned non-zero for num_items') + return + end if + + if (num_collisions /= 0) then + print *, 'num_collisions: ', num_collisions + call test_failed(error,'empty table returned non-zero for num_collisions') + return + end if + + if (max_depth > 0) then + print *, 'max_depth: ', max_depth + call test_failed(error,'empty table returned positive for max_depth') + return + end if + + end subroutine test_fhash_stats_empty + + + !> Store lots of values and check stats + subroutine test_fhash_balanced_load(error) + type(error_t), allocatable, intent(out) :: error + + type(fhash_tbl_t) :: tbl + integer :: i, j, val, stat + integer :: num_buckets, num_items, num_collisions, max_depth + character(2) :: key_str + + call tbl%allocate(877) + + do i=0,25 + do j=0,25 + + key_str = char(iachar('a')+i)//char(iachar('a')+j) + call tbl%set(key(key_str),i*j) + + end do + end do + + do i=0,25 + do j=0,25 + + key_str = char(iachar('a')+i)//char(iachar('a')+j) + call tbl%get(key(key_str),val,stat) + + if (stat /= 0) then + call test_failed(error,'Error while retrieving value for key"'//key_str//'"') + return + end if + + if (val /= i*j) then + call test_failed(error,'Incorrect value retrieved for key"'//key_str//'"') + return + end if + + end do + end do + + call tbl%stats(num_buckets,num_items,num_collisions,max_depth) + + if (num_buckets /= 877) then + print *, 'num_buckets: ', num_buckets + call test_failed(error,'stats routine returned incorrect value for num_buckets') + return + end if + + if (num_items /= 26*26) then + print *, 'num_items: ', num_items + call test_failed(error,'stats routine returned incorrect value for num_items') + return + end if + + if (num_collisions > 200) then + print *, 'num_collisions: ', num_collisions + call test_failed(error,'stats routine returned a larger than expected value for num_collisions') + return + end if + + if (max_depth > 5) then + print *, 'max_depth: ', max_depth + call test_failed(error,'stats routine returned a larger than expected value for max_depth') + return + end if + + end subroutine test_fhash_balanced_load + + +end module test_tbl \ No newline at end of file diff --git a/thirdparty/fhash/test/test_tbl_iter.f90 b/thirdparty/fhash/test/test_tbl_iter.f90 new file mode 100644 index 00000000..54cb9f18 --- /dev/null +++ b/thirdparty/fhash/test/test_tbl_iter.f90 @@ -0,0 +1,128 @@ +module test_tbl_iter + use iso_fortran_env, only: sp=>real32, dp=>real64, int32, int64 + use TestLite_suite, only : new_unittest, unittest_t, error_t, test_failed + use fhash, only: fhash_key_t, key=>fhash_key, fhash_tbl_t, fhash_iter_t + implicit none + + private + public collect_tbl_iter + + contains + + !> Collect all exported unit tests + subroutine collect_tbl_iter(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("fhash-iter-intrinsics", test_iter_intrinsics) & + ] + + end subroutine collect_tbl_iter + + !> Test intrinsic set and retrieve + subroutine test_iter_intrinsics(error) + type(error_t), allocatable, intent(out) :: error + + type(fhash_tbl_t) :: tbl + integer(int32) :: set_int32, get_int32 + integer(int64) :: set_int64, get_int64 + real(sp) :: set_float, get_float + real(dp) :: set_double, get_double + character(:), allocatable :: set_char, get_char + logical :: set_bool, get_bool + + integer :: count + type(fhash_iter_t) :: iter + class(fhash_key_t), allocatable :: ikey + class(*), allocatable :: idata + + ! Set values + call tbl%set(key('int32'),123_int32) + call tbl%set(key('int64'),456_int64) + call tbl%set(key('float'),1.0_sp) + call tbl%set(key('double'),2.0_dp) + call tbl%set(key('char'),'Hello world') + call tbl%set(key('bool'),.false.) + + ! Iterate over stored keys and check values + count = 0 + iter = fhash_iter_t(tbl) + do while(iter%next(ikey,idata)) + + count = count + 1 + + select type(d=>idata) + type is(integer(int32)) + if (ikey%to_string() /= 'int32') then + call test_failed(error,'int32 key has incorrect value') + return + end if + if (d /= 123_int32) then + call test_failed(error,'int32 data has incorrect value') + return + end if + + type is(integer(int64)) + if (ikey%to_string() /= 'int64') then + call test_failed(error,'int64 key has incorrect value') + return + end if + if (d /= 456_int64) then + call test_failed(error,'int64 data has incorrect value') + return + end if + + type is(real(sp)) + if (ikey%to_string() /= 'float') then + call test_failed(error,'float key has incorrect value') + return + end if + if (d /= 1.0_sp) then + call test_failed(error,'float data has incorrect value') + return + end if + + type is(real(dp)) + if (ikey%to_string() /= 'double') then + call test_failed(error,'double key has incorrect value') + return + end if + if (d /= 2.0_dp) then + call test_failed(error,'double data has incorrect value') + return + end if + + type is(character(*)) + if (ikey%to_string() /= 'char') then + call test_failed(error,'char key has incorrect value') + return + end if + if (d /= 'Hello world') then + call test_failed(error,'char data has incorrect value') + return + end if + + type is(logical) + if (ikey%to_string() /= 'bool') then + call test_failed(error,'bool key has incorrect value') + return + end if + if (d) then + call test_failed(error,'bool data has incorrect value') + return + end if + + end select + + end do + + if (count /= 6) then + call test_failed(error,'incorrect number of items iteracted over') + return + end if + + end subroutine test_iter_intrinsics + + end module test_tbl_iter \ No newline at end of file