using pointers makes finalize general for GNU and Intel

This commit is contained in:
Sharan Roongta 2020-04-30 21:29:59 +02:00
parent 20b604a334
commit 10710bc446
1 changed files with 159 additions and 94 deletions

View File

@ -70,6 +70,8 @@ module YAML_types
tNode_get_byKey_asString => tNode_get_byKey_asString tNode_get_byKey_asString => tNode_get_byKey_asString
procedure :: & procedure :: &
tNode_get_byKey_asStrings => tNode_get_byKey_asStrings tNode_get_byKey_asStrings => tNode_get_byKey_asStrings
procedure :: &
getIndex => tNode_get_byKey_asIndex
generic :: & generic :: &
get => tNode_get_byIndex, & get => tNode_get_byIndex, &
@ -132,9 +134,7 @@ module YAML_types
asBools => tList_asBools asBools => tList_asBools
procedure :: & procedure :: &
asStrings => tList_asStrings asStrings => tList_asStrings
#ifndef __GFORTRAN__
final :: tList_finalize final :: tList_finalize
#endif
end type tList end type tList
type, extends(tList) :: tDict type, extends(tList) :: tDict
@ -146,18 +146,20 @@ module YAML_types
type :: tItem type :: tItem
character(len=:), allocatable :: key character(len=:), allocatable :: key
class(tNode), allocatable :: node class(tNode), pointer :: node => null()
class(tItem), pointer :: next => null() class(tItem), pointer :: next => null()
contains
final :: tItem_finalize
end type tItem end type tItem
abstract interface abstract interface
recursive function asFormattedString(self,indent) recursive subroutine asFormattedString(self,indent)
import tNode import tNode
character(len=:), allocatable :: asFormattedString
class(tNode), intent(in), target :: self class(tNode), intent(in), target :: self
integer, intent(in), optional :: indent integer, intent(in), optional :: indent
end function asFormattedString end subroutine asFormattedString
end interface end interface
@ -188,52 +190,76 @@ end subroutine YAML_types_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine unitTest subroutine unitTest
type(tScalar),target :: s1,s2 class(tNode), pointer :: s1,s2
allocate(tScalar::s1)
s1 = '1' allocate(tScalar::s2)
if(s1%asInt() /= 1) call IO_error(0,ext_msg='tScalar_asInt') select type(s1)
if(dNeq(s1%asFloat(),1.0_pReal)) call IO_error(0,ext_msg='tScalar_asFloat') class is(tScalar)
s1 = 'True' s1 = '1'
if(.not. s1%asBool()) call IO_error(0,ext_msg='tScalar_asBool') if(s1%asInt() /= 1) call IO_error(0,ext_msg='tScalar_asInt')
if(s1%asString() /= 'True') call IO_error(0,ext_msg='tScalar_asString') if(dNeq(s1%asFloat(),1.0_pReal)) call IO_error(0,ext_msg='tScalar_asFloat')
s1 = 'True'
if(.not. s1%asBool()) call IO_error(0,ext_msg='tScalar_asBool')
if(s1%asString() /= 'True') call IO_error(0,ext_msg='tScalar_asString')
end select
block block
type(tList), target :: l1, l2 class(tNode), pointer :: l1, l2, n
class(tNode), pointer :: n character(len=1) :: test = '2'
select type(s1)
class is(tScalar)
s1 = test
endselect
s1 = '2' select type(s2)
s2 = '3' class is(tScalar)
call l1%append(s1) s2 = '3'
call l1%append(s2) endselect
call l2%append(l1)
n => l1
if(any(l1%asInts() /= [2,3])) call IO_error(0,ext_msg='tList_asInts') allocate(tList::l1)
if(any(dNeq(l1%asFloats(),[2.0_pReal,3.0_pReal]))) call IO_error(0,ext_msg='tList_asFloats') select type(l1)
if(n%get_asInt(1) /= 2) call IO_error(0,ext_msg='byIndex_asInt') class is(tList)
if(dNeq(n%get_asFloat(2),3.0_pReal)) call IO_error(0,ext_msg='byIndex_asFloat') call l1%append(s1)
if(any(l2%get_asInts(1) /= [2,3])) call IO_error(0,ext_msg='byIndex_asInts') call l1%append(s2)
if(any(dNeq(l2%get_asFloats(1),[2.0_pReal,3.0_pReal]))) call IO_error(0,ext_msg='byIndex_asFloats') n => l1
end block if(any(l1%asInts() /= [2,3])) call IO_error(0,ext_msg='tList_asInts')
if(any(dNeq(l1%asFloats(),[2.0_pReal,3.0_pReal]))) call IO_error(0,ext_msg='tList_asFloats')
if(n%get_asInt(1) /= 2) call IO_error(0,ext_msg='byIndex_asInt')
if(dNeq(n%get_asFloat(2),3.0_pReal)) call IO_error(0,ext_msg='byIndex_asFloat')
endselect
block allocate(tList::l2)
type(tList), target :: l1, l2 select type(l2)
class(tNode), pointer :: n class is(tList)
s1 = 'True' call l2%append(l1)
s2 = 'False' if(any(l2%get_asInts(1) /= [2,3])) call IO_error(0,ext_msg='byIndex_asInts')
call l1%append(s1) if(any(dNeq(l2%get_asFloats(1),[2.0_pReal,3.0_pReal]))) call IO_error(0,ext_msg='byIndex_asFloats')
call l1%append(s2) n => l2
call l2%append(l1) end select
n=> l1 deallocate(n)
end block
if(any(l1%asBools() .neqv. [.true., .false.])) call IO_error(0,ext_msg='tList_asBools') block
if(any(l1%asStrings() /= ['True ','False'])) call IO_error(0,ext_msg='tList_asStrings') type(tList), target :: l1
if(n%get_asBool(2)) call IO_error(0,ext_msg='byIndex_asBool') type(tScalar),pointer :: s3,s4
if(n%get_asString(1) /= 'True') call IO_error(0,ext_msg='byIndex_asString') class(tNode), pointer :: n
if(any(l2%get_asBools(1) .neqv. [.true., .false.])) call IO_error(0,ext_msg='byIndex_asBools')
if(any(l2%get_asStrings(1) /= ['True ','False'])) call IO_error(0,ext_msg='byIndex_asStrings') allocate(tScalar::s1)
end block allocate(tScalar::s2)
s3 => s1%asScalar()
s4 => s2%asScalar()
s3 = 'True'
s4 = 'False'
call l1%append(s1)
call l1%append(s2)
n => l1
if(any(l1%asBools() .neqv. [.true., .false.])) call IO_error(0,ext_msg='tList_asBools')
if(any(l1%asStrings() /= ['True ','False'])) call IO_error(0,ext_msg='tList_asStrings')
if(n%get_asBool(2)) call IO_error(0,ext_msg='byIndex_asBool')
if(n%get_asString(1) /= 'True') call IO_error(0,ext_msg='byIndex_asString')
end block
end subroutine unitTest end subroutine unitTest
@ -676,14 +702,40 @@ function tNode_get_byKey_asStrings(self,k) result(nodeAsStrings)
end function tNode_get_byKey_asStrings end function tNode_get_byKey_asStrings
!-------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------------
!> @brief Return scalar as string !> @brief Returns the index of a key in a dictionary
!-------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------------
recursive function tScalar_asFormattedString(self,indent) function tNode_get_byKey_asIndex(self,key) result(keyIndex)
character(len=:), allocatable :: tScalar_asFormattedString class(tNode), intent(in), target :: self
class(tScalar), intent(in), target :: self character(len=*), intent(in) :: key
integer, intent(in), optional :: indent
integer :: keyIndex
integer :: i
type(tDict), pointer :: dict
type(tItem), pointer :: item
dict => self%asDict()
item => dict%first
do i = 1, dict%length
if(key == item%key) then
keyIndex = i
exit
else
item => item%next
endif
enddo
end function tNode_get_byKey_asIndex
!--------------------------------------------------------------------------------------------------
!> @brief Prints scalar as string
!--------------------------------------------------------------------------------------------------
recursive subroutine tScalar_asFormattedString(self,indent)
class (tScalar), intent(in), target :: self
integer, intent(in), optional :: indent
integer :: indent_ integer :: indent_
@ -693,22 +745,21 @@ recursive function tScalar_asFormattedString(self,indent)
indent_ = 0 indent_ = 0
endif endif
tScalar_asFormattedString = repeat(' ',indent_)//trim(self%value)//IO_EOL write (6,'(a)') trim(self%value)
end function tScalar_asFormattedString end subroutine tScalar_asFormattedString
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Return list as string (YAML block style) !> @brief Prints list as string (YAML block style)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
recursive function tList_asFormattedString(self,indent) result(str) recursive subroutine tList_asFormattedString(self,indent)
class(tList), intent(in), target :: self class (tList),intent(in),target :: self
integer, intent(in), optional :: indent integer, intent(in),optional :: indent
class(tItem), pointer :: item type (tItem), pointer :: item
character(len=:), allocatable :: str integer :: i, indent_
integer :: i,indent_
if(present(indent)) then if(present(indent)) then
indent_ = indent indent_ = indent
@ -718,24 +769,25 @@ recursive function tList_asFormattedString(self,indent) result(str)
item => self%first item => self%first
do i = 1, self%length do i = 1, self%length
str = str//repeat(' ',indent_)//'-'//IO_EOL//item%node%asFormattedString(indent_+2) if( i /= 1) write (6,'(a)',advance='NO') repeat(' ',indent_)
write (6,'(a)',advance='NO') '- '
call item%node%asFormattedString(indent_+2)
item => item%next item => item%next
enddo end do
end function tList_asFormattedString end subroutine tList_asFormattedString
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Return dictionary as string (YAML block style) !> @brief Prints dictionary as string (YAML block style)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
recursive function tDict_asFormattedString(self,indent) result(str) recursive subroutine tDict_asFormattedString(self,indent)
class(tDict), intent(in), target :: self class (tDict),intent(in),target :: self
integer, intent(in), optional :: indent integer, intent(in),optional :: indent
class(tItem), pointer :: item type (tItem),pointer :: item
character(len=:), allocatable :: str integer :: i, indent_
integer :: i,indent_
if(present(indent)) then if(present(indent)) then
indent_ = indent indent_ = indent
@ -745,11 +797,20 @@ recursive function tDict_asFormattedString(self,indent) result(str)
item => self%first item => self%first
do i = 1, self%length do i = 1, self%length
str = str//repeat(' ',indent_)//item%key//':'//IO_EOL//item%node%asFormattedString(indent_+2) if( i /= 1) write (6,'(a)',advance='NO') repeat(' ',indent_)
select type (node_ => item%node)
class is (tScalar)
write (6,'(a)',advance='NO') trim(item%key)//': '
call node_%asFormattedString(indent_+len_trim(item%key)+2)
class default
write (6,'(a)') trim(item%key)//':'
write (6,'(a)',advance='NO') repeat(' ',indent_+2)
call node_%asFormattedString(indent_+2)
end select
item => item%next item => item%next
enddo end do
end function tDict_asFormattedString end subroutine tDict_asFormattedString
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
@ -905,8 +966,8 @@ end function tList_asStrings
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine tList_append(self,node) subroutine tList_append(self,node)
class(tList), intent(inout) :: self class(tList), intent(inout) :: self
class(tNode), intent(in) :: node class(tNode), intent(in), target :: node
type(tItem), pointer :: item type(tItem), pointer :: item
@ -922,7 +983,7 @@ subroutine tList_append(self,node)
item => item%next item => item%next
end if end if
allocate(item%node,source=node) ! ToDo: Discuss ownership (copy vs referencing) item%node => node
self%length = self%length + 1 self%length = self%length + 1
end subroutine tList_append end subroutine tList_append
@ -933,9 +994,9 @@ end subroutine tList_append
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine tDict_set(self,key,node) subroutine tDict_set(self,key,node)
class (tDict), intent(inout) :: self class (tDict), intent(inout) :: self
character(len=*), intent(in) :: key character(len=*), intent(in) :: key
class(tNode), intent(in) :: node class(tNode), intent(in), target :: node
type(tItem), pointer :: item type(tItem), pointer :: item
@ -957,7 +1018,7 @@ subroutine tDict_set(self,key,node)
end if end if
item%key = key item%key = key
allocate(item%node,source=node) item%node => node
end subroutine tDict_set end subroutine tDict_set
@ -970,17 +1031,21 @@ recursive subroutine tList_finalize(self)
type (tList),intent(inout) :: self type (tList),intent(inout) :: self
type (tItem),pointer :: current, & deallocate(self%first)
next
current => self%first
do while (associated(current))
next => current%next
deallocate(current)
current => next
end do
end subroutine tList_finalize end subroutine tList_finalize
!--------------------------------------------------------------------------------------------------
!> @brief empties nodes and frees associated memory
!--------------------------------------------------------------------------------------------------
recursive subroutine tItem_finalize(self)
type(tItem),intent(inout) :: self
deallocate(self%node)
if(associated(self%next)) deallocate(self%next)
end subroutine tItem_finalize
end module YAML_types end module YAML_types