Fetching contributors…
Cannot retrieve contributors at this time
237 lines (181 sloc) 5.96 KB
module m_common_elstack
#ifndef DUMMYLIB
use fox_m_fsys_array_str, only: str_vs, vs_str
use m_common_error, only: FoX_fatal
use m_common_content_model, only: content_particle_t, checkCP, &
elementContentCP, emptyContentCP, checkCPToEnd
implicit none
private
! Element stack during parsing. Keeps track of element names
! and optionally tracks validity of content model
! Initial stack size:
integer, parameter :: STACK_SIZE_INIT = 10
! Multiplier when stack is exceeded:
real, parameter :: STACK_SIZE_MULT = 1.5
type :: elstack_item
character, dimension(:), pointer :: name => null()
type(content_particle_t), pointer :: cp => null()
end type elstack_item
type :: elstack_t
private
integer :: n_items
type(elstack_item), pointer, dimension(:) :: stack => null()
end type elstack_t
public :: elstack_t
public :: push_elstack, pop_elstack, init_elstack, destroy_elstack, reset_elstack, print_elstack
public :: get_top_elstack, is_empty
public :: checkContentModel
public :: checkContentModelToEnd
public :: elementContent
public :: emptyContent
public :: len
interface len
module procedure number_of_items
end interface
interface is_empty
module procedure is_empty_elstack
end interface
contains
subroutine init_elstack(elstack)
type(elstack_t), intent(inout) :: elstack
! We go from 0 (and initialize the 0th string to "")
! in order that we can safely check the top of an
! empty stack
allocate(elstack%stack(0:STACK_SIZE_INIT))
elstack%n_items = 0
allocate(elstack%stack(0)%name(0))
end subroutine init_elstack
subroutine destroy_elstack(elstack)
type(elstack_t), intent(inout) :: elstack
integer :: i
do i = 0, elstack % n_items
deallocate(elstack%stack(i)%name)
enddo
deallocate(elstack%stack)
end subroutine destroy_elstack
subroutine reset_elstack(elstack)
type(elstack_t), intent(inout) :: elstack
call destroy_elstack(elstack)
call init_elstack(elstack)
end subroutine reset_elstack
subroutine resize_elstack(elstack)
type(elstack_t), intent(inout) :: elstack
type(elstack_item), dimension(0:ubound(elstack%stack,1)) :: temp
integer :: i, s
s = ubound(elstack%stack, 1)
do i = 0, s
temp(i)%name => elstack%stack(i)%name
temp(i)%cp => elstack%stack(i)%cp
enddo
deallocate(elstack%stack)
allocate(elstack%stack(0:nint(s*STACK_SIZE_MULT)))
do i = 0, s
elstack%stack(i)%name => temp(i)%name
elstack%stack(i)%cp => temp(i)%cp
enddo
end subroutine resize_elstack
pure function is_empty_elstack(elstack) result(answer)
type(elstack_t), intent(in) :: elstack
logical :: answer
answer = (elstack%n_items == 0)
end function is_empty_elstack
function number_of_items(elstack) result(n)
type(elstack_t), intent(in) :: elstack
integer :: n
n = elstack%n_items
end function number_of_items
subroutine push_elstack(elstack, name, cp)
type(elstack_t), intent(inout) :: elstack
character(len=*), intent(in) :: name
type(content_particle_t), pointer, optional :: cp
integer :: n
n = elstack%n_items
n = n + 1
if (n == size(elstack%stack)) then
call resize_elstack(elstack)
endif
allocate(elstack%stack(n)%name(len(name)))
elstack%stack(n)%name = vs_str(name)
if (present(cp)) elstack%stack(n)%cp => cp
elstack%n_items = n
end subroutine push_elstack
function pop_elstack(elstack) result(item)
type(elstack_t), intent(inout) :: elstack
character(len=merge(size(elstack%stack(elstack%n_items)%name), 0, elstack%n_items > 0)) :: item
integer :: n
n = elstack%n_items
if (n == 0) then
call FoX_fatal("Element stack empty")
endif
item = str_vs(elstack%stack(n)%name)
deallocate(elstack%stack(n)%name)
elstack%n_items = n - 1
end function pop_elstack
pure function get_top_elstack(elstack) result(item)
! Get the top element of the stack, *without popping it*.
type(elstack_t), intent(in) :: elstack
character(len=merge(size(elstack%stack(elstack%n_items)%name), 0, elstack%n_items > 0)) :: item
integer :: n
n = elstack%n_items
if (n==0) then
item = ""
else
item = str_vs(elstack%stack(n)%name)
endif
end function get_top_elstack
function checkContentModel(elstack, name) result(p)
type(elstack_t), intent(inout) :: elstack
character(len=*), intent(in) :: name
logical :: p
type(content_particle_t), pointer :: cp
integer :: n
n = elstack%n_items
if (n==0) then
p = .true.
else
cp => elstack%stack(n)%cp
p = checkCP(cp, name)
elstack%stack(n)%cp => cp
endif
end function checkContentModel
function checkContentModelToEnd(elstack) result(p)
type(elstack_t), intent(inout) :: elstack
logical :: p
type(content_particle_t), pointer :: cp
integer :: n
n = elstack%n_items
cp => elstack%stack(n)%cp
p = checkCPToEnd(cp)
end function checkContentModelToEnd
function elementContent(elstack) result(p)
type(elstack_t), intent(in) :: elstack
logical :: p
integer :: n
n = elstack%n_items
if (n==0) then
p = .false.
else
p = elementContentCP(elstack%stack(n)%cp)
endif
end function elementContent
function emptyContent(elstack) result(p)
type(elstack_t), intent(in) :: elstack
logical :: p
integer :: n
n = elstack%n_items
if (n==0) then
p = .false.
else
p = emptyContentCP(elstack%stack(n)%cp)
endif
end function emptyContent
subroutine print_elstack(elstack,unit)
type(elstack_t), intent(in) :: elstack
integer, intent(in) :: unit
integer :: i
do i = elstack%n_items, 1, -1
write(unit=unit,fmt=*) elstack%stack(i)%name
enddo
end subroutine print_elstack
#endif
end module m_common_elstack