30206241592

Committed 26 Jul 2026 02:31PM UTC coverage: 92.391% (-2.2%) from 94.58%

Build # 30206241592

Build Type

Pull #79

github

Committed by

web-flow

Commit Message

Merge 79dc9ef6b into 58212d52c

Pull Request Pull Request #79: Type mods2

Coverage Stats

89 of 126 new or added lines in 17 files covered. (70.63%)

33 existing lines in 4 files now uncovered.

2732 of 2957 relevant lines covered (92.39%)

14.8 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

82.33

/Source/FTObjects/FTLinkedListClass.f90

! MIT License
!
! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md
!
! Permission is hereby granted, free of charge, to any person obtaining a copy  
! of this software and associated documentation files (the "Software"), to deal  
! in the Software without restriction, including without limitation the rights  
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell  
! copies of the Software, and to permit persons to whom the Software is  
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all  
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR  
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE  
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER  
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,  
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE  
! SOFTWARE.
!
! FTObjectLibrary contains code that, to the best of our knowledge, has been released as
! public domain software:
! * `b3hs_hash_key_jenkins`: originally by Rich Townsend, 
! https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005
!
! --- End License

!
!////////////////////////////////////////////////////////////////////////
!
!      FTLinkedListClass.f90
!      Created: January 7, 2013 2:56 PM 
!      By: David Kopriva  
!
!
!
!////////////////////////////////////////////////////////////////////////
!
!@mark -
!
!>FTLinkedListRecord is the record type (object and next) for the
!>LinkedList class.
!>
!>One will generally not instantiate a record oneself. They are 
!>created automatically when one adds an object to a linked list.
!>
      Module FTLinkedListRecordClass 
      USE FTObjectClass
      IMPLICIT NONE 
!
!     -----------------------------
!     Record class for linked lists
!     -----------------------------
!
      TYPE, EXTENDS(FTObject) :: FTLinkedListRecord
      
         CLASS(FTObject)          , POINTER :: recordObject => NULL()
         CLASS(FTLinkedListRecord), POINTER :: next => NULL(), previous => NULL()
!
!        ========         
         CONTAINS
!        ========
!
         PROCEDURE :: initWithObject
         FINAL     :: destructFTLinkedListRecord
         PROCEDURE :: printDescription => printFTLinkedRecordDescription
         PROCEDURE :: className        => llRecordClassName
         
      END TYPE FTLinkedListRecord
!
!     ----------
!     Procedures
!     ----------
!
      CONTAINS 
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE initWithObject(self,obj) 
         IMPLICIT NONE 
         CLASS(FTLinkedListRecord) :: self
         CLASS(FTObject), POINTER  :: obj
!
!        -------------------------------
!        Always call the superclass init
!        -------------------------------
!
         CALL self % FTObject % init()
!
!        ------------------------
!        Subclass initializations
!        ------------------------
!
         CALL obj % retain()
         
         self % recordObject => obj
         self % next         => NULL()
         self % previous     => NULL()
         
      END SUBROUTINE initWithObject
!
!////////////////////////////////////////////////////////////////////////
!
!< The destructor must only be called from within subclass destructors
!
      SUBROUTINE destructFTLinkedListRecord(self) 
         IMPLICIT NONE
         TYPE(FTLinkedListRecord) :: self
         
         IF ( ASSOCIATED(self % recordObject) ) CALL releaseFTObject(self % recordObject)
         self % next     => NULL()
         self % previous => NULL()
        
      END SUBROUTINE destructFTLinkedListRecord
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE releaseFTLinkedListRecord(self)  
         IMPLICIT NONE
         TYPE(FTLinkedListRecord), POINTER :: self
         CLASS(FTObject)         , POINTER :: obj
         
         IF(.NOT. ASSOCIATED(self)) RETURN
         
         obj => self
         CALL release(obj) 
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTLinkedListRecord
!
!//////////////////////////////////////////////////////////////////////// 
! 
      RECURSIVE SUBROUTINE printFTLinkedRecordDescription(self,iUnit)  
         IMPLICIT NONE  
         CLASS(FTLinkedListRecord) :: self
         INTEGER                   :: iUnit

         IF ( ASSOCIATED(self % recordObject) )     THEN
            CALL self % recordObject % printDescription(iUnit)
         END IF 
         
      END SUBROUTINE printFTLinkedRecordDescription
!
!//////////////////////////////////////////////////////////////////////// 
! 
!      -----------------------------------------------------------------
!> Class name returns a string with the name of the type of the object
!>
!>  ### Usage:
!>
!>        PRINT *,  obj % className()
!>        if( obj % className = "FTLinkedListRecord")
!>
      FUNCTION llRecordClassName(self)  RESULT(s)
         IMPLICIT NONE  
         CLASS(FTLinkedListRecord)                  :: self
         CHARACTER(LEN=CLASS_NAME_CHARACTER_LENGTH) :: s
         
         s = "FTLinkedListRecord"
 
      END FUNCTION llRecordClassName

      
      END MODULE FTLinkedListRecordClass  
!@mark -
!
!
!     --------------------------------------------------
!     Implements the basics of a linked list of objects
!     --------------------------------------------------
!
!>
!>FTLinkedList is a container class that stores objects in a linked list.
!>
!>Inherits from FTObjectClass
!>
!>##Definition (Subclass of FTObject):
!>
!>         TYPE(FTLinkedList) :: list
!>
!>#Usage:
!>
!>##Initialization
!>
!>         CLASS(FTLinkedList), POINTER :: list
!>         ALLOCATE(list)
!>         CALL list % init
!>
!>##Adding objects
!>
!>         CLASS(FTLinkedList), POINTER :: list, listToAdd
!>         CLASS(FTObject)    , POINTER :: objectPtr
!>
!>         objectPtr => r                ! r is subclass of FTObject
!>         CALL list % Add(objectPtr)    ! Pointer is retained by list
!>         CALL release(r)               ! If caller relinquishes ownership
!>
!>         CALL list % addObjectsFromList(listToAdd)
!>
!>##Inserting objects
!>
!>         CLASS(FTLinkedList)      , POINTER :: list
!>         CLASS(FTObject)          , POINTER :: objectPtr, obj
!>         CLASS(FTLinkedListRecord), POINTER :: record
!>
!>         objectPtr => r                                        ! r is subclass of FTObject
!>         CALL list % insertObjectAfterRecord(objectPtr,record) ! Pointer is retained by list
!>         CALL release(r)                                       ! If caller reliquishes ownership
!>
!>         objectPtr => r                                     ! r is subclass of FTObject
!>         CALL list % insertObjectAfterObject(objectPtr,obj) ! Pointer is retained by list
!>         CALL release(r)                                    ! If caller reliquishes ownership
!>
!>##Removing objects
!>
!>         CLASS(FTLinkedList), POINTER :: list
!>         CLASS(FTObject)    , POINTER :: objectPtr
!>         objectPtr => r                 ! r is subclass of FTObject
!>         CALL list % remove(objectPtr)
!>
!>##Getting all objects as an object array
!>
!>         CLASS(FTLinkedList)        , POINTER :: list
!>         CLASS(FTMutableObjectArray), POINTER :: array
!>         array => list % allObjects() ! Array has refCount = 1
!>
!>##Counting the number of objects in the list
!>
!>         n = list % count()
!>
!>##Destruction
!>   
!>         CALL releaseFTLinkedList(list) [Pointers]
!>!
      Module FTLinkedListClass
!      
      USE FTLinkedListRecordClass
      USE FTMutableObjectArrayClass
      IMPLICIT NONE 
!
!     -----------------
!     Class object type
!     -----------------
!
      TYPE, EXTENDS(FTObject) :: FTLinkedList
      
         CLASS(FTLinkedListRecord), POINTER :: head => NULL(), tail => NULL()
         INTEGER                            :: nRecords
         LOGICAL                            :: isCircular_
!
!        ========         
         CONTAINS
!        ========
!
         PROCEDURE :: init             => initFTLinkedList
         PROCEDURE :: add              
         PROCEDURE :: remove           => removeObject
         PROCEDURE :: reverse          => reverseLinkedList
         PROCEDURE :: removeRecord     => removeLinkedListRecord
         FINAL     :: destructFTLinkedList
         PROCEDURE :: count            => numberOfRecords
         PROCEDURE :: description      => FTLinkedListDescription
         PROCEDURE :: printDescription => printFTLinkedListDescription
         PROCEDURE :: className        => linkedListClassName
         PROCEDURE :: allObjects       => allLinkedListObjects
         PROCEDURE :: removeAllObjects => removeAllLinkedListObjects
         PROCEDURE :: addObjectsFromList
         PROCEDURE :: makeCircular
         PROCEDURE :: isCircular
         PROCEDURE :: insertObjectAfterRecord
         PROCEDURE :: insertObjectAfterObject
         
      END TYPE FTLinkedList
      
      INTERFACE cast
         MODULE PROCEDURE castObjectToLinkedList
      END INTERFACE cast
!
!     ----------
!     Procedures
!     ----------
!
      CONTAINS 
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE initFTLinkedList(self) 
         IMPLICIT NONE 
         CLASS(FTLinkedList) :: self
!
!        -------------------------------
!        Always call the superclass init
!        -------------------------------
!
         CALL self % FTObject % init()
!
!        --------------------------------------
!        Then call the subclass initializations
!        --------------------------------------
!
         self % nRecords    = 0
         self % isCircular_ = .FALSE.
         
         self % head => NULL(); self % tail => NULL()
         
      END SUBROUTINE initFTLinkedList
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE add(self,obj)
         IMPLICIT NONE 
         CLASS(FTLinkedList)                :: self
         CLASS(FTObject)          , POINTER :: obj
         CLASS(FTLinkedListRecord), POINTER :: newRecord => NULL()
         
         ALLOCATE(newRecord)
         CALL newRecord % initWithObject(obj)
         
         IF ( .NOT.ASSOCIATED(self % head) )     THEN
            self % head => newRecord
         ELSE
            self % tail % next   => newRecord
            newRecord % previous => self % tail
         END IF
         
         self % tail => newRecord
         self % nRecords = self % nRecords + 1
         
      END SUBROUTINE add 
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE addObjectsFromList(self,list)
         IMPLICIT NONE 
         CLASS(FTLinkedList)                :: self
         CLASS(FTLinkedList)      , POINTER :: list
         CLASS(FTLinkedListRecord), POINTER :: recordPtr => NULL()
         CLASS(FtObject)          , POINTER :: obj       => NULL()
         LOGICAL                            :: circular
         
         IF(.NOT.ASSOCIATED(list % head)) RETURN
         
         circular = list % isCircular()
         CALL list % makeCircular(.FALSE.)

         recordPtr => list % head
         DO WHILE(ASSOCIATED( recordPtr ))
            obj => recordPtr % recordObject
            CALL self % add(obj)
            
            recordPtr => recordPtr % next
         END DO
         
         CALL list % makeCircular(circular) 
         
      END SUBROUTINE addObjectsFromList 
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE insertObjectAfterRecord(self,obj,after)
         IMPLICIT NONE 
         CLASS(FTLinkedList)                :: self
         CLASS(FTObject)          , POINTER :: obj
         CLASS(FTLinkedListRecord), POINTER :: newRecord   => NULL()
         CLASS(FTLinkedListRecord), POINTER :: after, next => NULL()
         
         ALLOCATE(newRecord)
         CALL newRecord % initWithObject(obj)
         
         next                 => after % next
         newRecord % next     => next
         newRecord % previous => after
         after % next         => newRecord
         next % previous      => newRecord
         
         IF ( .NOT.ASSOCIATED( newRecord % next ) )     THEN
            self % tail => newRecord 
         END IF 
         
         self % nRecords = self % nRecords + 1
         
      END SUBROUTINE insertObjectAfterRecord 
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE insertObjectAfterObject(self,obj,after)
         IMPLICIT NONE 
         CLASS(FTLinkedList)                :: self
         CLASS(FTObject)          , POINTER :: obj, after
         
         CLASS(FTLinkedListRecord), POINTER :: current => NULL(), previous => NULL()
                  
         IF ( .NOT.ASSOCIATED(self % head) )     THEN
            CALL self % add(obj)
            RETURN 
         END IF 
         
         current  => self % head
         previous => NULL()
!
!        -------------------------------------------------------------
!        Find the object in the list by a linear search and 
!        add the new object after it.
!        It will be deallocated if necessary.
!        -------------------------------------------------------------
!
         DO WHILE (ASSOCIATED(current))
         
            IF ( ASSOCIATED(current % recordObject,after) )     THEN
               CALL self % insertObjectAfterRecord(obj = obj,after = current)
               RETURN 
            END IF 
            
            previous => current
            current  => current % next
         END DO
         
      END SUBROUTINE insertObjectAfterObject 
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE makeCircular(self,circular)  
         IMPLICIT NONE  
         CLASS(FTLinkedList) :: self
         LOGICAL             :: circular
         
         IF ( circular )     THEN
            self % head % previous => self % tail
            self % tail % next     => self % head
            self % isCircular_ = .TRUE.
         ELSE
            self % head % previous => NULL()
            self % tail % next     => NULL()
            self % isCircular_ = .FALSE.
         END IF 
      END SUBROUTINE makeCircular
!
!//////////////////////////////////////////////////////////////////////// 
! 
      LOGICAL FUNCTION isCircular(self)  
         IMPLICIT NONE  
         CLASS(FTLinkedList) :: self
         isCircular = self % isCircular_
      END FUNCTION isCircular
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE removeObject(self,obj)
         IMPLICIT NONE 
         CLASS(FTLinkedList)                :: self
         CLASS(FTObject)          , POINTER :: obj
         
         CLASS(FTLinkedListRecord), POINTER :: current => NULL(), previous => NULL()
                  
         IF ( .NOT.ASSOCIATED(self % head) )     RETURN
         
         current  => self % head
         previous => NULL()
!
!        -------------------------------------------------------------
!        Find the object in the list by a linear search and remove it.
!        It will be deallocated if necessary.
!        -------------------------------------------------------------
!
         DO WHILE (ASSOCIATED(current))
         
            IF ( ASSOCIATED(current % recordObject,obj) )     THEN
               CALL self % removeRecord(current)
               EXIT
            END IF 
            
            previous => current
            current  => current % next
         END DO
         
      END SUBROUTINE removeObject 
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE removeLinkedListRecord(self,listRecord)
         IMPLICIT NONE 
!
!        ---------
!        Arguments
!        ---------
!
         CLASS(FTLinkedList)                :: self
         CLASS(FTLinkedListRecord), POINTER :: listRecord
!
!        ---------------
!        Local variables
!        ---------------
!
         CLASS(FTLinkedListRecord), POINTER :: previous => NULL(), next => NULL()
         CLASS(FTObject)          , POINTER :: obj
!
!        ---------------------------------------------------
!        Turn cirularity off and then back on
!        to work around an what appears to be an
!        ifort bug testing the association of two pointers. 
!        ---------------------------------------------------
!
         LOGICAL :: circ
         circ = self % isCircular()
         IF(circ) CALL self % makeCircular(.FALSE.)
         
         previous => listRecord % previous
         next     => listRecord % next
         
         IF ( .NOT.ASSOCIATED(listRecord % previous) )     THEN
            self % head => next
            IF ( ASSOCIATED(next) )     THEN
               self % head % previous => NULL() 
            END IF  
         END IF 
         
         IF ( .NOT.ASSOCIATED(listRecord % next) )     THEN
            self % tail => previous
            IF ( ASSOCIATED(previous) )     THEN
               self % tail % next => NULL() 
            END IF
         END IF 
         
         IF ( ASSOCIATED(previous) .AND. ASSOCIATED(next) )     THEN
            previous % next => next
            next % previous => previous 
         END IF 
         
         obj => listRecord
         CALL release(obj)
         
         self % nRecords = self % nRecords - 1
         IF(circ) CALL self % makeCircular(.TRUE.)
         
      END SUBROUTINE removeLinkedListRecord
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE removeAllLinkedListObjects(self)  
         IMPLICIT NONE
         CLASS(FTLinkedList)                :: self
         CLASS(FTLinkedListRecord), POINTER :: listRecord => NULL(), tmp => NULL()
         LOGICAL                            :: circular
         CLASS(FTObject)          , POINTER :: obj

         IF(.NOT.ASSOCIATED(self % head)) RETURN 
         
         circular = self % isCircular()
         CALL self % makeCircular(.FALSE.)
         
         listRecord => self % head
         DO WHILE (ASSOCIATED(listRecord))

            tmp => listRecord % next

            obj => listRecord
            CALL release(obj)

            IF(.NOT. ASSOCIATED(listRecord)) THEN
               self % nRecords = self % nRecords - 1
            END IF
            listRecord => tmp
         END DO

         self % head => NULL(); self % tail => NULL()
         
      END SUBROUTINE removeAllLinkedListObjects
!
!//////////////////////////////////////////////////////////////////////// 
! 
      INTEGER FUNCTION numberOfRecords(self)  
         IMPLICIT NONE  
         CLASS(FTLinkedList) :: self
          numberOfRecords = self % nRecords
      END FUNCTION numberOfRecords     
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE releaseFTLinkedListClass(self)  
         IMPLICIT NONE
         CLASS (FTLinkedList), POINTER :: self
         CLASS(FTObject)   , POINTER :: obj
          
         IF(.NOT. ASSOCIATED(self)) RETURN
        
         obj => self
         CALL release(obj) 
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTLinkedListClass
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE releaseFTLinkedList(self)  
         IMPLICIT NONE
         TYPE (FTLinkedList), POINTER :: self
         CLASS(FTObject)   , POINTER :: obj
          
         IF(.NOT. ASSOCIATED(self)) RETURN
        
         obj => self
         CALL release(obj) 
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTLinkedList
!
!////////////////////////////////////////////////////////////////////////
!
!< The destructor must only be called from within the destructors of subclasses
!> It is automatically called by release().
!
      SUBROUTINE destructFTLinkedList(self) 
         IMPLICIT NONE
         TYPE(FTLinkedList)                :: self

         CALL self % removeAllObjects()

      END SUBROUTINE destructFTLinkedList
!
!//////////////////////////////////////////////////////////////////////// 
! 
      FUNCTION FTLinkedListDescription(self)  
         IMPLICIT NONE  
         CLASS(FTLinkedList)                         :: self
         CLASS(FTLinkedListRecord), POINTER          :: listRecord => NULL()
         CHARACTER(LEN=DESCRIPTION_CHARACTER_LENGTH) :: FTLinkedListDescription
         
         
         FTLinkedListDescription = ""
         IF(.NOT.ASSOCIATED(self % head)) RETURN
         
         listRecord              => self % head
         FTLinkedListDescription = TRIM(listRecord % recordObject % description())
         listRecord              => listRecord % next

         DO WHILE (ASSOCIATED(listRecord))
            FTLinkedListDescription = TRIM(FTLinkedListDescription) // &
                                       CHAR(13) // &
                                       TRIM(listRecord % recordObject % description())
            listRecord => listRecord % next
         END DO
      END FUNCTION FTLinkedListDescription    
!
!//////////////////////////////////////////////////////////////////////// 
! 
      RECURSIVE SUBROUTINE printFTLinkedListDescription(self,iUnit)  
         IMPLICIT NONE  
         CLASS(FTLinkedList)                 :: self
         INTEGER                             :: iUnit
         CLASS(FTLinkedListRecord), POINTER  :: listRecord => NULL()
         LOGICAL                             :: circular
         
         IF(.NOT.ASSOCIATED(self % head)) RETURN
         
         circular                        = .FALSE.
         IF(self % isCircular_) circular = .TRUE.
         CALL self % makeCircular(.FALSE.)
         
         listRecord => self % head

         DO WHILE (ASSOCIATED(listRecord)) 
            CALL listRecord % printDescription(iUnit)
            IF(.NOT. ASSOCIATED(listRecord)) EXIT !TODO Don't understand why this is necessary. Why is record being unassociated?
            listRecord => listRecord % next
         END DO
         
         CALL self % makeCircular (circular)
         
      END SUBROUTINE printFTLinkedListDescription
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE reverseLinkedList(self)
!
!     ------------------------
!     Reverses the linked list
!     ------------------------
!
         IMPLICIT NONE 
!
!        ---------
!        Arguments
!        ---------
!
         CLASS(FTLinkedList) :: self
!
!        ---------------
!        Local variables
!        ---------------
!
         CLASS(FTLinkedListRecord), POINTER :: current => NULL(), tmp => NULL()
         
         IF(.NOT.ASSOCIATED(self % head)) RETURN
         
         IF ( self % isCircular_ )     THEN
            self % head % previous => NULL()
            self % tail % next     => NULL() 
         END IF
         
         current  => self % head

         DO WHILE (ASSOCIATED(current))
            tmp                => current % next
            current % next     => current % previous
            current % previous => tmp
            current            => tmp
         END DO
         
         tmp => self % head
         self % head => self % tail
         self % tail => tmp
         
         CALL self % makeCircular(self % isCircular_) 
         
      END SUBROUTINE reverseLinkedList
!
!//////////////////////////////////////////////////////////////////////// 
! 
      FUNCTION allLinkedListObjects(self)  RESULT(array)
         IMPLICIT NONE  
!
!        ---------
!        Arguments
!        ---------
!
         CLASS (FTLinkedList)                 :: self
         CLASS(FTMutableObjectArray), POINTER :: array
!
!        ---------------
!        Local variables
!        ---------------
!
         INTEGER                            :: N
         CLASS(FTLinkedListRecord), POINTER :: listRecord => NULL()
         CLASS(FTObject)          , POINTER :: obj        => NULL()
         LOGICAL                            :: circular
         
         array => NULL()
         IF(.NOT.ASSOCIATED(self % head)) RETURN
         
         circular                        = .FALSE.
         IF(self % isCircular_) circular = .TRUE.
         CALL self % makeCircular(.FALSE.)
         
         array => NULL()
         N = self % count()
         IF(N==0)     RETURN
         
         ALLOCATE(array)
         CALL array % initWithSize(arraySize  = N)
         
         listRecord => self % head

         DO WHILE (ASSOCIATED(listRecord))
            obj => listRecord % recordObject
            CALL array % addObject(obj)
            listRecord => listRecord % next
         END DO
         
         CALL self % makeCircular(circular)
         
      END FUNCTION allLinkedListObjects
!
!//////////////////////////////////////////////////////////////////////// 
! 
!      -----------------------------------------------------------------
!> Class name returns a string with the name of the type of the object
!>
!>  ### Usage:
!>
!>        PRINT *,  obj % className()
!>        if( obj % className = "FTLinkedList")
!>
      FUNCTION linkedListClassName(self)  RESULT(s)
         IMPLICIT NONE  
         CLASS(FTLinkedList)                        :: self
         CHARACTER(LEN=CLASS_NAME_CHARACTER_LENGTH) :: s
         
         s = "FTLinkedList"
 
      END FUNCTION linkedListClassName
!@mark -
! type conversions
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE castObjectToLinkedList(obj,cast) 
!
!     -----------------------------------------------------
!     Cast the base class FTObject to the LinkedList class
!     -----------------------------------------------------
!
         IMPLICIT NONE  
         CLASS(FTObject)    , POINTER :: obj
         CLASS(FTLinkedList), POINTER :: cast
         
         cast => NULL()
         SELECT TYPE (e => obj)
            TYPE is (FTLinkedList)
               cast => e
            CLASS DEFAULT
               
         END SELECT
         
      END SUBROUTINE castObjectToLinkedList
!
!//////////////////////////////////////////////////////////////////////// 
! 
      FUNCTION linkedListFromObject(obj) RESULT(cast)
!
!     -----------------------------------------------------
!     Cast the base class FTObject to the LinkedList class
!     -----------------------------------------------------
!
         IMPLICIT NONE  
         CLASS(FTObject)    , POINTER :: obj 
         CLASS(FTLinkedList), POINTER :: cast
         
         cast => NULL()
         SELECT TYPE (e => obj)
            TYPE is (FTLinkedList)
               cast => e
            CLASS DEFAULT
               
         END SELECT
         
      END FUNCTION linkedListFromObject
!
      END MODULE FTLinkedListClass
!
!@mark -
!
!//////////////////////////////////////////////////////////////////////// 
! 
!>An object for stepping through a linked list.
!>
!>###Definition (Subclass of FTObject):
!>   TYPE(FTLinkedListIterator) :: list
!>
!>
!>###Initialization
!>
!>         CLASS(FTLinkedList)        , POINTER :: list
!>         CLASS(FTLinkedListIterator), POINTER :: iterator
!>         ALLOCATE(iterator)
!>         CALL iterator % initWithFTLinkedList(list)
!>
!>###Accessors
!>
!>         ptr => iterator % list()
!>         ptr => iterator % object()
!>         ptr => iterator % currentRecord()
!>
!>###Iterating
!>
!>         CLASS(FTObject), POINTER :: objectPtr
!>         CALL iterator % setToStart
!>         DO WHILE (.NOT.iterator % isAtEnd())
!>            objectPtr => iterator % object()        ! if the object is wanted
!>            recordPtr => iterator % currentRecord() ! if the record is wanted
!>            
!>             Do something with object or record
!>
!>            CALL iterator % moveToNext() ! DON'T FORGET THIS!!
!>         END DO
!>
!>###Destruction
!>   
!>         CALL releaseFTLinkedListIterator(iterator) [Pointers]
!
!//////////////////////////////////////////////////////////////////////// 
! 
      Module FTLinkedListIteratorClass
      USE FTLinkedListClass
      IMPLICIT NONE
!
!     -----------------
!     Class object type
!     -----------------
!
      TYPE, EXTENDS(FTObject) :: FTLinkedListIterator
         CLASS(FTLinkedList)      , POINTER :: list    => NULL()
         CLASS(FTLinkedListRecord), POINTER :: current => NULL()
!
!        ========         
         CONTAINS
!        ========
!
         PROCEDURE :: init           => initEmpty
         PROCEDURE :: initWithFTLinkedList
         PROCEDURE :: initWithFTLinkedListClass
         FINAL     :: destructIterator
         PROCEDURE :: isAtEnd        => FTLinkedListIsAtEnd
         PROCEDURE :: object         => FTLinkedListObject
         PROCEDURE :: currentRecord  => FTLinkedListCurrentRecord
         PROCEDURE :: linkedList     => returnLinkedList
         PROCEDURE :: className      => linkedListIteratorClassName
         PROCEDURE :: setLinkedList
         PROCEDURE :: setLinkedListClass
         PROCEDURE :: setToStart
         PROCEDURE :: moveToNext
         PROCEDURE :: removeCurrentRecord
      END TYPE FTLinkedListIterator
!
!     ----------
!     Procedures
!     ----------
!
      CONTAINS 
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE initEmpty(self) 
         IMPLICIT NONE 
         CLASS(FTLinkedListIterator)  :: self
!
!        --------------------------------------------
!        Always call the superclass initializer first
!        --------------------------------------------
!
         CALL self % FTObject % init()
!
!        ----------------------------------------------
!        Then call the initializations for the subclass
!        ----------------------------------------------
!
         self % list    => NULL()
         self % current => NULL()
         
      END SUBROUTINE initEmpty   
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE initWithFTLinkedList(self,list) 
         IMPLICIT NONE 
         CLASS(FTLinkedListIterator)  :: self
         TYPE(FTLinkedList), POINTER  :: list
!
!        --------------------------------------------
!        Always call the superclass initializer first
!        --------------------------------------------
!
         CALL self % FTObject % init()
!
!        ----------------------------------------------
!        Then call the initializations for the subclass
!        ----------------------------------------------
!
         self % list    => NULL()
         self % current => NULL()
         CALL self % setLinkedList(list)
         CALL self % setToStart()
         
      END SUBROUTINE initWithFTLinkedList   
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE initWithFTLinkedListClass(self,list) 
         IMPLICIT NONE 
         CLASS(FTLinkedListIterator)  :: self
         CLASS(FTLinkedList), POINTER :: list
!
!        --------------------------------------------
!        Always call the superclass initializer first
!        --------------------------------------------
!
         CALL self % FTObject % init()
!
!        ----------------------------------------------
!        Then call the initializations for the subclass
!        ----------------------------------------------
!
         self % list    => NULL()
         self % current => NULL()
         CALL self % setLinkedListClass(list)
         CALL self % setToStart()
         
      END SUBROUTINE initWithFTLinkedListClass   
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE releaseFTLinkedListIterator(self)  
         IMPLICIT NONE
         TYPE(FTLinkedListIterator), POINTER :: self
         CLASS(FTObject)   , POINTER :: obj
         
         IF(.NOT. ASSOCIATED(self)) RETURN
         
         obj => self
         CALL release(obj) 
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTLinkedListIterator
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE releaseFTLinkedListIteratorClass(self)  
         IMPLICIT NONE
         TYPE(FTLinkedListIterator), POINTER :: self
         CLASS(FTObject)   , POINTER :: obj
         
         IF(.NOT. ASSOCIATED(self)) RETURN
         
         obj => self
         CALL release(obj) 
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTLinkedListIteratorClass
!
!////////////////////////////////////////////////////////////////////////
!
!< The destructor must not be called except at the end of destructors of
! subclasses.
!
      SUBROUTINE destructIterator(self)
          IMPLICIT NONE 
          TYPE(FTLinkedListIterator) :: self
          
          CALL releaseMemberList(self)
          self % current => NULL()
          
      END SUBROUTINE destructIterator
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE releaseMemberList(self)  
          IMPLICIT NONE  
          CLASS(FTLinkedListIterator) :: self
          CLASS(FTObject), POINTER    :: obj
          
          IF ( ASSOCIATED(self % list) )     THEN
             obj => self % list
             CALL releaseFTObject(self = obj)
             IF(.NOT. ASSOCIATED(obj)) self % list => NULL()
          END IF 
      END SUBROUTINE releaseMemberList
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE setToStart(self) 
         IMPLICIT NONE 
         CLASS(FTLinkedListIterator)  :: self
         self % current => self % list % head
      END SUBROUTINE setToStart 
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE moveToNext(self) 
         IMPLICIT NONE 
         CLASS(FTLinkedListIterator)  :: self
         
         IF ( ASSOCIATED(self % current) )     THEN
            self % current => self % current % next
         ELSE 
            self % current => NULL() 
         END IF 
         
         IF ( ASSOCIATED(self % current, self % list % head) )     THEN
            self % current => NULL() 
         END IF 
         
      END SUBROUTINE moveToNext 
!
!////////////////////////////////////////////////////////////////////////
!
      LOGICAL FUNCTION FTLinkedListIsAtEnd(self)
         IMPLICIT NONE 
         CLASS(FTLinkedListIterator)  :: self
         IF ( ASSOCIATED(self % current) )     THEN
            FTLinkedListIsAtEnd = .false.
         ELSE
            FTLinkedListIsAtEnd = .true.
         END IF
      END FUNCTION FTLinkedListIsAtEnd   
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE setLinkedListClass(self,list)
         IMPLICIT NONE 
         CLASS(FTLinkedListIterator)  :: self
         CLASS(FTLinkedList), POINTER :: list
!
!        -----------------------------------
!        Remove current list if there is one
!        -----------------------------------
!
         IF ( ASSOCIATED(list) )     THEN
         
            IF ( ASSOCIATED(self % list, list) )     THEN
               CALL self % setToStart()
            ELSE IF( ASSOCIATED(self % list) )     THEN
               CALL releaseMemberList(self)
               self % list => list
               CALL self % list % retain()
               CALL self % setToStart
            ELSE
               self % list => list
               CALL self % list % retain()
               CALL self % setToStart()
            END IF 
            
         ELSE
         
            IF( ASSOCIATED(self % list) )     THEN
               CALL releaseMemberList(self)
            END IF 
            self % list => NULL()
            
         END IF
         
      END SUBROUTINE setLinkedListClass   
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE setLinkedList(self,list)
         IMPLICIT NONE 
         CLASS(FTLinkedListIterator)  :: self
         TYPE (FTLinkedList), POINTER :: list
!
!        -----------------------------------
!        Remove current list if there is one
!        -----------------------------------
!
         IF ( ASSOCIATED(list) )     THEN
         
            IF ( ASSOCIATED(self % list, list) )     THEN
               CALL self % setToStart()
            ELSE IF( ASSOCIATED(self % list) )     THEN
               CALL releaseMemberList(self)
               self % list => list
               CALL self % list % retain()
               CALL self % setToStart
            ELSE
               self % list => list
               CALL self % list % retain()
               CALL self % setToStart()
            END IF 
            
         ELSE
         
            IF( ASSOCIATED(self % list) )     THEN
               CALL releaseMemberList(self)
            END IF 
            self % list => NULL()
            
         END IF
         
      END SUBROUTINE setLinkedList   
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION returnLinkedList(self) RESULT(o)
         IMPLICIT NONE 
         CLASS(FTLinkedListIterator)  :: self
         CLASS(FTLinkedList), POINTER     :: o
         o => self % list
      END FUNCTION returnLinkedList 
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION FTLinkedListObject(self) RESULT(o)
         IMPLICIT NONE 
         CLASS(FTLinkedListIterator)  :: self
         CLASS(FTObject), POINTER     :: o
         o => self % current % recordObject
      END FUNCTION FTLinkedListObject 
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION FTLinkedListCurrentRecord(self) RESULT(o)
         IMPLICIT NONE 
         CLASS(FTLinkedListIterator)        :: self
         CLASS(FTLinkedListRecord), POINTER :: o
         o => self % current
      END FUNCTION FTLinkedListCurrentRecord 
!
!//////////////////////////////////////////////////////////////////////// 
! 
      SUBROUTINE removeCurrentRecord(self)  
         IMPLICIT NONE  
         CLASS(FTLinkedListIterator)        :: self
         CLASS(FTLinkedListRecord), POINTER :: r, n
         r => self % current
         n => self % current % next
         
         CALL self % list % removeRecord(r)
         self % current => n
         
      END SUBROUTINE removeCurrentRecord
!
!//////////////////////////////////////////////////////////////////////// 
! 
!      -----------------------------------------------------------------
!> Class name returns a string with the name of the type of the object
!>
!>  ### Usage:
!>
!>        PRINT *,  obj % className()
!>        if( obj % className = "FTLinkedListIterator")
!>
      FUNCTION linkedListIteratorClassName(self)  RESULT(s)
         IMPLICIT NONE  
         CLASS(FTLinkedListIterator)                :: self
         CHARACTER(LEN=CLASS_NAME_CHARACTER_LENGTH) :: s
         
         s = "FTLinkedListIterator"
 
      END FUNCTION linkedListIteratorClassName
      
      END MODULE FTLinkedListIteratorClass   

trixi-framework / FTObjectLibrary / 30206241592

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous