From 86bccfd858e5d15239e378013cad1a05e0e782b1 Mon Sep 17 00:00:00 2001 From: David Kopriva Date: Sat, 25 Jul 2026 17:26:40 -0700 Subject: [PATCH 1/7] Add Class Releases Distinguish between type and class dummy arguments --- Source/FTObjects/FTDataClass.f90 | 14 ++++++++ Source/FTObjects/FTDictionaryClass.f90 | 28 +++++++++++++++ Source/FTObjects/FTExceptionClass.f90 | 38 ++++++++++++++++++++- Source/FTObjects/FTLinkedListClass.f90 | 30 +++++++++++++++- Source/FTObjects/FTMultiIndexTable.f90 | 14 ++++++++ Source/FTObjects/FTObjectArrayClass.f90 | 14 ++++++++ Source/FTObjects/FTSparseMatrixClass.f90 | 14 ++++++++ Source/FTObjects/FTStackClass.f90 | 14 ++++++++ Source/FTObjects/FTStringSetClass.f90 | 14 ++++++++ Source/FTObjects/FTValueClass.f90 | 14 ++++++++ Source/FTObjects/FTValueDictionaryClass.f90 | 16 +++++++++ Testing/Tests/DataTests.f90 | 2 +- Testing/Tests/DictionaryTests.f90 | 2 +- Testing/Tests/ExceptionTests.f90 | 18 +++++----- Testing/Tests/LinkedListTests.f90 | 12 +++---- Testing/Tests/StringSetTests.f90 | 2 +- Testing/Tests/ValueDictionaryTests.f90 | 2 +- 17 files changed, 227 insertions(+), 21 deletions(-) diff --git a/Source/FTObjects/FTDataClass.f90 b/Source/FTObjects/FTDataClass.f90 index 75da9f3a..a8a4ced1 100644 --- a/Source/FTObjects/FTDataClass.f90 +++ b/Source/FTObjects/FTDataClass.f90 @@ -123,6 +123,20 @@ SUBROUTINE releaseFTData(self) CALL release(obj) IF(.NOT.ASSOCIATED(obj)) self => NULL() END SUBROUTINE releaseFTData +! +!//////////////////////////////////////////////////////////////////////// +! + SUBROUTINE releaseFTDataClass(self) + IMPLICIT NONE + CLASS(FTData) , POINTER :: self + CLASS(FTObject), POINTER :: obj + + IF(.NOT. ASSOCIATED(self)) RETURN + + obj => self + CALL release(obj) + IF(.NOT.ASSOCIATED(obj)) self => NULL() + END SUBROUTINE releaseFTDataClass !@mark - ! !//////////////////////////////////////////////////////////////////////// diff --git a/Source/FTObjects/FTDictionaryClass.f90 b/Source/FTObjects/FTDictionaryClass.f90 index 600bf789..32de5ee5 100644 --- a/Source/FTObjects/FTDictionaryClass.f90 +++ b/Source/FTObjects/FTDictionaryClass.f90 @@ -109,6 +109,20 @@ SUBROUTINE releaseFTKeyObjectPair(self) END SUBROUTINE releaseFTKeyObjectPair ! !//////////////////////////////////////////////////////////////////////// +! + SUBROUTINE releaseFTKeyObjectPairClass(self) + IMPLICIT NONE + CLASS(FTKeyObjectPair), POINTER :: self + CLASS(FTObject) , POINTER :: obj + + IF(.NOT. ASSOCIATED(self)) RETURN + + obj => self + CALL release(obj) + IF(.NOT.ASSOCIATED(obj)) self => NULL() + END SUBROUTINE releaseFTKeyObjectPairClass +! +!//////////////////////////////////////////////////////////////////////// ! SUBROUTINE destructFTKeyObjectPair(self) IMPLICIT NONE @@ -316,6 +330,20 @@ SUBROUTINE releaseFTDictionary(self) END SUBROUTINE releaseFTDictionary ! !//////////////////////////////////////////////////////////////////////// +! + SUBROUTINE releaseFTDictionaryClass(self) + IMPLICIT NONE + CLASS(FTDictionary) , POINTER :: self + CLASS(FTObject) , POINTER :: obj + + IF(.NOT. ASSOCIATED(self)) RETURN + + obj => self + CALL release(obj) + IF(.NOT.ASSOCIATED(obj)) self => NULL() + END SUBROUTINE releaseFTDictionaryClass +! +!//////////////////////////////////////////////////////////////////////// ! SUBROUTINE destructFTDictionary(self) IMPLICIT NONE diff --git a/Source/FTObjects/FTExceptionClass.f90 b/Source/FTObjects/FTExceptionClass.f90 index b7c35392..c9570831 100644 --- a/Source/FTObjects/FTExceptionClass.f90 +++ b/Source/FTObjects/FTExceptionClass.f90 @@ -73,7 +73,8 @@ !> !>### Destruction !> -!> CALL releaseFTException(e) [pointers] +!> CALL releaseFTExceptionClass(e) [pointers] +!> CALL releaseFTException(e) [pointers, TYPE] !> !>###Setting the infoDictionary !> @@ -277,6 +278,20 @@ SUBROUTINE initAssertionFailureException(self,msg,expectedValueObject,observedVa END SUBROUTINE initAssertionFailureException ! !//////////////////////////////////////////////////////////////////////// +! + SUBROUTINE releaseFTExceptionClass(self) + IMPLICIT NONE + CLASS(FTException) , POINTER :: self + CLASS(FTObject) , POINTER :: obj + + IF(.NOT. ASSOCIATED(self)) RETURN + + obj => self + CALL release(obj) + IF(.NOT.ASSOCIATED(obj)) self => NULL() + END SUBROUTINE releaseFTExceptionClass +! +!//////////////////////////////////////////////////////////////////////// ! SUBROUTINE releaseFTException(self) IMPLICIT NONE @@ -626,6 +641,27 @@ SUBROUTINE throw(exceptionToThrow) END SUBROUTINE throw ! !//////////////////////////////////////////////////////////////////////// +! + SUBROUTINE throwClass(exceptionToThrow) +! +!>Throws the exception: exceptionToThrow +! + IMPLICIT NONE + CLASS (FTException), POINTER :: exceptionToThrow + CLASS(FTObject) , POINTER :: ptr => NULL() + + IF ( .NOT.ASSOCIATED(errorStack) ) THEN + CALL initializeFTExceptions + END IF + + ptr => exceptionToThrow + CALL errorStack % push(ptr) + + maxErrorLevel = MAX(maxErrorLevel, exceptionToThrow % severity()) + + END SUBROUTINE throwClass +! +!//////////////////////////////////////////////////////////////////////// ! LOGICAL FUNCTION catchAll() ! diff --git a/Source/FTObjects/FTLinkedListClass.f90 b/Source/FTObjects/FTLinkedListClass.f90 index a93d3959..478ea6fe 100644 --- a/Source/FTObjects/FTLinkedListClass.f90 +++ b/Source/FTObjects/FTLinkedListClass.f90 @@ -577,13 +577,27 @@ END FUNCTION numberOfRecords ! !//////////////////////////////////////////////////////////////////////// ! - SUBROUTINE releaseFTLinkedList(self) + 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() @@ -950,6 +964,20 @@ SUBROUTINE releaseFTLinkedListIterator(self) 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 diff --git a/Source/FTObjects/FTMultiIndexTable.f90 b/Source/FTObjects/FTMultiIndexTable.f90 index 237fa16d..8a507795 100644 --- a/Source/FTObjects/FTMultiIndexTable.f90 +++ b/Source/FTObjects/FTMultiIndexTable.f90 @@ -275,6 +275,20 @@ SUBROUTINE releaseFTMultiIndexTable(self) END SUBROUTINE releaseFTMultiIndexTable ! !//////////////////////////////////////////////////////////////////////// +! + SUBROUTINE releaseFTMultiIndexTableClass(self) + IMPLICIT NONE + CLASS(FTMultiIndexTable), POINTER :: self + CLASS(FTObject) , POINTER :: obj + + IF(.NOT. ASSOCIATED(self)) RETURN + + obj => self + CALL release(obj) + IF(.NOT.ASSOCIATED(obj)) self => NULL() + END SUBROUTINE releaseFTMultiIndexTableClass +! +!//////////////////////////////////////////////////////////////////////// ! SUBROUTINE destructMultiIndexTable(self) IMPLICIT NONE diff --git a/Source/FTObjects/FTObjectArrayClass.f90 b/Source/FTObjects/FTObjectArrayClass.f90 index da67aedd..8ce2cebb 100644 --- a/Source/FTObjects/FTObjectArrayClass.f90 +++ b/Source/FTObjects/FTObjectArrayClass.f90 @@ -172,6 +172,20 @@ SUBROUTINE releaseFTMutableObjectArray(self) END SUBROUTINE releaseFTMutableObjectArray ! !//////////////////////////////////////////////////////////////////////// +! + SUBROUTINE releaseFTMutableObjectArrayClass(self) + IMPLICIT NONE + CLASS(FTMutableObjectArray), POINTER :: self + CLASS(FTObject) , POINTER :: obj + + IF(.NOT. ASSOCIATED(self)) RETURN + + obj => self + CALL release(obj) + IF(.NOT.ASSOCIATED(obj)) self => NULL() + END SUBROUTINE releaseFTMutableObjectArrayClass +! +!//////////////////////////////////////////////////////////////////////// ! !> !> Destructor for the class. This is called automatically when the diff --git a/Source/FTObjects/FTSparseMatrixClass.f90 b/Source/FTObjects/FTSparseMatrixClass.f90 index af01e3fd..77d6536d 100644 --- a/Source/FTObjects/FTSparseMatrixClass.f90 +++ b/Source/FTObjects/FTSparseMatrixClass.f90 @@ -455,6 +455,20 @@ SUBROUTINE releaseFTSparseMatrix(self) END SUBROUTINE releaseFTSparseMatrix ! !//////////////////////////////////////////////////////////////////////// +! + SUBROUTINE releaseFTSparseMatrixClass(self) + IMPLICIT NONE + CLASS(FTSparseMatrix), POINTER :: self + CLASS(FTObject) , POINTER :: obj + + IF(.NOT. ASSOCIATED(self)) RETURN + + obj => self + CALL release(obj) + IF(.NOT.ASSOCIATED(obj)) self => NULL() + END SUBROUTINE releaseFTSparseMatrixClass +! +!//////////////////////////////////////////////////////////////////////// ! SUBROUTINE destructSparseMatrix(self) IMPLICIT NONE diff --git a/Source/FTObjects/FTStackClass.f90 b/Source/FTObjects/FTStackClass.f90 index 56625594..c6f10b44 100644 --- a/Source/FTObjects/FTStackClass.f90 +++ b/Source/FTObjects/FTStackClass.f90 @@ -144,6 +144,20 @@ SUBROUTINE releaseFTStack(self) IF(.NOT.ASSOCIATED(obj)) self => NULL() END SUBROUTINE releaseFTStack ! +!//////////////////////////////////////////////////////////////////////// +! + SUBROUTINE releaseFTStackClass(self) + IMPLICIT NONE + CLASS(FTStack) , POINTER :: self + CLASS(FTObject) , POINTER :: obj + + IF(.NOT. ASSOCIATED(self)) RETURN + + obj => self + CALL release(obj) + IF(.NOT.ASSOCIATED(obj)) self => NULL() + END SUBROUTINE releaseFTStackClass +! ! ----------------------------------- ! push: Push an object onto the stack ! ----------------------------------- diff --git a/Source/FTObjects/FTStringSetClass.f90 b/Source/FTObjects/FTStringSetClass.f90 index 18aeeceb..1583a2fd 100644 --- a/Source/FTObjects/FTStringSetClass.f90 +++ b/Source/FTObjects/FTStringSetClass.f90 @@ -214,6 +214,20 @@ SUBROUTINE releaseFTStringSet(self) END SUBROUTINE releaseFTStringSet ! !//////////////////////////////////////////////////////////////////////// +! + SUBROUTINE releaseFTStringSetClass(self) + IMPLICIT NONE + CLASS(FTStringSet), POINTER :: self + CLASS(FTObject) , POINTER :: obj + + obj => self + CALL release(self = obj) + IF ( .NOT. ASSOCIATED(obj) ) THEN + NULLIFY(self) + END IF + END SUBROUTINE releaseFTStringSetClass +! +!//////////////////////////////////////////////////////////////////////// ! INTEGER FUNCTION stringCount(self) IMPLICIT NONE diff --git a/Source/FTObjects/FTValueClass.f90 b/Source/FTObjects/FTValueClass.f90 index 11f0922a..f35a5c54 100644 --- a/Source/FTObjects/FTValueClass.f90 +++ b/Source/FTObjects/FTValueClass.f90 @@ -371,6 +371,20 @@ SUBROUTINE releaseFTValue(self) IF(.NOT.ASSOCIATED(obj)) self => NULL() END SUBROUTINE releaseFTValue ! +!//////////////////////////////////////////////////////////////////////// +! + SUBROUTINE releaseFTValueClass(self) + IMPLICIT NONE + CLASS(FTValue) , POINTER :: self + CLASS(FTObject), POINTER :: obj + + IF(.NOT. ASSOCIATED(self)) RETURN + + obj => self + CALL release(obj) + IF(.NOT.ASSOCIATED(obj)) self => NULL() + END SUBROUTINE releaseFTValueClass +! !------------------------------------------------ !> Public, generic name: destruct() !> diff --git a/Source/FTObjects/FTValueDictionaryClass.f90 b/Source/FTObjects/FTValueDictionaryClass.f90 index 610df2d7..be8c5baf 100644 --- a/Source/FTObjects/FTValueDictionaryClass.f90 +++ b/Source/FTObjects/FTValueDictionaryClass.f90 @@ -144,6 +144,22 @@ SUBROUTINE releaseFTValueDictionary(self) END SUBROUTINE releaseFTValueDictionary ! !//////////////////////////////////////////////////////////////////////// +! + SUBROUTINE releaseFTValueDictionaryClass(self) + IMPLICIT NONE + CLASS(FTValueDictionary), POINTER :: self + CLASS(FTObject) , POINTER :: obj + + IF(.NOT. ASSOCIATED(self)) RETURN + + obj => self + CALL releaseFTObject(self = obj) + IF ( .NOT. ASSOCIATED(obj) ) THEN + self => NULL() + END IF + END SUBROUTINE releaseFTValueDictionaryClass +! +!//////////////////////////////////////////////////////////////////////// ! SUBROUTINE addIntegerValueForKey(self,i,key) IMPLICIT NONE diff --git a/Testing/Tests/DataTests.f90 b/Testing/Tests/DataTests.f90 index 69a7ec65..35646b57 100644 --- a/Testing/Tests/DataTests.f90 +++ b/Testing/Tests/DataTests.f90 @@ -102,7 +102,7 @@ SUBROUTINE DataTests ! Cleanup ! ------- ! - CALL releaseFTData(dat) + CALL releaseFTDataClass(dat) CALL FTAssert(.NOT. ASSOCIATED(dat),msg = "Destruction of FTData") END SUBROUTINE DataTests diff --git a/Testing/Tests/DictionaryTests.f90 b/Testing/Tests/DictionaryTests.f90 index 83013ab3..dcd66fb5 100644 --- a/Testing/Tests/DictionaryTests.f90 +++ b/Testing/Tests/DictionaryTests.f90 @@ -167,7 +167,7 @@ SUBROUTINE FTDictionaryClassTests ! DEALLOCATE(storedKeys) CALL releaseFTMutableObjectArray(storedObjects) - CALL releaseFTDictionary(dict) + CALL releaseFTDictionaryClass(dict) CALL FTAssert(.NOT.ASSOCIATED(dict),"Released dictionary should have been deallocated") ! ! ------------------------- diff --git a/Testing/Tests/ExceptionTests.f90 b/Testing/Tests/ExceptionTests.f90 index 5500d6a7..000a34c0 100644 --- a/Testing/Tests/ExceptionTests.f90 +++ b/Testing/Tests/ExceptionTests.f90 @@ -111,16 +111,16 @@ SUBROUTINE FTExceptionClassTests CALL FTAssertEqual(expectedValue = FT_ERROR_WARNING, & actualValue = e % severity(), & msg = "Warning error level match") - CALL throw(e) - CALL releaseFTException(e) + CALL throwClass(e) + CALL releaseFTExceptionClass(e) ALLOCATE(e) CALL e % initFatalException(msg = "I'm Sorry, I can't do that Dave (Designed Uncaught)") CALL FTAssertEqual(expectedValue = FT_ERROR_FATAL, & actualValue = e % severity(), & msg = "Fatal error level match") - CALL throw(e) - CALL releaseFTException(e) + CALL throwClass(e) + CALL releaseFTExceptionClass(e) ALLOCATE(e) ALLOCATE(vGood, vBad) @@ -131,8 +131,8 @@ SUBROUTINE FTExceptionClassTests expectedValueObject = vGood, & ObservedValueObject = vBad, & level = FT_ERROR_WARNING) - CALL releaseFTValue(vBad) - CALL releaseFTValue(vGood) + CALL releaseFTValueClass(vBad) + CALL releaseFTValueClass(vGood) CALL FTAssertEqual(expectedValue = FT_ERROR_WARNING, & actualValue = e % severity(), & @@ -161,8 +161,8 @@ SUBROUTINE FTExceptionClassTests ePtr => exceptionFromObject(obj) CALL FTAssert(ASSOCIATED(ePtr),msg = "Test casting of exception by function") - CALL throw(e) - CALL releaseFTException(e) + CALL throwClass(e) + CALL releaseFTExceptionClass(e) ! ! ----------------------------- ! Testing the exception manager @@ -208,7 +208,7 @@ SUBROUTINE FTExceptionClassTests CALL FTAssertEqual(expectedValue = FT_ERROR_WARNING, & actualValue = e % severity(), & msg = "Popped error level match") - CALL releaseFTException(e) + CALL releaseFTExceptionClass(e) CALL destructFTExceptions diff --git a/Testing/Tests/LinkedListTests.f90 b/Testing/Tests/LinkedListTests.f90 index 293e736e..4dafd59b 100644 --- a/Testing/Tests/LinkedListTests.f90 +++ b/Testing/Tests/LinkedListTests.f90 @@ -113,7 +113,7 @@ SUBROUTINE basicTests CALL FTAssertEqual(1,list % refCount(),"Reference counting: Initial object refCount") CALL list % retain() CALL FTAssertEqual(2,list % refCount(), "Reference counting: Test retain") - CALL releaseFTLinkedList(list) + CALL releaseFTLinkedListClass(list) CALL FTAssertEqual(1,list % refCount(),"Reference counting: test release") ! ! --------------------------------------------------------------------------------- @@ -272,7 +272,7 @@ SUBROUTINE basicTests ! Otherwise, it is possible to get an undefined pointer. ! ------------------------------------------------------ ! - CALL releaseFTLinkedList(list) + CALL releaseFTLinkedListClass(list) CALL FTAssertEqual(1,list % refCount(),"Ref count decrease on release") ! ! ------------------------------------------------------------------- @@ -370,7 +370,7 @@ SUBROUTINE TestAppendingLists ! in list1 ! -------------------------------------------------- ! - CALL releaseFTLinkedList(list2) + CALL releaseFTLinkedListClass(list2) CALL FTAssertEqual(.TRUE., .NOT. ASSOCIATED(list2),"List has only one owner and should deallocate on release") ! ! -------------------------------------------------- @@ -430,7 +430,7 @@ SUBROUTINE TestAppendingLists ! Clean up ! -------- ! - CALL releaseFTLinkedList(list1) + CALL releaseFTLinkedListClass(list1) CALL releaseFTLinkedListIterator(iterator) END SUBROUTINE TestAppendingLists @@ -546,7 +546,7 @@ SUBROUTINE TestDeletingObjects ! Clean up ! -------- ! - CALL releaseFTLinkedList(list) + CALL releaseFTLinkedListClass(list) CALL releaseFTLinkedListIterator(iterator) END SUBROUTINE TestDeletingObjects @@ -605,7 +605,7 @@ SUBROUTINE TestInsertingObjects ! ALLOCATE(iterator) CALL iterator % initwithFTLinkedList(list) - CALL releaseFTLinkedList(list) + CALL releaseFTLinkedListClass(list) CALL iterator % setToStart() DO j = 1, 3 diff --git a/Testing/Tests/StringSetTests.f90 b/Testing/Tests/StringSetTests.f90 index 510476b6..4364dbaa 100644 --- a/Testing/Tests/StringSetTests.f90 +++ b/Testing/Tests/StringSetTests.f90 @@ -150,7 +150,7 @@ SUBROUTINE FTStringSetTests actualValue = unionSet % COUNT(), & msg = "union set count") - CALL releaseFTStringSet(self = unionSet) + CALL releaseFTStringSetClass(self = unionSet) CALL FTAssert(test = .NOT.ASSOCIATED(unionSet),msg = 'Release of pointer to set') ! ! ---------------------- diff --git a/Testing/Tests/ValueDictionaryTests.f90 b/Testing/Tests/ValueDictionaryTests.f90 index bee8c0fc..ee0dd0af 100644 --- a/Testing/Tests/ValueDictionaryTests.f90 +++ b/Testing/Tests/ValueDictionaryTests.f90 @@ -229,7 +229,7 @@ SUBROUTINE FTValueDictionaryClassTests CALL FTAssert(ASSOCIATED(valDict),msg = "Cast dictionary to valuedictionary as subroutine call ") CALL FTAssert(valDict % containsKey(key = "name"),msg = "Test integrity of casting") - CALL releaseFTValueDictionary(dict3) + CALL releaseFTValueDictionaryClass(dict3) CALL FTAssert(.NOT.ASSOCIATED(dict3),msg = "Release dictionary should deallocate") From 79dc9ef6bbf9320bd235aa1ff750b6ca0be09f0c Mon Sep 17 00:00:00 2001 From: David Kopriva Date: Sat, 25 Jul 2026 18:05:51 -0700 Subject: [PATCH 2/7] Linked List mods Allow either a class or type to be added to a linked list iterator, --- Source/FTObjects/FTExceptionClass.f90 | 4 +- Source/FTObjects/FTLinkedListClass.f90 | 67 +++++++++++++++++++++++- Source/FTObjects/FTSparseMatrixClass.f90 | 4 +- Testing/Tests/LinkedListTests.f90 | 8 +-- 4 files changed, 73 insertions(+), 10 deletions(-) diff --git a/Source/FTObjects/FTExceptionClass.f90 b/Source/FTObjects/FTExceptionClass.f90 index c9570831..d1571bfd 100644 --- a/Source/FTObjects/FTExceptionClass.f90 +++ b/Source/FTObjects/FTExceptionClass.f90 @@ -754,7 +754,7 @@ LOGICAL FUNCTION catchErrorWithName(exceptionName) END IF ptr => errorStack - CALL iterator % initWithFTLinkedList(ptr) + CALL iterator % initWithFTLinkedListClass(ptr) CALL iterator % setToStart() DO WHILE (.NOT.iterator % isAtEnd()) @@ -869,7 +869,7 @@ SUBROUTINE printAllExceptions CLASS(FTException) , POINTER :: e => NULL() list => errorStack - CALL iterator % initWithFTLinkedList(list) + CALL iterator % initWithFTLinkedListClass(list) ! ! ---------------------------------------------------- ! Write out the descriptions of each of the exceptions diff --git a/Source/FTObjects/FTLinkedListClass.f90 b/Source/FTObjects/FTLinkedListClass.f90 index 478ea6fe..71553536 100644 --- a/Source/FTObjects/FTLinkedListClass.f90 +++ b/Source/FTObjects/FTLinkedListClass.f90 @@ -887,6 +887,7 @@ Module FTLinkedListIteratorClass ! PROCEDURE :: init => initEmpty PROCEDURE :: initWithFTLinkedList + PROCEDURE :: initWithFTLinkedListClass FINAL :: destructIterator PROCEDURE :: isAtEnd => FTLinkedListIsAtEnd PROCEDURE :: object => FTLinkedListObject @@ -894,6 +895,7 @@ Module FTLinkedListIteratorClass PROCEDURE :: linkedList => returnLinkedList PROCEDURE :: className => linkedListIteratorClassName PROCEDURE :: setLinkedList + PROCEDURE :: setLinkedListClass PROCEDURE :: setToStart PROCEDURE :: moveToNext PROCEDURE :: removeCurrentRecord @@ -931,7 +933,7 @@ END SUBROUTINE initEmpty SUBROUTINE initWithFTLinkedList(self,list) IMPLICIT NONE CLASS(FTLinkedListIterator) :: self - CLASS(FTLinkedList), POINTER :: list + TYPE(FTLinkedList), POINTER :: list ! ! -------------------------------------------- ! Always call the superclass initializer first @@ -950,6 +952,30 @@ SUBROUTINE initWithFTLinkedList(self,list) 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) @@ -1046,7 +1072,7 @@ END FUNCTION FTLinkedListIsAtEnd ! !//////////////////////////////////////////////////////////////////////// ! - SUBROUTINE setLinkedList(self,list) + SUBROUTINE setLinkedListClass(self,list) IMPLICIT NONE CLASS(FTLinkedListIterator) :: self CLASS(FTLinkedList), POINTER :: list @@ -1054,6 +1080,43 @@ SUBROUTINE setLinkedList(self,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 diff --git a/Source/FTObjects/FTSparseMatrixClass.f90 b/Source/FTObjects/FTSparseMatrixClass.f90 index 77d6536d..0b3db175 100644 --- a/Source/FTObjects/FTSparseMatrixClass.f90 +++ b/Source/FTObjects/FTSparseMatrixClass.f90 @@ -378,7 +378,7 @@ FUNCTION objectInSparseMatrixForKeys(self,i,j) RESULT(r) ! r => NULL() - CALL self % iterator % setLinkedList(self % table(i) % list) + CALL self % iterator % setLinkedListClass(self % table(i) % list) DO WHILE (.NOT.self % iterator % isAtEnd()) obj => self % iterator % object() @@ -424,7 +424,7 @@ FUNCTION SparseMatrixContainsKeys(self,i,j) RESULT(r) ! ---------------------------- ! list => self % table(i) % list - CALL self % iterator % setLinkedList(list) + CALL self % iterator % setLinkedListClass(list) CALL self % iterator % setToStart() DO WHILE (.NOT.self % iterator % isAtEnd()) diff --git a/Testing/Tests/LinkedListTests.f90 b/Testing/Tests/LinkedListTests.f90 index 4dafd59b..0de81280 100644 --- a/Testing/Tests/LinkedListTests.f90 +++ b/Testing/Tests/LinkedListTests.f90 @@ -195,7 +195,7 @@ SUBROUTINE basicTests ! --------------------------------------------------------------------------------- ! ALLOCATE(iterator) - CALL iterator % initWithFTLinkedList(list) + CALL iterator % initWithFTLinkedListClass(list) CALL FTAssertEqual(2,list % refCount(),"Ref count increase on addition of list to iterator") CALL FTAssertEqual(expectedValue = "FTLinkedListIterator", & actualValue = iterator % className(), & @@ -352,7 +352,7 @@ SUBROUTINE TestAppendingLists ! Note that objects are owned by both lists. ! ------------------------------------------- ! - CALL iterator % initWithFTLinkedList(list1) + CALL iterator % initWithFTLinkedListClass(list1) j = 1 DO WHILE (.NOT.iterator % isAtEnd()) v => valueFromObject(iterator % object()) @@ -481,7 +481,7 @@ SUBROUTINE TestDeletingObjects ! ------------------------------------------------------------ ! ALLOCATE(iterator) - CALL iterator % initwithFTLinkedList(list) + CALL iterator % initwithFTLinkedListClass(list) ! ! --------------- ! Delete the tail @@ -604,7 +604,7 @@ SUBROUTINE TestInsertingObjects ! --------------------------------- ! ALLOCATE(iterator) - CALL iterator % initwithFTLinkedList(list) + CALL iterator % initwithFTLinkedListClass(list) CALL releaseFTLinkedListClass(list) CALL iterator % setToStart() From 38d10b00926c7c6bb99701d47005f6424df059ca Mon Sep 17 00:00:00 2001 From: David Kopriva Date: Sun, 26 Jul 2026 19:59:19 -0700 Subject: [PATCH 3/7] LinkedList Coverage Increase coverage on linked list class --- Source/FTObjects/FTLinkedListClass.f90 | 2 +- Testing/Tests/LinkedListTests.f90 | 23 +++++++++++++++++++---- 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/Source/FTObjects/FTLinkedListClass.f90 b/Source/FTObjects/FTLinkedListClass.f90 index 71553536..3c96b30e 100644 --- a/Source/FTObjects/FTLinkedListClass.f90 +++ b/Source/FTObjects/FTLinkedListClass.f90 @@ -994,7 +994,7 @@ END SUBROUTINE releaseFTLinkedListIterator ! SUBROUTINE releaseFTLinkedListIteratorClass(self) IMPLICIT NONE - TYPE(FTLinkedListIterator), POINTER :: self + CLASS(FTLinkedListIterator), POINTER :: self CLASS(FTObject) , POINTER :: obj IF(.NOT. ASSOCIATED(self)) RETURN diff --git a/Testing/Tests/LinkedListTests.f90 b/Testing/Tests/LinkedListTests.f90 index 0de81280..9cbad1b3 100644 --- a/Testing/Tests/LinkedListTests.f90 +++ b/Testing/Tests/LinkedListTests.f90 @@ -81,8 +81,10 @@ SUBROUTINE basicTests ! can be a non-pointer, too, like the iterator. ! ------------------------------------------------- ! - CLASS (FTLinkedList) , POINTER :: list, listPtr + CLASS(FTLinkedList) , POINTER :: list, listPtr + TYPE (FTLinkedList) , POINTER :: listType TYPE (FTLinkedListIterator), POINTER :: iterator + CLASS(FTLinkedListIterator), POINTER :: iteratorClass INTEGER :: i REAL :: singleTol = 2*EPSILON(1.0e0) @@ -94,7 +96,9 @@ SUBROUTINE basicTests ! ------------------------------------------------------- ! ALLOCATE(list) + ALLOCATE(listType) CALL list % init() + CALL listType % init() CALL FTAssertEqual(expectedValue = "FTLinkedList", & actualValue = list % className(), & msg = "Class name test for linked list") @@ -121,6 +125,7 @@ SUBROUTINE basicTests ! --------------------------------------------------------------------------------- ! CALL FTAssertEqual(0,list % COUNT(),"Initial list size") + CALL FTAssertEqual(0,listType % COUNT(),"Initial list size") ! ! ------------------------------------------------------------------ ! Add some items to the linked list. @@ -139,13 +144,14 @@ SUBROUTINE basicTests CALL r1 % initWithValue(1) objectPtr => r1 CALL list % add(objectPtr) + CALL listType % add(objectPtr) CALL FTAssertEqual(1,list % COUNT(),"List size after adding one object") ! - CALL FTAssertEqual(2,r1 % refCount(),& + CALL FTAssertEqual(3,r1 % refCount(),& "Reference counting: Stored object should have reference count increased") CALL releaseFTValue(r1) - CALL FTAssertEqual(1,objectPtr % refCount(),& + CALL FTAssertEqual(2,objectPtr % refCount(),& "Reference counting: Stored object should have reference count decreased") ! ! --------------------------------------------------------------------- @@ -195,8 +201,11 @@ SUBROUTINE basicTests ! --------------------------------------------------------------------------------- ! ALLOCATE(iterator) + ALLOCATE(iteratorClass) CALL iterator % initWithFTLinkedListClass(list) + CALL iteratorClass % initWithFTLinkedList(listType) CALL FTAssertEqual(2,list % refCount(),"Ref count increase on addition of list to iterator") + CALL FTAssertEqual(2,listType % refCount(),"Ref count increase on addition of list to iterator type") CALL FTAssertEqual(expectedValue = "FTLinkedListIterator", & actualValue = iterator % className(), & msg = "Class name test for linked list") @@ -274,6 +283,7 @@ SUBROUTINE basicTests ! CALL releaseFTLinkedListClass(list) CALL FTAssertEqual(1,list % refCount(),"Ref count decrease on release") + CALL releaseFTLinkedList(listType) ! ! ------------------------------------------------------------------- ! Normally we would now check if the list should be deallocated. But @@ -290,7 +300,12 @@ SUBROUTINE basicTests ! ------------------------------------------------------------------------------ ! CALL releaseFTLinkedListIterator(iterator) - + CALL releaseFTLinkedListIteratorClass(iteratorClass) +! +! ---------------------------------------------- +! Operations on the class version of the pointer +! ---------------------------------------------- +! END SUBROUTINE basicTests ! !//////////////////////////////////////////////////////////////////////// From 4891831578a84c21dabf8a6547c9a8603866f9ef Mon Sep 17 00:00:00 2001 From: David Kopriva Date: Mon, 27 Jul 2026 08:12:33 -0700 Subject: [PATCH 4/7] Increase Coverage Remove asn unneeded class version in FTDictionaryClass. Add test for class version of release in MultiIndexTable --- Source/FTObjects/FTDictionaryClass.f90 | 28 +++++++++++++------------- Testing/Tests/MultiIndexTableTests.f90 | 6 +++++- 2 files changed, 19 insertions(+), 15 deletions(-) diff --git a/Source/FTObjects/FTDictionaryClass.f90 b/Source/FTObjects/FTDictionaryClass.f90 index 32de5ee5..8d0fdca8 100644 --- a/Source/FTObjects/FTDictionaryClass.f90 +++ b/Source/FTObjects/FTDictionaryClass.f90 @@ -107,20 +107,20 @@ SUBROUTINE releaseFTKeyObjectPair(self) CALL release(obj) IF(.NOT.ASSOCIATED(obj)) self => NULL() END SUBROUTINE releaseFTKeyObjectPair -! -!//////////////////////////////////////////////////////////////////////// -! - SUBROUTINE releaseFTKeyObjectPairClass(self) - IMPLICIT NONE - CLASS(FTKeyObjectPair), POINTER :: self - CLASS(FTObject) , POINTER :: obj - - IF(.NOT. ASSOCIATED(self)) RETURN - - obj => self - CALL release(obj) - IF(.NOT.ASSOCIATED(obj)) self => NULL() - END SUBROUTINE releaseFTKeyObjectPairClass +!! +!!//////////////////////////////////////////////////////////////////////// +!! +! SUBROUTINE releaseFTKeyObjectPairClass(self) +! IMPLICIT NONE +! CLASS(FTKeyObjectPair), POINTER :: self +! CLASS(FTObject) , POINTER :: obj +! +! IF(.NOT. ASSOCIATED(self)) RETURN +! +! obj => self +! CALL release(obj) +! IF(.NOT.ASSOCIATED(obj)) self => NULL() +! END SUBROUTINE releaseFTKeyObjectPairClass ! !//////////////////////////////////////////////////////////////////////// ! diff --git a/Testing/Tests/MultiIndexTableTests.f90 b/Testing/Tests/MultiIndexTableTests.f90 index c44663e4..88e834eb 100644 --- a/Testing/Tests/MultiIndexTableTests.f90 +++ b/Testing/Tests/MultiIndexTableTests.f90 @@ -47,7 +47,8 @@ SUBROUTINE MultiIndexTableTests TYPE (FTValue) , POINTER :: v CLASS(FTObject), POINTER :: obj - TYPE(FTMultiIndexTable), POINTER :: table, tablePtr + TYPE (FTMultiIndexTable), POINTER :: table + CLASS(FTMultiIndexTable), POINTER :: tableClass, tablePtr INTEGER, DIMENSION(1) :: unsorted1 = [3] INTEGER, DIMENSION(1) :: sorted1 = [3] INTEGER, DIMENSION(2) :: unsorted2 = [5,3] @@ -99,7 +100,9 @@ SUBROUTINE MultiIndexTableTests keys(:,4) = [4,6,7,2] ALLOCATE(table) + ALLOCATE(tableClass) CALL table % initWithSize(N = 10) ! Says first item of the multiIndex array is at most 10 + CALL tableClass % initWithSize(N = 10) ! Says first item of the multiIndex array is at most 10 CALL FTAssertEqual(expectedValue = 10, & actualValue = table % MultiIndexTableSize(), & msg = "Size of table") @@ -148,6 +151,7 @@ SUBROUTINE MultiIndexTableTests ! -------- ! CALL releaseFTMultiIndexTable(table) + CALL releaseFTMultiIndexTableClass(tableClass) CALL FTAssert(.NOT. ASSOCIATED(table),msg = "Final release of table") END SUBROUTINE MultiIndexTableTests From 8fb7e8893b9ecefd38725bffd209fabdf3bbfbe1 Mon Sep 17 00:00:00 2001 From: David Kopriva Date: Mon, 27 Jul 2026 10:03:26 -0700 Subject: [PATCH 5/7] Update LinkedListTests.f90 cover unused add null to iterator --- Testing/Tests/LinkedListTests.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/Testing/Tests/LinkedListTests.f90 b/Testing/Tests/LinkedListTests.f90 index 9cbad1b3..ef74e008 100644 --- a/Testing/Tests/LinkedListTests.f90 +++ b/Testing/Tests/LinkedListTests.f90 @@ -299,6 +299,7 @@ SUBROUTINE basicTests ! since it is the last owner. ! ------------------------------------------------------------------------------ ! + CALL iteratorClass % setLinkedListClass(list) !This will destroy the linked list ince list => null() CALL releaseFTLinkedListIterator(iterator) CALL releaseFTLinkedListIteratorClass(iteratorClass) ! From 7733259292d14cdf49411f8bed33086f72357f42 Mon Sep 17 00:00:00 2001 From: David Kopriva Date: Mon, 27 Jul 2026 17:52:57 -0700 Subject: [PATCH 6/7] Update FTObjectArrayClass.f90 Make a change to test HOHQMesh ifx error --- Source/FTObjects/FTObjectArrayClass.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Source/FTObjects/FTObjectArrayClass.f90 b/Source/FTObjects/FTObjectArrayClass.f90 index 8ce2cebb..b49e684f 100644 --- a/Source/FTObjects/FTObjectArrayClass.f90 +++ b/Source/FTObjects/FTObjectArrayClass.f90 @@ -197,10 +197,10 @@ RECURSIVE SUBROUTINE destructObjectArray(self) CLASS(FTObject), POINTER :: obj => NULL() INTEGER :: i - DO i = 1, self % count_ - obj => self % array(i) % object - IF ( ASSOCIATED(obj) ) CALL releaseFTObject(self = obj) - END DO +! DO i = 1, self % count_ +! obj => self % array(i) % object +! IF ( ASSOCIATED(obj) ) CALL releaseFTObject(self = obj) +! END DO DEALLOCATE(self % array) self % array => NULL() From 6426f814488459b7d61a0ca2fbcc5572f82e1e48 Mon Sep 17 00:00:00 2001 From: David Kopriva Date: Mon, 27 Jul 2026 18:07:16 -0700 Subject: [PATCH 7/7] Update FTObjectArrayClass.f90 Put deallocation back in --- Source/FTObjects/FTObjectArrayClass.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Source/FTObjects/FTObjectArrayClass.f90 b/Source/FTObjects/FTObjectArrayClass.f90 index b49e684f..8ce2cebb 100644 --- a/Source/FTObjects/FTObjectArrayClass.f90 +++ b/Source/FTObjects/FTObjectArrayClass.f90 @@ -197,10 +197,10 @@ RECURSIVE SUBROUTINE destructObjectArray(self) CLASS(FTObject), POINTER :: obj => NULL() INTEGER :: i -! DO i = 1, self % count_ -! obj => self % array(i) % object -! IF ( ASSOCIATED(obj) ) CALL releaseFTObject(self = obj) -! END DO + DO i = 1, self % count_ + obj => self % array(i) % object + IF ( ASSOCIATED(obj) ) CALL releaseFTObject(self = obj) + END DO DEALLOCATE(self % array) self % array => NULL()