namespace.F90

Go to the documentation of this file.

!! Copyright (C) 2019 M. Oliveira, S. Ohlmann
!!
!! This Source Code Form is subject to the terms of the Mozilla Public
!! License, v. 2.0. If a copy of the MPL was not distributed with this
!! file, You can obtain one at https://mozilla.org/MPL/2.0/.
!!
 
#include "global.h"
 
module namespace_oct_m
  use global_oct_m
  use mpi_oct_m
  implicit none
 
  private
  public ::          &
    namespace_t,     &
    global_namespace
 
  integer, parameter, public :: MAX_NAMESPACE_LEN = 128
 
  type :: namespace_t
    private
    character(len=MAX_NAMESPACE_LEN) :: name = ""
    type(namespace_t), pointer, public :: parent => null()
  contains
    procedure :: get => namespace_get
    procedure :: len => namespace_len
    generic   :: operator(==) => equal
    procedure :: equal => namespace_equal
    procedure :: contains => namespace_contains
    procedure :: is_contained_in => namespace_is_contained_in
    procedure :: get_hash32 => namespace_get_hash32
  end type namespace_t
 
  interface namespace_t
    procedure namespace_constructor
  end interface namespace_t
 
  type(namespace_t) :: global_namespace
 
contains
 
  !---------------------------------------------------------
  recursive type(namespace_t) function namespace_constructor(name, parent, delimiter)
    character(len=*),                    intent(in) :: name
    type(namespace_t), optional, target, intent(in) :: parent
    character(len=1),  optional,         intent(in) :: delimiter
 
    integer :: total_len, parent_len
    character(len=1) :: delimiter_
 
    if (present(delimiter)) then
      delimiter_ = delimiter
    else
      delimiter_ = '.'
    end if
 
    ! Calculate total length of namespace, including the parent
    total_len = len_trim(name)
    if (present(parent)) then
      parent_len = parent%len()
      if (parent_len > 0) then
        total_len = total_len + parent_len + 1
      end if
    end if
 
    ! If total length is too large, stop and explain the reason
    if (total_len > max_namespace_len) then
      write(stderr,'(a)') '*** Fatal Error (description follows)'
      write(stderr,'(a)') 'Trying to create the following namespace:'
      if (present(parent)) then
        if (parent%len() > 0) then
          write(stderr,'(a)') trim(parent%get()) // delimiter_ // name
        end if
      else
        write(stderr,'(a)') name
      end if
      write(stderr,'(a,i4,a)') 'but namespaces are limited to ', max_namespace_len, ' characters'
      call mpi_world%abort()
    end if
 
    ! We do not allow the creation of empty namespaces, as that might lead to ambiguous paths
    assert(len_trim(name) > 0)
 
    namespace_constructor%name = name
    if (present(parent)) then
      namespace_constructor%parent => parent
    else
      nullify(namespace_constructor%parent)
    end if
 
  end function namespace_constructor
 
  ! ---------------------------------------------------------
  !
  recursive function namespace_get(this, delimiter) result(name)
    class(namespace_t),           intent(in) :: this
    character(len=1),   optional, intent(in) :: delimiter
    character(len=MAX_NAMESPACE_LEN) :: name
 
    character(len=1) :: delimiter_
 
    if (present(delimiter)) then
      delimiter_ = delimiter
    else
      delimiter_ = '.'
    end if
 
    name = this%name
    if (associated(this%parent)) then
      if (len_trim(name) > 0 .and. this%parent%len() > 0) then
        name = trim(this%parent%get(delimiter_)) // delimiter_ // trim(name)
      end if
    end if
 
  end function namespace_get
 
  ! ---------------------------------------------------------
  pure recursive function namespace_len(this)
    class(namespace_t), intent(in) :: this
    integer :: namespace_len
 
    integer :: parent_len
 
    namespace_len = len_trim(this%name)
    if (associated(this%parent)) then
      parent_len = this%parent%len()
      if (parent_len > 0) then
        namespace_len = namespace_len + parent_len + 1
      end if
    end if
 
  end function namespace_len
 
  ! ---------------------------------------------------------
  elemental logical function namespace_equal(lhs, rhs)
    class(namespace_t), intent(in) :: lhs
    class(namespace_t), intent(in) :: rhs
 
    namespace_equal = lhs%name == rhs%name
 
  end function namespace_equal
 
  ! ---------------------------------------------------------
  logical function namespace_contains(this, namespace)
    class(namespace_t), target, intent(in) :: this
    type(namespace_t),  target, intent(in) :: namespace
 
    logical :: found_ancestor
    type(namespace_t),  pointer :: this_ancestor, namespace_ancestor
 
    ! Find if there is a common ancestor
    found_ancestor = .false.
    namespace_ancestor => namespace
    do while (associated(namespace_ancestor))
      found_ancestor = namespace_ancestor == this
      if (found_ancestor) exit
      namespace_ancestor => namespace_ancestor%parent
    end do
 
    if (found_ancestor) then
      ! Check if the remaining ancestors are also equal
      namespace_contains = .true.
      this_ancestor => this
      do while (associated(namespace_ancestor%parent) .and. associated(this_ancestor%parent))
        namespace_contains = namespace_ancestor%parent == this_ancestor%parent
        if (.not. namespace_contains) exit
        this_ancestor => this_ancestor%parent
        namespace_ancestor => namespace_ancestor%parent
      end do
    else
      ! We did not find a common ancestor
      namespace_contains = .false.
    end if
 
  end function namespace_contains
 
  ! ---------------------------------------------------------
  logical function namespace_is_contained_in(this, name, delimiter) result(is_contained)
    class(namespace_t), target, intent(in) :: this
    character(len=*),           intent(in) :: name
    character(len=1), optional, intent(in) :: delimiter
 
    integer :: si, se
    character(len=1) :: delimiter_
    type(namespace_t), target :: namespace
    type(namespace_t), pointer :: next, parent
 
    if (present(delimiter)) then
      delimiter_ = delimiter
    else
      delimiter_ = '.'
    end if
 
    ! Create temporary namespace from name
    si = index(name, delimiter_, back=.true.)
    namespace%name = name(si+1:len(name))
    next => namespace
    do while (si /= 0)
      se = si
      si = index(name(:se-1), delimiter_, back=.true.)
      allocate(next%parent)
      next%parent = namespace_t(name(si+1:se-1), delimiter=delimiter)
      next => next%parent
    end do
 
    ! Compare namespaces
    is_contained = namespace%contains(this)
 
    ! Deallocate all memory
    parent => namespace%parent
    do while (associated(parent))
      next => parent%parent
      deallocate(parent)
      parent => next
    end do
 
  end function namespace_is_contained_in
 
  ! ----------------------------------------------------------
  !
  function namespace_get_hash32(this) result(h)
    class(namespace_t), intent(in) :: this
    !!
 
    character(len=MAX_NAMESPACE_LEN) :: ns
    integer(int64)                   :: h
    integer                          :: i
    integer(int64), parameter        :: offset_basis = int(z'811C9DC5', int64)
    integer(int64), parameter        :: fnv_prime    = int(z'01000193', int64)
    integer(int64), parameter        :: mask32       = int(z'FFFFFFFF', int64)
 
    ns = this%get()
 
    h = offset_basis
    do i = 1, len_trim(ns)
      h = ieor(h, int(iachar(ns(i:i)), int64))
      h = h * fnv_prime   ! wraps modulo 2^32 by integer overflow on 2s complement
      h = iand(h, mask32)   ! Force mod 2^32 behavior (important on some compilers/opts)
    end do
 
  end function namespace_get_hash32
 
 
end module namespace_oct_m
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: