! 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 releaseFTLinkedList(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 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 FINAL :: destructIterator PROCEDURE :: isAtEnd => FTLinkedListIsAtEnd PROCEDURE :: object => FTLinkedListObject PROCEDURE :: currentRecord => FTLinkedListCurrentRecord PROCEDURE :: linkedList => returnLinkedList PROCEDURE :: className => linkedListIteratorClassName PROCEDURE :: setLinkedList 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 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 % setLinkedList(list) CALL self % setToStart() END SUBROUTINE initWithFTLinkedList ! !//////////////////////////////////////////////////////////////////////// ! 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 ! !//////////////////////////////////////////////////////////////////////// ! !< 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 setLinkedList(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 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