using pointers makes finalize general for GNU and Intel

src/YAML_types.f90

@@ -70,6 +70,8 @@ module YAML_types
       tNode_get_byKey_asString    => tNode_get_byKey_asString
     procedure :: &
       tNode_get_byKey_asStrings   => tNode_get_byKey_asStrings
+    procedure :: &  
+      getIndex                    => tNode_get_byKey_asIndex
 
     generic :: &
       get           => tNode_get_byIndex, &
@@ -132,9 +134,7 @@ module YAML_types
       asBools   => tList_asBools
     procedure :: &
       asStrings => tList_asStrings
-#ifndef __GFORTRAN__
     final :: tList_finalize
-#endif
   end type tList
 
   type, extends(tList) :: tDict
@@ -146,18 +146,20 @@ module YAML_types
 
   type :: tItem
     character(len=:), allocatable :: key
-    class(tNode),     allocatable :: node
+    class(tNode),     pointer     :: node => null()
     class(tItem),     pointer     :: next => null()
+    
+    contains
+    final :: tItem_finalize
   end type tItem
 
   abstract interface
 
-    recursive function asFormattedString(self,indent)
+    recursive subroutine asFormattedString(self,indent)
       import tNode
-      character(len=:), allocatable      :: asFormattedString
       class(tNode), intent(in), target   :: self
       integer,      intent(in), optional :: indent
-    end function asFormattedString
+    end subroutine asFormattedString
 
   end interface
 
@@ -188,51 +190,75 @@ end subroutine YAML_types_init
 !--------------------------------------------------------------------------------------------------
 subroutine unitTest
 
-  type(tScalar),target :: s1,s2
+  class(tNode), pointer  :: s1,s2
-
+  allocate(tScalar::s1)
+  allocate(tScalar::s2)
+  select type(s1)
+    class is(tScalar) 
       s1 = '1'
       if(s1%asInt() /= 1)              call IO_error(0,ext_msg='tScalar_asInt')
       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
-    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)
+      class is(tScalar)
         s2 = '3'
+    endselect
+
+    allocate(tList::l1)
+    select type(l1)
+      class is(tList)
         call l1%append(s1)
         call l1%append(s2)
-    call l2%append(l1)
         n => l1
-
         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
+    
+    allocate(tList::l2)
+    select type(l2)
+      class is(tList)
+        call l2%append(l1)
         if(any(l2%get_asInts(1) /= [2,3]))                       call IO_error(0,ext_msg='byIndex_asInts')
         if(any(dNeq(l2%get_asFloats(1),[2.0_pReal,3.0_pReal])))  call IO_error(0,ext_msg='byIndex_asFloats')
+        n => l2
+    end select
+    deallocate(n)
    end block
 
    block
-    type(tList),  target  :: l1, l2
+     type(tList),  target  :: l1
+     type(tScalar),pointer :: s3,s4
      class(tNode), pointer :: n
-    s1 = 'True'
+    
-    s2 = 'False'
+     allocate(tScalar::s1)
+     allocate(tScalar::s2)
+     s3 => s1%asScalar()
+     s4 => s2%asScalar()
+     s3 = 'True'
+     s4 = 'False'
+    
      call l1%append(s1)
      call l1%append(s2)
-    call l2%append(l1)
      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')
-    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')
    end block
 
 end subroutine unitTest
@@ -676,12 +702,38 @@ function tNode_get_byKey_asStrings(self,k) result(nodeAsStrings)
 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)
+
+  class(tNode),     intent(in), target  :: self
+  character(len=*), intent(in)          :: key
+
+  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)
 
-  character(len=:), allocatable        :: tScalar_asFormattedString
   class (tScalar), intent(in), target    :: self
   integer,         intent(in), optional  :: indent
 
@@ -693,21 +745,20 @@ recursive function tScalar_asFormattedString(self,indent)
     indent_ = 0
   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
   integer,      intent(in),optional    :: indent
 
-  class(tItem),     pointer     :: item
+  type (tItem), pointer  :: item
-  character(len=:), allocatable :: str
   integer :: i, indent_
 
   if(present(indent)) then
@@ -718,23 +769,24 @@ recursive function tList_asFormattedString(self,indent) result(str)
 
   item => self%first
   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
   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
   integer,      intent(in),optional    :: indent
   
-  class(tItem),     pointer     :: item
+  type (tItem),pointer  :: item
-  character(len=:), allocatable :: str
   integer :: i, indent_
 
   if(present(indent)) then
@@ -745,11 +797,20 @@ recursive function tDict_asFormattedString(self,indent) result(str)
 
   item => self%first
   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
   end do
 
-end function tDict_asFormattedString
+end subroutine tDict_asFormattedString
 
 
 !--------------------------------------------------------------------------------------------------
@@ -906,7 +967,7 @@ end function tList_asStrings
 subroutine tList_append(self,node)
 
   class(tList), intent(inout)         :: self
-  class(tNode), intent(in)    :: node
+  class(tNode), intent(in), target    :: node
 
   type(tItem), pointer :: item
 
@@ -922,7 +983,7 @@ subroutine tList_append(self,node)
     item => item%next
   end if
 
-  allocate(item%node,source=node) ! ToDo: Discuss ownership (copy vs referencing)
+  item%node => node
   self%length = self%length + 1
 
 end subroutine tList_append
@@ -935,7 +996,7 @@ subroutine tDict_set(self,key,node)
 
   class (tDict),    intent(inout)         :: self
   character(len=*), intent(in)            :: key
-  class(tNode),     intent(in)    :: node
+  class(tNode),     intent(in), target    :: node
 
   type(tItem), pointer :: item
 
@@ -957,7 +1018,7 @@ subroutine tDict_set(self,key,node)
   end if
 
   item%key = key
-  allocate(item%node,source=node)
+  item%node => node
 
 end subroutine tDict_set
 
@@ -970,17 +1031,21 @@ recursive subroutine tList_finalize(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
 
 
+!--------------------------------------------------------------------------------------------------
+!> @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