Compiler Explorer

Source code

module hash_integers
    use iso_fortran_env, only: int32,int64
    implicit none(type, external)
    private

public :: integer_key
    public :: node_clear
    public :: hash_integer
    public :: hash_integer_node
    public :: hash_integer_iterator

integer, parameter :: ISIZE = int32
    integer(ISIZE), parameter :: SMALL_SIZE  = 20_ISIZE

! Magic numbers to cope with gfortran finalization issues: reduce chance of invalid `logical`s
    integer, parameter, public :: HASH_ADDR = int64
    integer(HASH_ADDR), parameter :: HASH_TRUE  = int(Z'DEADC0DEFEEDFACE', HASH_ADDR)
    integer(HASH_ADDR), parameter :: HASH_FALSE = int(Z'BAADF00DBAADCAFE', HASH_ADDR)

type integer_key

integer :: ints = 0

contains

procedure, private :: hash_value_ints
        generic :: hash_value => hash_value_ints

procedure, private, pass(lhs) :: ints_equal
        generic :: operator(==) => ints_equal

end type integer_key

! <int, int> key-value type
    type kv_type
        integer(HASH_ADDR) :: set = HASH_FALSE
        type(integer_key)  :: key = integer_key(0)
        integer            :: value = 0
    end type kv_type

type :: hash_integer_node

type(kv_type) :: kv
        integer(HASH_ADDR) :: continues = HASH_FALSE ! placeholder for associated(next)
        type(hash_integer_node), pointer :: next => null()

contains

final :: node_final

end type hash_integer_node

type hash_integer
        private

integer :: n_buckets = 0
        integer, public :: n_keys = 0

integer(HASH_ADDR) :: initialized = HASH_FALSE ! placeholder for associated(buckets)
        type(hash_integer_node), pointer, public :: buckets(:) => null()

contains

! Reserve certain number of buckets.
        procedure, non_overridable, public :: reserve

! Set the value at a given a key.
        procedure, public :: set => set_integer

! Destroy structure
        procedure, non_overridable, public :: clear

! Is a key in the map?
        procedure, non_overridable, public :: contains => hash_contains

!procedure, private :: hash_assign
        !generic :: assignment(=) => hash_assign

!final :: hash_final

end type hash_integer

type hash_integer_iterator
        private

integer :: bucket_id
        type(hash_integer_node), pointer :: node_ptr => null()
        type(hash_integer),      pointer :: fhash_ptr => null()

contains

! Point to the first node in the hash table
        procedure, public :: first

! Point to the next node in the table
        procedure, public :: to_next

end type hash_integer_iterator

! bucket sizes: Fast - powers of 2
    integer :: j
    integer, parameter :: use_sizes(29) = [(2**j,j=2,30)]

interface operator(.not.)
        module procedure HASH_NOT
    end interface operator(.not.)

contains

subroutine reserve(this, n_buckets)
        class(hash_integer), intent(inout) :: this
        integer, intent(in) :: n_buckets
        integer :: i,nnew,nold

nnew = 0
        find_size: do i = 1, size(use_sizes)
            if (use_sizes(i) >= n_buckets) then
                nnew = use_sizes(i)
                exit find_size
            endif
        end do find_size

if (.not.this%initialized) then

if (.not.associated(this%buckets)) then 
               allocate(this%buckets(nnew))
               this%n_buckets   = nnew
            else
               this%n_buckets = size(this%buckets)
            endif   
               
            this%initialized = HASH_TRUE
            do i=1,nnew
               this%buckets(i)%continues = HASH_FALSE
               nullify(this%buckets(i)%next)
            end do

else

nold = size(this%buckets)
            if (nnew>nold) then
                call this%clear(dealloc=.true.)
                allocate(this%buckets(nnew))
                do i=1,nnew
                    this%buckets(i)%continues = HASH_FALSE
                    nullify(this%buckets(i)%next)
                end do                
                this%initialized = HASH_TRUE
                this%n_buckets = nnew
            else
                this%n_buckets = nold
            endif

endif

end subroutine reserve

pure subroutine set_only_kv(this,kv,is_new)
        class(hash_integer), intent(inout) :: this
        type(kv_type), intent(in) :: kv
        logical, intent(out) :: is_new
        integer :: bucket_id
        type(hash_integer_node), pointer :: node

bucket_id = get_bucket_id(kv%key%hash_value(), this%n_buckets)
        node      => this%buckets(bucket_id)
        is_new    = .false.

set_node: do while (associated(node))

if (.not.node%kv%set) then
                ! This node not yet used
                node%kv     = kv
                node%kv%set = HASH_TRUE
                is_new      = .true.
                exit set_node
            elseif (node%kv%key == kv%key) then
                ! Same key, but update value
                node%kv     = kv
                node%kv%set = HASH_TRUE
                is_new      = .false.
                exit set_node
            elseif (.not.node%continues) then
                ! Add trailing node
                allocate(node%next)
                node%continues   = HASH_TRUE
                node%next%kv     = kv
                node%next%kv%set = HASH_TRUE
                is_new  = .true.
                exit set_node
            else

! Move to the next node
                node => node%next

endif

end do set_node

if (is_new) this%n_keys = this%n_keys + 1

end subroutine set_only_kv

pure subroutine set_only(this,key,value,is_new)
        class(hash_integer), intent(inout), target :: this
        type(integer_key), intent(in), value :: key
        integer, intent(in), value :: value
        logical, intent(out) :: is_new
        call set_only_kv(this,kv_type(HASH_TRUE,key,value),is_new)
    end subroutine set_only

subroutine set_kv(this, kv, is_new)
        class(hash_integer), intent(inout) :: this
        type(kv_type), intent(in) :: kv
        logical, intent(out), optional :: is_new
        integer :: opt_nbuck
        logical :: new,resized

if (this%n_buckets<=0) call this%reserve(11)

! Set node only
        call set_only_kv(this,kv,new)

if (present(is_new)) is_new = new

end subroutine set_kv

subroutine set_integer(this, keyval, is_new)
        class(hash_integer), intent(inout) :: this
        integer, intent(in) :: keyval
        logical, intent(out), optional :: is_new
        call set_kv(this, kv_type(HASH_TRUE,integer_key(keyval), keyval), is_new)
    end subroutine set_integer

subroutine clear(this,dealloc)
        class(hash_integer), intent(inout) :: this
        logical, optional, intent(in) :: dealloc

integer :: i
        logical :: clean_memory

if (.not.HASH_VALID_INITIALIZATION(this%initialized)) return

if (present(dealloc)) then
            clean_memory = dealloc
        else
            clean_memory = .true.
        end if

! Instead of deallocating them, return a queue of pre-allocated nodes
        if (TRUE(this%initialized) .and. associated(this%buckets)) then
            do i = 1, size(this%buckets)
                call node_clear(this%buckets(i))
            enddo
        endif

this%n_keys = 0

if (clean_memory .and. TRUE(this%initialized)) then
            this%n_buckets = 0
            if (associated(this%buckets)) deallocate(this%buckets)
            nullify(this%buckets)
            this%initialized = HASH_FALSE
        endif

end subroutine clear

pure subroutine hash_final(this)
        type(hash_integer), intent(inout) :: this
        integer :: i

if (.not.HASH_VALID_INITIALIZATION(this%initialized)) return

if (TRUE(this%initialized)) then
            if (associated(this%buckets)) then
                do i = 1, size(this%buckets)
                    call node_clear(this%buckets(i))
                enddo
                deallocate(this%buckets)
            endif
            nullify(this%buckets)
        endif

this%initialized = HASH_FALSE
        this%n_keys = 0
        this%n_buckets = 0

end subroutine hash_final

pure elemental subroutine node_final(this)
        type(hash_integer_node), intent(inout) :: this

if (.not.HASH_VALID_INITIALIZATION(this%continues)) return

if (TRUE(this%continues)) then
            call node_clear(this%next)
            if (associated(this%next)) deallocate(this%next)
            nullify(this%next)
            this%continues = HASH_FALSE
        endif
        this%kv%set = HASH_FALSE

end subroutine node_final

! Deallocate kv is allocated.
    ! Call the clear method of the next node if the next pointer associated.
    ! Deallocate and nullify the next pointer.
    pure recursive subroutine node_clear(this)
        class(hash_integer_node), intent(inout) :: this

if (TRUE(this%continues)) then
            if (associated(this%next)) then 
               call node_clear(this%next)
               deallocate(this%next)
            endif   
            nullify(this%next)
            this%continues = HASH_FALSE
        endif
        this%kv%set = HASH_FALSE

end subroutine node_clear

pure subroutine begin(this, fhash_target)
        class(hash_integer_iterator), intent(inout) :: this
        type(hash_integer), target, intent(inout) :: fhash_target

this%bucket_id = 1
        this%node_ptr  => fhash_target%buckets(1)
        this%fhash_ptr => fhash_target
    end subroutine begin

function first(this, fhash_target) result(node)
        class(hash_integer_iterator), intent(inout) :: this
        type(hash_integer), target, intent(inout) :: fhash_target
        type(hash_integer_node), pointer :: node
        integer :: status

call begin(this,fhash_target)
        call next_ptr(this,node,status)
        if (status/=0) nullify(node)

end function first

pure subroutine next_ptr(this, node, status)
        class(hash_integer_iterator), intent(inout) :: this
        type(hash_integer_node), pointer, intent(out) :: node
        integer, optional, intent(out) :: status

nullify(node)

do while (.not. valid_node_pointer(this%node_ptr))
            if (this%bucket_id < this%fhash_ptr%n_buckets) then
                this%bucket_id = this%bucket_id + 1
                this%node_ptr => this%fhash_ptr%buckets(this%bucket_id)
            else
                if (present(status)) status = -1
                return
            endif
        enddo

node  => this%node_ptr
        if (present(status)) status = 0

! Position to the next key (may be empty)
        this%node_ptr => this%node_ptr%next

end subroutine next_ptr

function to_next(this) result(node)
        class(hash_integer_iterator), intent(inout) :: this
        type(hash_integer_node), pointer :: node
        integer :: status
        call next_ptr(this, node, status)
        if (status/=0) nullify(node)
    end function to_next

pure logical function valid_node_pointer(node_ptr)
        type(hash_integer_node), pointer, intent(in) :: node_ptr

valid_node_pointer = associated(node_ptr); if (.not.valid_node_pointer) return
        valid_node_pointer = TRUE(node_ptr%kv%set)

end function valid_node_pointer

! Bucket ID evaluation
    elemental integer function get_bucket_id(hash_value,n_buckets)
        integer, intent(in) :: hash_value,n_buckets
        get_bucket_id = IAND(hash_value,n_buckets-1)+1
    end function get_bucket_id

! This subroutine mimics sl_contains from the sorted integer array
    logical function hash_contains(this,key)
        class(hash_integer), intent(in) :: this
        integer, intent(in) :: key

integer :: ib

hash_contains = .false.
        if (.not.HASH_VALID_INITIALIZATION(this%initialized)) return

do ib=1,this%n_buckets
            if (bucket_contains(this%buckets(ib),key)) then
                hash_contains = .true.
                return
            end if
        end do

end function hash_contains

pure recursive logical function bucket_contains(bucket,key) result(is_in)
        type(hash_integer_node), intent(in) :: bucket
        integer, intent(in) :: key

if (.not.bucket%kv%set) then
            is_in = .false.
        elseif (bucket%kv%key%ints==key) then
            is_in = .true.
        else if (TRUE(bucket%continues) .and. associated(bucket%next)) then
            is_in = bucket_contains(bucket%next,key)
        else
            is_in = .false.
        end if

end function bucket_contains

subroutine hash_assign(this,that)
        class(hash_integer), intent(out) :: this
        class(hash_integer), intent(in), target  :: that

type(hash_integer_iterator) :: iter
        type(hash_integer_node), pointer :: node
        logical :: dummy

print *, 'initialized ',this%initialized, associated(this%buckets),this%n_keys,this%n_buckets

call clear(this)
        call this%reserve(n_buckets = that%n_buckets)

if (that%n_buckets<=0) return

! Initialize iterator
        iter%bucket_id = 1
        iter%node_ptr  => that%buckets(1)
        iter%fhash_ptr => that

node => iter%to_next()
        do while (associated(node))

call set_kv(this,node%kv,dummy)

node => iter%to_next()
        end do

end subroutine hash_assign

elemental logical function TRUE(addr)
        integer(HASH_ADDR), intent(in) :: addr
        TRUE = addr==HASH_TRUE
    end function TRUE

elemental logical function HASH_NOT(addr)
        integer(HASH_ADDR), intent(in) :: addr
        HASH_NOT = addr==HASH_FALSE
    end function HASH_NOT

elemental logical function HASH_VALID_INITIALIZATION(initialized) result(is_valid)
        integer(HASH_ADDR), intent(in) :: initialized
        is_valid = initialized==HASH_TRUE .or. initialized==HASH_FALSE
    end function HASH_VALID_INITIALIZATION

elemental function hash_value_ints(ints) result(hash)
        class(integer_key), intent(in) :: ints
        integer :: hash
        hash = 0
        hash = ieor(hash, ints%ints + 1640531527 + ishft(hash, 6) + ishft(hash, -2))
    end function hash_value_ints

elemental function ints_equal(lhs, rhs)
        class(integer_key), intent(in) :: lhs, rhs
        logical :: ints_equal
        ints_equal = lhs%ints==rhs%ints
    end function ints_equal

end module hash_integers

program test_hash_integer_driver
   use hash_integers         
   implicit none
   
   type :: derived
      type(hash_integer) :: hash
   end type derived
      
   logical :: success
   type(derived) :: a,b
   
   call a%hash%reserve(12)
   call a%hash%set(123)
   call a%hash%set(124)
   call a%hash%set(125)
   call b%hash%reserve(356)
   call b%hash%set(-1234)
   
   b = a ! CRASH!!

a = b

print *, a%hash%contains(123)

end program test_hash_integer_driver