list.f90

Go to the documentation of this file.

!##############################################################################
!     ________  _____  ______________ 
!    / ____/  |/  / / / /_  __/  _/ / 
!   / /_  / /|_/ / / / / / /  / // /  
!  / __/ / /  / / /_/ / / / _/ // /___
! /_/   /_/  /_/\____/ /_/ /___/_____/                                     
!
! Copyright 2020 Bharat Mahajan
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!    http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!
!##############################################################################
 
    
module lists
 
    use fmutilbase
    
    implicit none
    
    private
 
    integer, parameter :: default_newslotsallocated = 5
 
     type, private :: listitem
        private
        logical :: valid = .false.
        class(*), pointer :: item
        contains
        private
        procedure :: add_listitem
        procedure :: del_listitem
        procedure :: isvalid_listitem
     end type listitem
 
 
 
    type, public :: list
        
        private
        
        integer, public :: status = 0
 
        integer :: usedslots = 0
 
        integer :: allocatedslots = 0
 
        integer :: newslotstoallocate = default_newslotsallocated
 
        type(listitem), dimension(:), allocatable :: listdata
 
    contains
    
        private
 
        procedure :: assignlist
 
        generic, public :: assignment(=) => assignlist
 
        ! procedure :: ConcatList
 
        ! !> Concatenate operator for the List type, this enables
        ! !! concatenationo of the two lists to create a new list 
        ! !! with the combined contents.
        ! generic, public :: assignment(//) => ConcatList
 
        ! Internal procedures
        procedure :: create_newslots        
        
        procedure, public :: size => list_size
 
        procedure, public :: pushback => push_back
 
        procedure, public :: popback => pop_back        
        
        procedure, public :: item => item_at
 
        procedure, public :: front => item_front
 
        procedure, public :: back => item_back
 
        procedure, public :: insert => item_insert
 
        procedure, public :: erase => item_erase
 
        procedure, public :: shrinktofit
 
        procedure, public :: clear
 
        final :: destroy
 
    end type list
 
 
contains
 
 
 
 
pure function list_size(me)
    implicit none
    class(list), intent(in) :: me
    integer :: list_size
 
    list_size = me%UsedSlots
end function list_size
 
 
 
 
 
 
function push_back(me, newitem) result(Index)
    implicit none
    class(list), intent(inout) :: me
    class(*), intent(in) :: newitem
    integer :: index
    
    index = 0
    
    if (me%UsedSlots == me%AllocatedSlots) then
        ! allocate new slots
        call me%create_newslots(me%NewSlotsToAllocate)
        if (me%status /= 0) return
    end if
    
    ! copy the item at the back of the list
    call me%ListData(me%UsedSlots+1)%add_listitem(newitem)
    me%UsedSlots = me%UsedSlots + 1
    index = me%UsedSlots
end function push_back
 
 
 
 
function pop_back(me) result(item)
    implicit none
    class(list), intent(inout) :: me
    class(*), allocatable :: item
        
    ! get the last item
    allocate(item, source=me%Listdata(me%UsedSlots)%item, stat=me%status)
 
    ! delete this item
    call me%ListData(me%UsedSlots)%del_listitem()
    me%UsedSlots = me%UsedSlots - 1
end function pop_back
 
 
function item_at(me, Index) result(item)
    implicit none
    class(list), intent(inout), target :: me
    integer, intent(in) :: index
 
    class(*), pointer :: item
        
    item => null()
    ! check if Index is valid
    if (index < 1 .OR. index > me%Size()) return
    ! If element is valid, return the pointer
    if (me%Listdata(index)%isvalid_listitem()) item=>me%Listdata(index)%item
end function item_at
 
 
 
 
function item_front(me) result(item)
    implicit none
    class(list), intent(inout) :: me
    class(*), allocatable :: item
    class(*), pointer :: ptr
    ptr => me%Item(1)
    allocate(item, source=ptr)
end function item_front
 
 
 
function item_back(me) result(item)
    implicit none
    class(list), intent(inout) :: me
    class(*), allocatable :: item
    class(*), pointer :: ptr
    ptr => me%Item(me%Size())
    allocate(item, source=ptr)
end function item_back
 
 
subroutine item_insert(me, pos, NewItem)
    implicit none
    class(list), intent(inout) :: me
    integer, intent(in) :: pos
    class(*), intent(in) :: NewItem
    
    integer :: ctr
 
    ! parameter check
    if (pos < 1 .OR. pos > (me%Size()+1)) then
        me%status = -1
        return
    end if
 
    ! expand internal array if needed
    if (me%Size() == me%AllocatedSlots) then
        ! allocate new slots
        call me%create_newslots(me%NewSlotsToAllocate)
        if (me%status /= 0) return
    end if
    
    ! Move the old list item pointers
    do ctr = me%Size(), pos, -1
        call me%ListData(ctr+1)%add_listitem(me%ListData(ctr)%item)
    end do
 
    ! insert the new item
    call me%ListData(pos)%add_listitem(newitem)
    me%UsedSlots = me%UsedSlots + 1
end subroutine item_insert
 
 
 
 
subroutine item_erase(me, pos)
    implicit none
    class(list), intent(inout) :: me
    integer, intent(in) :: pos
    
    integer :: ctr
    
    ! parameter check
    if (pos < 1 .OR. pos > me%Size()) then
        me%status = -1
        return
    end if
   
    ! delete the element
    call me%ListData(pos)%del_listitem()
 
    ! Move the other list item pointers
    do ctr = pos, me%Size()-1
        call me%ListData(ctr)%add_listitem(me%ListData(ctr+1)%item)
    end do
    me%UsedSlots = me%UsedSlots - 1
end subroutine item_erase
 
 
 
 
 
subroutine create_newslots(me, NumSlots)
    implicit none
    class(list), intent(inout) :: me
    integer, intent(in) :: NumSlots
 
    type(listitem), dimension(:), allocatable :: tmp
    integer :: ctr
 
    ! allocate new item array
    allocate(tmp(me%AllocatedSlots+numslots), stat=me%status)
        
    if (me%status == 0) then
        ! if List already has some slots
        if (me%UsedSlots /= 0) then
            ! copy the previous data pointers
            tmp(1:me%AllocatedSlots) = me%ListData
        end if
        ! expand the list array
        call move_alloc(from=tmp, to=me%ListData)
        me%AllocatedSlots = me%AllocatedSlots + numslots
    end if
end subroutine create_newslots
 
 
 
 
subroutine assignlist(lhs, rhs)
    implicit none
    class(list), intent(out) :: lhs
    class(list), intent(in) :: rhs
 
    integer :: ctr
 
    ! we assign the contents by moving all the items of rhs to lhs
 
    ! allocate memory for items array
    allocate(lhs%ListData(rhs%AllocatedSlots))
 
    ! copy items
    do ctr = 1, rhs%AllocatedSlots
        call lhs%ListData(ctr)%add_listitem(rhs%ListData(ctr)%item)
    end do
    
    ! copy List state
    lhs%status               = rhs%status
    lhs%NewSlotsToAllocate   = rhs%NewSlotsToAllocate
    lhs%UsedSlots            = rhs%UsedSlots
    lhs%AllocatedSlots       = rhs%AllocatedSlots 
end subroutine assignlist    
 
 
 
 
 
 
subroutine clear(me)
    implicit none
    class(list), intent(inout) :: me
 
    integer :: ctr
    ! clear slots
    do ctr = 1, me%Size()
        call me%ListData(ctr)%del_listitem()
    end do
    ! used slots are 0 now
    me%UsedSlots = 0
end subroutine clear
 
 
subroutine shrinktofit(me)
    implicit none
    class(list), intent(inout) :: me
 
    integer :: ctr
    type(listitem), dimension(:), allocatable :: tmp
 
    if (me%Size() < me%AllocatedSlots) then
        ! destroy the slots
        do ctr = me%Size()+1, me%AllocatedSlots
            call me%ListData(ctr)%del_listitem()
        end do
        me%AllocatedSlots = me%Size()
    end if
 
    if (me%AllocatedSlots < 1) then
        if (allocated(me%ListData)) deallocate(me%ListData, stat=me%status)
    else
        ! shrink the list data pointer array
        allocate(tmp(1:me%AllocatedSlots), stat=me%status)
        if (me%status == 0) then
            tmp = me%ListData(1:me%AllocatedSlots)
            call move_alloc(from=tmp, to=me%ListData)
        end if
    end if
end subroutine shrinktofit
 
 
 
 
subroutine destroy(me)
    implicit none
    type(list), intent(inout) :: me
 
    integer :: ctr
    
    ! free up memory held up by all the slots
    do ctr = 1, me%Size()
        call me%ListData(ctr)%del_listitem()
    end do
end subroutine destroy
 
 
 
! List Item procedures
 
elemental subroutine add_listitem(me, item)
    implicit none
    class(listitem), intent(inout) :: me
    class(*), intent(in) :: item
 
    integer :: status
 
    allocate(me%item, source=item, stat=status)
    if (status == 0) then
        me%Valid = .true.
    else
        me%Valid = .false.
        if (associated(me%item)) deallocate(me%item)
        me%item => null()
    end if
end subroutine add_listitem
 
 
 
subroutine del_listitem(me)
    implicit none
    class(listitem), intent(inout) :: me
 
    if (associated(me%item)) deallocate(me%item)
    me%item => null()
    me%Valid = .false.
end subroutine del_listitem
 
 
 
pure elemental function isvalid_listitem(me)
    implicit none
    class(listitem), intent(in) :: me
    logical :: isvalid_listitem
    isvalid_listitem = me%Valid
end function isvalid_listitem
 
end module lists