module n3hash

  implicit none

  type, private:: hash_t
    integer, pointer:: table(:)
  end type

  logical, save, private:: toh_used = .false.
  type(hash_t), pointer, save, private:: binder(:)
  integer, parameter:: BINDER_INITSIZE = 16

  integer, parameter:: HASHTABLE_INITSIZE = 16
  integer, save:: hash_class = -1

  private:: table_clear, table_unused, table_init, table_dispose
  private:: get_free_slot

  interface hash_save
    module procedure hash_save_str
    module procedure hash_save_unit
  end interface

  interface hash_load
    module procedure hash_load_str
    module procedure hash_load_unit
  end interface

contains

  subroutine hashclass_init(stat)
    use n3object, only: class_new
    use n3error, only: error_add, ETHROUGH, error_set, EALLOC
    integer:: i
    integer, intent(out):: stat
    if (toh_used) then
      stat = 0
      return
    endif
    allocate(binder(BINDER_INITSIZE), stat=stat)
    if (stat /= 0) then
      call error_set(930010015, EALLOC)
      return
    endif
    do, i = 1, size(binder)
      call table_clear(binder(i))
    enddo
    call class_new('HASH', hash_class)
    if (hash_class < 0) then
      deallocate(binder, stat=stat)
      ! the problem isn't solved even if deallocate succeded.
      stat = -1
      call error_add(930010010, ETHROUGH)
      return
    endif
    toh_used = .true.
    stat = 0
  end subroutine

  subroutine hashclass_finalize(stat)
    use n3error, only: error_set, EDEALLOC
    integer, intent(out):: stat
    deallocate(binder, stat=stat)
    if (stat /= 0) then
      stat = -1
      call error_set(930010015, EDEALLOC)
    endif
  end subroutine

  subroutine table_clear(entry)
    type(hash_t), intent(out):: entry
    nullify(entry%table)
  end subroutine

  logical function table_unused(entry) result(result)
    type(hash_t), intent(in):: entry
    result = .not. associated(entry%table)
  end function

  subroutine table_init(entry, klen, vlen, stat)
    use n3error, only: error_set, EALLOC
    use n3hashraw, only: htinit_pre, htinit
    type(hash_t), intent(out):: entry
    integer, intent(in):: klen, vlen
    integer, intent(out):: stat
    integer:: tabsiz, i
    call htinit_pre(klen, vlen, tabsiz)
    allocate(entry%table(tabsiz), stat=stat)
    if (stat /= 0) then
      call error_set(930010020, EALLOC)
      return
    endif
    call htinit(entry%table, klen, vlen)
  end subroutine

  subroutine table_dispose(entry, stat)
    use n3error, only: error_set, EDEALLOC
    type(hash_t), intent(out):: entry
    integer, intent(out):: stat
    deallocate(entry%table, stat=stat)
    if (stat /= 0) then
      call error_set(930010030, EDEALLOC)
    endif
  end subroutine

  subroutine get_free_slot(id)
    integer, intent(out):: id
    do, id = 1, size(binder)
      if (table_unused(binder(id))) return
    enddo
    id = -1
  end subroutine

  subroutine hash_new(klen, vlen, handle)
    use n3error, only: error_add, error_set, ETHROUGH, ETABFUL
    use n3object, only: object_new
    integer, intent(in):: klen, vlen
    integer, intent(out):: handle
    integer:: i, stat
    call hashclass_init(stat)
    if (stat /= 0) goto 90000
    call get_free_slot(i)
    if (i < 0) then
      handle = -1
      call error_set(930010040, ETABFUL)
      goto 99999
    endif
    call table_init(binder(i), klen, vlen, stat)
    if (stat /= 0) goto 90000
    call object_new(hash_class, i, handle)
    goto 99999
    !
    90000 continue
    handle = -1
    call error_add(930010050, ETHROUGH)

    99999 continue
  end subroutine

  subroutine hash_dispose(handle, stat)
    use n3object, only: object_id
    use n3error, only: error_add, ETHROUGH, error_set, EBADID
    integer, intent(in):: handle
    integer, intent(out):: stat
    integer:: id
    call hashclass_init(stat)
    if (stat /= 0) goto 99999
    call object_id(handle, hash_class, id)
    if (id < 0) goto 99999
    if (id == 0 .or. id > size(binder)) then
      stat = -1
      call error_set(930010070, EBADID)
      return
    endif
    call table_dispose(binder(id), stat)
    if (stat /= 0) goto 99999
    return
    !
  99999 continue
    stat = -1
    call error_add(930010060, ETHROUGH)
  end subroutine

  subroutine hash_put(handle, key, value, stat)
    use n3object, only: object_id
    use n3error, only: error_add, error_set, ETHROUGH, EBADID, ETABFUL
    use n3hashraw, only: htput
    integer, intent(in):: handle
    integer, intent(in):: key(*)
    integer, intent(in):: value(*)
    integer, intent(out):: stat
    integer:: id
    !
    call hashclass_init(stat)
    if (stat /= 0) goto 99999
    call object_id(handle, hash_class, id)
    if (id < 0) goto 99999
    if (id == 0 .or. id > size(binder)) then
      stat = -1
      call error_set(930010080, EBADID)
      return
    endif
    call htput(binder(id)%table, key, value, stat)
    if (stat == 0) then
      ! --- THIS IS THE NORMAL RETURN ---
      stat = 0
      return
    endif
    call table_double(id, stat)
    if (stat /= 0) goto 99999
    call htput(binder(id)%table, key, value, stat)
    if (stat /= 0) then
      call error_set(930010085, ETABFUL)
      return
    endif
    stat = 0
    return
    !
  99999 continue
    stat = -1
    call error_add(930010090, ETHROUGH)
  end subroutine

  subroutine table_double(id, stat)
    use n3error, only: error_set, EALLOC, EDEALLOC
    use n3hashraw, only: IDX_ALL_ENTS, IDX_KLEN, IDX_VLEN, htwords, htcopy
    integer, intent(in):: id
    integer, intent(out):: stat
    integer, pointer:: otab(:)
    integer:: nalloc, nent_new
    otab => binder(id)%table
    nent_new = otab(IDX_ALL_ENTS) * 2
    nalloc = htwords(otab(IDX_KLEN), otab(IDX_VLEN), nent_new)
    allocate(binder(id)%table(nalloc), stat=stat)
    if (stat /= 0) then
      call error_set(930010100, EALLOC)
      return
    endif
    call htcopy(otab, binder(id)%table, nent_new)
    deallocate(otab, stat=stat)
    if (stat /= 0) then
      call error_set(930010105, EDEALLOC)
      return
    endif
  end subroutine

  subroutine hash_get(handle, key, value, stat)
    use n3object, only: object_id
    use n3error, only: error_add, error_set, ETHROUGH, EBADID, ENOTFOUND
    use n3hashraw, only: htrefer
    integer, intent(in):: handle
    integer, intent(in):: key(*)
    integer, intent(out):: value(*)
    integer, intent(out):: stat
    integer:: id
    !
    call hashclass_init(stat)
    if (stat /= 0) goto 99999
    call object_id(handle, hash_class, id)
    if (id < 0) goto 99999
    if (id == 0 .or. id > size(binder)) then
      stat = -1
      call error_set(930010110, EBADID)
      return
    endif
    call htrefer(binder(id)%table, key, value, stat)
    if (stat /= 0) then
      call error_set(930010120, ENOTFOUND)
      return
    endif
    stat = 0
    return
    !
  99999 continue
    stat = -1
    call error_add(930010130, ETHROUGH)
  end subroutine

  subroutine hash_each(handle, callback, args, stat)
    use n3object, only: object_id
    use n3error, only: error_add, error_set, ETHROUGH, EBADID, ENOTFOUND
    use n3hashraw, only: hteach
    integer, intent(in):: handle
    interface
      subroutine callback(key, value, args, stat)
        integer, intent(in):: key(*)
        integer, intent(in):: value(*)
        integer, intent(in):: args(*)
        integer, intent(out):: stat
      end subroutine
    end interface
    integer, intent(in):: args(*)
    integer, intent(out):: stat
    integer:: id
    !
    call hashclass_init(stat)
    if (stat /= 0) goto 99999
    call object_id(handle, hash_class, id)
    if (id < 0) goto 99999
    if (id == 0 .or. id > size(binder)) then
      stat = -1
      call error_set(930010140, EBADID)
      return
    endif
    call hteach(binder(id)%table, callback, args, stat)
    if (stat /= 0) goto 99999
    return
    !
  99999 continue
    stat = -1
    call error_add(930010150, ETHROUGH)
  end subroutine

  subroutine hash_delete(handle, key, stat)
    use n3object, only: object_id
    use n3error, only: error_add, error_set, ETHROUGH, EBADID, ENOTFOUND
    use n3hashraw, only: htdelete
    integer, intent(in):: handle
    integer, intent(in):: key(*)
    integer, intent(out):: stat
    integer:: id
    !
    call hashclass_init(stat)
    if (stat /= 0) goto 99999
    call object_id(handle, hash_class, id)
    if (id < 0) goto 99999
    if (id == 0 .or. id > size(binder)) then
      stat = -1
      call error_set(930010160, EBADID)
      return
    endif
    call htdelete(binder(id)%table, key, stat)
    if (stat /= 0) then
      call error_set(930010170, ENOTFOUND)
      return
    endif
    stat = 0
    return
    !
  99999 continue
    stat = -1
    call error_add(930010180, ETHROUGH)
  end subroutine

  subroutine hash_dump(handle, unit)
    use n3object, only: object_id
    use n3error, only: error_set, EBADID, die, error_add, ETHROUGH
    use n3hashraw, only: htdump
    integer, intent(in):: handle
    integer, intent(in), optional:: unit
    integer:: id, stat
    !
    call hashclass_init(stat)
    if (stat /= 0) goto 99999
    call object_id(handle, hash_class, id)
    if (id < 0) goto 99999
    if (id == 0 .or. id > size(binder)) then
      call error_set(930010190, EBADID)
      call die
      return
    endif
    call htdump(binder(id)%table, unit)
    return
    !
  99999 continue
    call error_add(930010200, ETHROUGH)
    call die
  end subroutine

  integer function hash_size(handle) result(result)
    use n3object, only: object_id
    use n3error, only: error_add, error_set, ETHROUGH, EBADID, ENOTFOUND
    use n3hashraw, only: htsize
    integer, intent(in):: handle
    integer:: id, stat
    !
    call hashclass_init(stat)
    if (stat /= 0) goto 99999
    call object_id(handle, hash_class, id)
    if (id < 0) goto 99999
    if (id == 0 .or. id > size(binder)) then
      result = -1
      call error_set(930010210, EBADID)
      return
    endif
    result = htsize(binder(id)%table)
    return
    !
  99999 continue
    result = -1
    call error_add(930010220, ETHROUGH)
  end function

  integer function hash_klen(handle) result(result)
    use n3object, only: object_id
    use n3error, only: error_add, error_set, ETHROUGH, EBADID, ENOTFOUND
    use n3hashraw, only: IDX_KLEN
    integer, intent(in):: handle
    integer:: id, stat
    !
    call hashclass_init(stat)
    if (stat /= 0) goto 99999
    call object_id(handle, hash_class, id)
    if (id < 0) goto 99999
    if (id == 0 .or. id > size(binder)) then
      result = -1
      call error_set(930010211, EBADID)
      return
    endif
    result = binder(id)%table(IDX_KLEN)
    return
    !
  99999 continue
    result = -1
    call error_add(930010221, ETHROUGH)
  end function

  integer function hash_vlen(handle) result(result)
    use n3object, only: object_id
    use n3error, only: error_add, error_set, ETHROUGH, EBADID, ENOTFOUND
    use n3hashraw, only: IDX_VLEN
    integer, intent(in):: handle
    integer:: id, stat
    !
    call hashclass_init(stat)
    if (stat /= 0) goto 99999
    call object_id(handle, hash_class, id)
    if (id < 0) goto 99999
    if (id == 0 .or. id > size(binder)) then
      result = -1
      call error_set(930010212, EBADID)
      return
    endif
    result = binder(id)%table(IDX_VLEN)
    return
    !
  99999 continue
    result = -1
    call error_add(930010222, ETHROUGH)
  end function

  subroutine hash_save_unit(handle, unit, stat)
    use n3object, only: object_id
    use n3error, only: error_add, error_set, ETHROUGH, EBADID, EWRITE
    integer, intent(in):: handle, unit
    integer, intent(out):: stat
    !
    integer:: id
    call hashclass_init(stat)
    if (stat /= 0) goto 99999
    call object_id(handle, hash_class, id)
    if (id < 0) goto 99999
    if (id == 0 .or. id > size(binder)) then
      stat = -1
      call error_set(930010230, EBADID)
      return
    endif
    !
    write(unit=unit, iostat=stat) binder(id)%table
    if (stat /= 0) then
      call error_set(930010240, EWRITE)
    endif
    return
    !
  99999 continue
    stat = -1
    call error_add(930010250, ETHROUGH)
  end subroutine

  subroutine hash_load_unit(unit, handle)
    use n3hashraw, only: htwordsbuf, IDX_KLEN, IDX_VLEN
    use n3object, only: object_id, object_new
    use n3error, only: error_add, error_set, ETHROUGH, EBADID, EREAD, EALLOC, &
      & ETABFUL, EBACKSPACE
    integer, intent(in):: unit
    integer, intent(out):: handle
    integer:: head(16), allocsize
    integer:: id, stat
    !
    handle = -1
    call hashclass_init(stat)
    if (stat /= 0) goto 99999
    read(unit=unit, iostat=stat) head
    if (stat /= 0) then
      call error_set(930010270, EREAD)
      return
    endif
    !
    backspace(unit=unit, iostat=stat)
    if (stat /= 0) then
      call error_set(930010275, EBACKSPACE)
      return
    endif
    !
    call get_free_slot(id)
    if (id < 0) then
      call error_set(930010275, ETABFUL)
      return
    endif
    call object_new(hash_class, id, handle)
    !
    allocsize = htwordsbuf(head)
    allocate(binder(id)%table(allocsize), stat=stat)
    if (stat /= 0) then
      call error_set(930010280, EALLOC)
      return
    endif
    !
    read(unit=unit, iostat=stat) binder(id)%table
    if (stat /= 0) then
      call error_set(930010290, EREAD)
      return
    endif
    return
    !
  99999 continue
    stat = -1
    call error_add(930010300, ETHROUGH)
  end subroutine

  subroutine hash_load_str(file, handle)
    use n3error, only: error_set, error_add, EOPEN, ECLOSE, ETHROUGH
    use n3io1, only: open
    character(*), intent(in):: file
    integer, intent(out):: handle
    integer:: stat, fp
    fp = open(file=file, access='sequential', form='unformatted', &
      & action='READ', status='OLD')
    if (fp < 0) then
      call error_set(930010310, EOPEN)
      handle = -1
      return
    endif
    call hash_load_unit(unit=fp, handle=handle)
    if (handle < 0) then
      call error_add(930010320, ETHROUGH)
      return
    endif
    close(unit=fp, iostat=stat)
    if (stat /= 0) then
      call error_set(930010330, ECLOSE)
      handle = -1
      return
    endif
  end subroutine

  subroutine hash_save_str(ihash, file, stat)
    use n3error, only: error_set, error_add, EOPEN, ECLOSE, ETHROUGH
    use n3io1, only: open
    integer, intent(in):: ihash
    character(*), intent(in):: file
    integer, intent(out):: stat
    integer:: fp
    fp = open(file=file, access='sequential', form='unformatted')
    if (fp < 0) then
      call error_set(930010340, EOPEN)
      return
    endif
    call hash_save_unit(ihash, unit=fp, stat=stat)
    if (stat < 0) then
      call error_add(930010350, ETHROUGH)
      return
    endif
    close(unit=fp, iostat=stat)
    if (stat /= 0) then
      call error_set(930010360, ECLOSE)
      return
    endif
  end subroutine

end module