module n3object

  implicit none
  public

  type object
    integer:: id
  end type
  private:: object

  !
  ! === OBJECT HANDLE LAYOUT ===
  ! 31 (MSB): reserved & set 0
  ! 30:       class code
  ! ...
  ! 24:       class code
  ! 23:       object id code
  ! ...
  ! 0  (LSB): object id code
  ! ===
  !
  ! YOU CAN TUNE CLASS_NBITS
  integer, parameter:: class_nbits = 9
  ! THE REST SHOULD BE CONFIGURED AUTOMATICALLY
  integer, parameter:: class_max = (2 ** class_nbits - 1)
  integer, parameter:: id_nbits = bit_size(0) - 1 - class_nbits
  integer, parameter:: id_mask = &
    & ishft(ishft(not(0), class_nbits + 1), -(class_nbits + 1))
  integer, parameter:: id_shifter = 0
  integer, parameter:: class_shifter = id_nbits
  integer, parameter:: class_mask = &
    & ishft(ishft(not(0), id_nbits + 1), -1)
  ! --- END OF AUTO CONFIGURED PARAMETERS ---

  integer, parameter:: N3NAMELEN = 32
  character(N3NAMELEN), private:: classtab(1:class_max)
  logical, save, private:: not_initialized = .true.

contains

  subroutine class_new(classname, klass)
    use n3error, only: error_set, EBLANKNAME, EDUPNAME, ETABFUL
    character(*), intent(in):: classname
    integer, intent(out):: klass
    integer:: i
    if (not_initialized) then
      classtab = ''
      not_initialized = .false.
    endif
    if (classname == '') then
      call error_set(930020010, EBLANKNAME)
      goto 99999
    endif
    do, i = 1, class_max
      if (classtab(i) == classname) then
        call error_set(930020020, EDUPNAME)
        goto 99999
      endif
    enddo
    do, i = 1, class_max
      if (classtab(i) == '') then
        classtab(i) = classname
        klass = i
        return
      endif
    enddo
    CALL error_set(930020030, ETABFUL)
    99999 continue
    klass = -1
  end subroutine

  subroutine class_find(classname, klass)
    use n3error, only: error_set, ENOTINIT, ENOTFOUND, EBLANKNAME
    character(*), intent(in):: classname
    integer, intent(out):: klass
    integer:: i
    if (not_initialized) then
      klass = -1
      call error_set(930020050, ENOTINIT)
      return
    endif
    if (classname == '') then
      klass = -1
      call error_set(930020055, EBLANKNAME)
    endif
    do, i = 1, class_max
      if (classtab(i) == classname) then
        klass = i
        return
      endif
    enddo
    klass = -1
    call error_set(930020060, ENOTFOUND)
  end subroutine

  subroutine class_dispose(klass, stat)
    use n3error, only: error_set, ENOTINIT, ENOTFOUND
    integer, intent(in):: klass
    integer, intent(out):: stat
    if (not_initialized) then
      stat = -1
      call error_set(930020070, ENOTINIT)
      return
    endif
    if (klass <= 0 .or. klass > class_max) goto 99999
    if (classtab(klass) == '') goto 99999
    classtab(klass) = ''
    stat = 0
    return
  99999 continue
    stat = -1
    call error_set(930020080, ENOTFOUND)
  end subroutine

  subroutine object_new(klass, id, handle)
    integer, intent(in):: klass
    integer, intent(in):: id
    integer, intent(out):: handle
    handle = ior(iand(ishft(klass, class_shifter), class_mask), &
    & iand(ishft(id, -id_shifter), id_mask))
  end subroutine

  subroutine object_classpart(handle, klass)
    integer, intent(in):: handle
    integer, intent(out):: klass
    klass = ishft(iand(handle, class_mask), -class_shifter)
  end subroutine

  subroutine object_idpart(handle, id)
    integer, intent(in):: handle
    integer, intent(out):: id
    id = ishft(iand(handle, id_mask), id_shifter)
  end subroutine

  subroutine object_id(handle, klass, id)
    use n3error, only: error_set, EBADCLASS
    integer, intent(in):: handle
    integer, intent(in):: klass
    integer, intent(out):: id
    integer:: klass2
    call object_classpart(handle, klass2)
    if (klass2 /= klass) then
      call error_set(930020040, EBADCLASS)
      id = -1
      return
    endif
    call object_idpart(handle, id)
  end subroutine

end module