From 86bccfd858e5d15239e378013cad1a05e0e782b1 Mon Sep 17 00:00:00 2001 From: David Kopriva Date: Sat, 25 Jul 2026 17:26:40 -0700 Subject: [PATCH 01/17] 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 02/17] 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 03/17] 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 04/17] 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 05/17] 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 06/17] 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 07/17] 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() From 1bce14ba7ab47ea2b112341df2feb26f0d002446 Mon Sep 17 00:00:00 2001 From: David Kopriva Date: Tue, 28 Jul 2026 08:07:45 -0700 Subject: [PATCH 08/17] Update FTObjectArrayClass.f90 Add TODO on location of problem with ifx compiler. --- Source/FTObjects/FTObjectArrayClass.f90 | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/Source/FTObjects/FTObjectArrayClass.f90 b/Source/FTObjects/FTObjectArrayClass.f90 index 8ce2cebb..bd3ca722 100644 --- a/Source/FTObjects/FTObjectArrayClass.f90 +++ b/Source/FTObjects/FTObjectArrayClass.f90 @@ -197,10 +197,15 @@ 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 + !TODO The following is commented out because it tries to delete and + ! unallocated object with the ifx and ifort compilers. This will + ! cause a memory leak. Unfortunately, this is a recursive subroutine, + ! and so far I have not been able to track down why this is happening. + ! --- DAK +! 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 a63a33dbb8a0a53ad4a8b9424ce0714780838e57 Mon Sep 17 00:00:00 2001 From: David Kopriva Date: Wed, 29 Jul 2026 08:24:07 -0700 Subject: [PATCH 09/17] Restore ObjectArray plus bug fix Restore FTMultableObjectArray deallocation procedure. Plus, found a bug where if a linked list didn't have any items in it, it's status as circular or not could be changed. --- Source/FTObjects/FTLinkedListClass.f90 | 5 ++++- Source/FTObjects/FTObjectArrayClass.f90 | 30 ++++++++++--------------- 2 files changed, 16 insertions(+), 19 deletions(-) diff --git a/Source/FTObjects/FTLinkedListClass.f90 b/Source/FTObjects/FTLinkedListClass.f90 index 3c96b30e..20b83d8e 100644 --- a/Source/FTObjects/FTLinkedListClass.f90 +++ b/Source/FTObjects/FTLinkedListClass.f90 @@ -743,7 +743,10 @@ FUNCTION allLinkedListObjects(self) RESULT(array) array => NULL() N = self % count() - IF(N==0) RETURN + IF(N==0) THEN + CALL self % makeCircular(circular) + RETURN + END IF ALLOCATE(array) CALL array % initWithSize(arraySize = N) diff --git a/Source/FTObjects/FTObjectArrayClass.f90 b/Source/FTObjects/FTObjectArrayClass.f90 index bd3ca722..e03daf64 100644 --- a/Source/FTObjects/FTObjectArrayClass.f90 +++ b/Source/FTObjects/FTObjectArrayClass.f90 @@ -94,9 +94,9 @@ MODULE FTMutableObjectArrayClass PRIVATE :: increaseArraysize TYPE, EXTENDS(FTObject) :: FTMutableObjectArray - INTEGER , PRIVATE :: count_ - TYPE(FTObjectPointerWrapper), DIMENSION(:), POINTER, PRIVATE :: array => NULL() - INTEGER , PRIVATE :: chunkSize_ = 10 + INTEGER , PRIVATE :: count_ + TYPE(FTObjectPointerWrapper), DIMENSION(:), POINTER , PRIVATE :: array => NULL() + INTEGER , PRIVATE :: chunkSize_ = 10 ! ! -------- CONTAINS @@ -165,7 +165,6 @@ SUBROUTINE releaseFTMutableObjectArray(self) CLASS(FTObject) , POINTER :: obj IF(.NOT. ASSOCIATED(self)) RETURN - obj => self CALL release(obj) IF(.NOT.ASSOCIATED(obj)) self => NULL() @@ -191,26 +190,21 @@ END SUBROUTINE releaseFTMutableObjectArrayClass !> Destructor for the class. This is called automatically when the !> reference count reaches zero. Do not call this yourself. !> - RECURSIVE SUBROUTINE destructObjectArray(self) + RECURSIVE SUBROUTINE destructObjectArray(self) IMPLICIT NONE - TYPE( FTMutableObjectArray) :: self + TYPE( FTMutableObjectArray) :: self CLASS(FTObject), POINTER :: obj => NULL() INTEGER :: i - !TODO The following is commented out because it tries to delete and - ! unallocated object with the ifx and ifort compilers. This will - ! cause a memory leak. Unfortunately, this is a recursive subroutine, - ! and so far I have not been able to track down why this is happening. - ! --- DAK -! 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(obj) + END DO - DEALLOCATE(self % array) + IF(ASSOCIATED(self % array)) DEALLOCATE(self % array) self % array => NULL() - self % count_ = 0 - + self % count_ = 0 + END SUBROUTINE destructObjectArray ! !//////////////////////////////////////////////////////////////////////// From 6801940bb7c057bde43529eb7468bd87072451d8 Mon Sep 17 00:00:00 2001 From: David Kopriva Date: Wed, 29 Jul 2026 11:45:31 -0700 Subject: [PATCH 10/17] Update UsersGuide.md Now distinguishes between objects defined by TYPE and those defined by CLASS --- Docs/UsersGuide.md | 35 +++++++++++++++++++++-------------- 1 file changed, 21 insertions(+), 14 deletions(-) diff --git a/Docs/UsersGuide.md b/Docs/UsersGuide.md index 1c1f13c1..a4bc1e53 100644 --- a/Docs/UsersGuide.md +++ b/Docs/UsersGuide.md @@ -105,13 +105,13 @@ added to the dictionary. CALL v % initWithValue(3.14159) obj => v CALL dict % addObjectForKey(obj,``Pi'') - CALL releaseFTValue(v) + CALL releaseFTValueClass(v) ALLOCATE(v) CALL v % initWithValue(``Ratio of circumference to diameter'') obj => v CALL dict % addObjectForKey(obj,"definition") - CALL releaseFTValue(v) + CALL releaseFTValueClass(v) END SUBROUTINE constructDictionary Notice that in the subroutine we have allocated memory for the @@ -125,7 +125,7 @@ later through the dictionary. This is where a systematic approach to memory management comes in. When we allocate and initialize an object, we assume ownership of it. When we add it to the dictionary, it assumes partial ownership. So instead of deallocating the two value objects, we -relinquish ownership by way of the releaseFTValue() procedure, leaving +relinquish ownership by way of the releaseFTValueClass() procedure, since v is typed by CLASS, leaving only the dictionary to be responsible for deallocating them when it does not need them any more. @@ -141,7 +141,7 @@ We use the dictionary as shown in the next snippet of code: v => valueFromObject(dict % objectForKey(``definition'')) PRINT *, "The num pi = ", pi," is defined as", TRIM(v % stringValue()) - CALL releaseFTDictionary(dict) + CALL releaseFTDictionaryClass(dict) In this snippet, the values for the two keys "Pi" and "definition" are retrieved and then used. @@ -183,8 +183,8 @@ Ownership rules are as follows: creates (allocates and initializes) it. - When you no longer need an object (or are going out of scope) you must - release it using the releaseXXX() subroutine, where XXX refers to the - specific name of the extended type. + release it using the releaseXXX() subroutine, or releaseXXXClass(), where XXX refers to the + specific name of the extended type, depending on whether the object is declared by TYPE or CLASS. - You must neither relinquish ownership, nor deallocate a pointer object that you do not own. @@ -212,13 +212,13 @@ the point object to the linked list. obj => pnt CALL list % add(obj) !list also owns pnt - CALL releasePoint(pnt) ! main gives up ownership to pnt + CALL releasePointClass(pnt) ! main gives up ownership to pnt . . . ! we're done with the list, it will deallocate pnt since the list is the last owner. ! It will also deallocate itself since main is the last owner. - CALL releaseFTLinkedList(list) + CALL releaseFTLinkedListClass(list) END PROGRAM main @@ -371,9 +371,7 @@ cascading of what is stored in the object. The release subroutine will call the base class releaseFTObject which will, in turn, release all objects that it owns. If the object itself is -no longer referenced, it will deallocate itself. If the subclass is -going to be subclassed again, use the CLASS specifier, otherwise, we -TYPE to work only on that specific subclass. +no longer referenced, it will deallocate itself. Due to fortran's rules, create one as below with the pointer TYPEed, and another with CLASS, usually with the word Class appended, e.g. releaseXXXClass(self). SUBROUTINE releaseSubclass(self) IMPLICIT NONE @@ -433,7 +431,8 @@ character. (To Add: complex) - Destruction - CALL releaseFTValue(r) !For Pointers + CALL releaseFTValue(r) !For Pointers + CALL releaseFTValueClass(r) !For Pointers typed by CLASS - Accessors @@ -573,6 +572,7 @@ inherits from FTObjectClass. - Destruction CALL releaseFTLinkedList(list) ! If list is a pointer + CALL releaseFTLinkedListClass(list) ! If list is a pointer typed by CLASS ### FTLinkedListIterator @@ -630,7 +630,8 @@ stepping through (iterating) a linked list to access its entries. - Destruction - CALL releaseFTLinkedListIterator(iterator) ! If a pointer + CALL releaseFTLinkedListIterator(iterator) ! If a pointer + CALL releaseFTLinkedListIteratorClass(iterator)! If a pointer typed by CLASS ## Stacks @@ -655,7 +656,8 @@ stack, for instance. - Destruction - CALL releaseFTStack(stack) ! If stack is a pointer + CALL releaseFTStack(stack) ! If stack is a pointer + CALL releaseFTStackClass(stack)! If stack is a pointer typed by CLASS - Pushing an object onto the stack @@ -708,6 +710,7 @@ be efficient, it adds more than one entry at a time given by the - Destruction CALL releaseFTMutableObjectArray(array) !If array is a pointer + CALL releaseFTMutableObjectArray(array) !If array is a pointer and CLASS - Adding an object @@ -815,6 +818,7 @@ initialize the matrix with the number of rows. - Destruction CALL releaseFTSparseMatrix(matrix) !If matrix is a pointer + CALL releaseFTSparseMatrixClass(matrix) !If matrix is a pointer typed by CLASS - Adding an object @@ -854,6 +858,7 @@ another element. - Destruction CALL releaseFTMultiIndexTable(table) !If table is a pointer + CALL releaseFTMultiIndexTableClass(table) !If table is a pointer typed by CLASS - Adding an object @@ -900,6 +905,7 @@ retrieve FTValue objects. - Destruction CALL releaseFTDictionary(dict) !If dict is a pointer + CALL releaseFTDictionaryClass(dict) !If dict is a pointer typed by CLASS - Adding a key-object pair @@ -1002,6 +1008,7 @@ FTDICT\_KWD\_STRING\_LENGTH or less. - Destruction CALL releaseFTStringSet(set) !If set is a pointer + CALL releaseFTStringSetClass(set) !If set is a pointer typed by CLASS - Adding a string From 343a3f7ce6a1d9d6735ae2051deb8c8b6aa9a326 Mon Sep 17 00:00:00 2001 From: Andrew Winters Date: Wed, 29 Jul 2026 20:49:44 +0200 Subject: [PATCH 11/17] attempt to add ifx to CI --- .github/workflows/ci.yml | 50 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 49 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 6100749d..0b61f3e0 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -15,15 +15,21 @@ on: - 'README.md' workflow_dispatch: +env: + # Modify this variable to change the ifx compiler version - do NOT hardcode the version + # anywhere else! + INTEL_ONEAPI_VERSION: 2025.2 + jobs: test: if: "!contains(github.event.head_commit.message, 'skip ci')" - name: ${{ matrix.os }} - ${{ github.event_name }} + name: ${{ matrix.os }} - ${{ matrix.compiler }} - ${{ github.event_name }} runs-on: ${{ matrix.os }} strategy: fail-fast: false matrix: include: + # Linux - os: ubuntu-22.04 compiler: gfortran-10 cmake_generator: Unix Makefiles @@ -32,10 +38,24 @@ jobs: compiler: gfortran-13 cmake_generator: Unix Makefiles shell: bash + - os: ubuntu-26.04 + compiler: gfortran-15 + cmake_generator: Unix Makefiles + shell: bash + - os: ubuntu-latest + compiler: ifx + cmake_generator: Unix Makefiles + shell: bash + # macOS - os: macos-latest compiler: gfortran-13 cmake_generator: Unix Makefiles shell: bash + - os: macos-latest + compiler: gfortran-15 + cmake_generator: Unix Makefiles + shell: bash + # Windows - os: windows-latest compiler: gfortran cmake_generator: MinGW Makefiles @@ -55,6 +75,34 @@ jobs: with: update: true install: git base-devel mingw-w64-x86_64-toolchain mingw-w64-x86_64-gcc-fortran mingw-w64-x86_64-cmake + - uses: actions/cache@v6 + id: cache + with: + path: /opt/intel/oneapi + key: ${{ matrix.os }}-${{ matrix.compiler }}-${{ env.INTEL_ONEAPI_VERSION }} + - name: Install Intel oneAPI Fortran compiler + if: matrix.compiler == 'ifx' && steps.cache.outputs.cache-hit != 'true' + run: | + # download the key to system keyring + wget -O- https://apt.repos.intel.com/intel-gpg-keys/GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB \ + | gpg --dearmor | sudo tee /usr/share/keyrings/oneapi-archive-keyring.gpg > /dev/null + + # add signed entry to apt sources and configure the APT client to use Intel repository: + echo "deb [signed-by=/usr/share/keyrings/oneapi-archive-keyring.gpg] https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list + + # update package index and install Fortran compiler + sudo apt update + sudo apt-get install intel-oneapi-compiler-fortran-$INTEL_ONEAPI_VERSION + + # set environment variables and make them persistent across steps + . /opt/intel/oneapi/setvars.sh + env | grep oneapi >> $GITHUB_ENV + - name: Use existing Intel oneAPI Fortran compiler + if: matrix.compiler == 'ifx' && steps.cache.outputs.cache-hit == 'true' + run: | + # set environment variables and make them persistent across steps + . /opt/intel/oneapi/setvars.sh + env | grep oneapi >> $GITHUB_ENV - name: Verify CMake build run: | mkdir build && cd build From 08c188036d38c77179fcef81f8a3fa4184759046 Mon Sep 17 00:00:00 2001 From: Andrew Winters Date: Wed, 29 Jul 2026 20:59:40 +0200 Subject: [PATCH 12/17] deactiavte coverage in all but one Ubuntu test --- .github/workflows/ci.yml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 0b61f3e0..5354bdf5 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -34,32 +34,39 @@ jobs: compiler: gfortran-10 cmake_generator: Unix Makefiles shell: bash + coverage: true - os: ubuntu-latest compiler: gfortran-13 cmake_generator: Unix Makefiles shell: bash + coverage: false - os: ubuntu-26.04 compiler: gfortran-15 cmake_generator: Unix Makefiles shell: bash + coverage: false - os: ubuntu-latest compiler: ifx cmake_generator: Unix Makefiles shell: bash + coverage: false # macOS - os: macos-latest compiler: gfortran-13 cmake_generator: Unix Makefiles shell: bash + coverage: false - os: macos-latest compiler: gfortran-15 cmake_generator: Unix Makefiles shell: bash + coverage: false # Windows - os: windows-latest compiler: gfortran cmake_generator: MinGW Makefiles shell: 'msys2 {0}' + coverage: false # Set default shell as suggested here: https://github.community/t/setting-default-shell-or-other-step-metadata-conditionally-in-workflows/154055 defaults: run: From b8a9ed1c3a1b9275ca1fe7cdb5576d11649e7316 Mon Sep 17 00:00:00 2001 From: Andrew Winters Date: Wed, 29 Jul 2026 21:11:03 +0200 Subject: [PATCH 13/17] add valgrind tests and adjust coverage reporting --- .github/workflows/ci.yml | 35 ++++++++++++++++++++++++++++++----- 1 file changed, 30 insertions(+), 5 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 5354bdf5..f6f927e3 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -23,7 +23,7 @@ env: jobs: test: if: "!contains(github.event.head_commit.message, 'skip ci')" - name: ${{ matrix.os }} - ${{ matrix.compiler }} - ${{ github.event_name }} + name: ${{ matrix.os }} - ${{ matrix.compiler }} - ${{ matrix.test_type }} - ${{ github.event_name }} runs-on: ${{ matrix.os }} strategy: fail-fast: false @@ -34,38 +34,63 @@ jobs: compiler: gfortran-10 cmake_generator: Unix Makefiles shell: bash + test_type: regular coverage: true - - os: ubuntu-latest + - os: ubuntu-22.04 + os_name: linux + compiler: gfortran-10 + shell: bash + test_type: valgrind + coverage: false + - os: ubuntu-24.04 compiler: gfortran-13 cmake_generator: Unix Makefiles shell: bash + test_type: regular + coverage: false + - os: ubuntu-24.04 + os_name: linux + compiler: gfortran-13 + shell: bash + test_type: valgrind coverage: false - os: ubuntu-26.04 compiler: gfortran-15 cmake_generator: Unix Makefiles shell: bash + test_type: regular + coverage: false + - os: ubuntu-26.04 + os_name: linux + compiler: gfortran-15 + shell: bash + test_type: valgrind coverage: false - os: ubuntu-latest compiler: ifx cmake_generator: Unix Makefiles shell: bash + test_type: regular coverage: false # macOS - os: macos-latest compiler: gfortran-13 cmake_generator: Unix Makefiles shell: bash + test_type: regular coverage: false - os: macos-latest compiler: gfortran-15 cmake_generator: Unix Makefiles shell: bash + test_type: regular coverage: false # Windows - os: windows-latest compiler: gfortran cmake_generator: MinGW Makefiles shell: 'msys2 {0}' + test_type: regular coverage: false # Set default shell as suggested here: https://github.community/t/setting-default-shell-or-other-step-metadata-conditionally-in-workflows/154055 defaults: @@ -130,13 +155,13 @@ jobs: cd TestSuiteBuild ./runSuite - name: Run tests for coverage - if: ${{ matrix.os == 'ubuntu-latest' }} + if: ${{ matrix.coverage }} run: | sudo apt-get install -y lcov cd TestSuiteBuild FC=${{ matrix.compiler }} ./createcoverage - uses: codecov/codecov-action@v7 - if: ${{ matrix.os == 'ubuntu-latest' }} + if: ${{ matrix.coverage }} with: files: ./TestSuiteBuild/lcov.info flags: unittests @@ -144,7 +169,7 @@ jobs: env: CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} # now required for public repos - name: Coveralls - if: ${{ matrix.os == 'ubuntu-latest' }} + if: ${{ matrix.coverage }} uses: coverallsapp/github-action@master with: github-token: ${{ secrets.GITHUB_TOKEN }} From 05772f01a7ba79f5c93441c924f4351ee42cb68f Mon Sep 17 00:00:00 2001 From: David Kopriva Date: Wed, 29 Jul 2026 12:14:46 -0700 Subject: [PATCH 14/17] Update News.md Add news about Class/type distinction --- Docs/News.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Docs/News.md b/Docs/News.md index e515d4c1..b7700944 100644 --- a/Docs/News.md +++ b/Docs/News.md @@ -1,5 +1,9 @@ # News +July 29, 2026 + +FTOL now has two versions, as necessary for procedures that need to distinguish between objects declared as TYPE and thos declared as CLASS. See the documentation and the tests for examples. + May 11, 2025 The stringValue() and stringValueForKey() functions now use allocated strings, so the requestedLength argument is no longer necessary. Existing code can continue to use the older versions, but those versions are deprecated and undocumented. \ No newline at end of file From 2411f3368fd8871cdc3ba1890c61bc2e4e2225e5 Mon Sep 17 00:00:00 2001 From: Andrew Winters Date: Wed, 29 Jul 2026 21:33:36 +0200 Subject: [PATCH 15/17] fix valgrind tests --- .github/workflows/ci.yml | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index f6f927e3..3445ab26 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -23,7 +23,7 @@ env: jobs: test: if: "!contains(github.event.head_commit.message, 'skip ci')" - name: ${{ matrix.os }} - ${{ matrix.compiler }} - ${{ matrix.test_type }} - ${{ github.event_name }} + name: ${{ matrix.os_name }} - ${{ matrix.compiler }} - ${{ matrix.test_type }} - ${{ github.event_name }} runs-on: ${{ matrix.os }} strategy: fail-fast: false @@ -31,6 +31,7 @@ jobs: include: # Linux - os: ubuntu-22.04 + os_name: linux compiler: gfortran-10 cmake_generator: Unix Makefiles shell: bash @@ -43,6 +44,7 @@ jobs: test_type: valgrind coverage: false - os: ubuntu-24.04 + os_name: linux compiler: gfortran-13 cmake_generator: Unix Makefiles shell: bash @@ -55,6 +57,7 @@ jobs: test_type: valgrind coverage: false - os: ubuntu-26.04 + os_name: linux compiler: gfortran-15 cmake_generator: Unix Makefiles shell: bash @@ -67,6 +70,7 @@ jobs: test_type: valgrind coverage: false - os: ubuntu-latest + os_name: linux compiler: ifx cmake_generator: Unix Makefiles shell: bash @@ -74,12 +78,14 @@ jobs: coverage: false # macOS - os: macos-latest + os_name: macos compiler: gfortran-13 cmake_generator: Unix Makefiles shell: bash test_type: regular coverage: false - os: macos-latest + os_name: macos compiler: gfortran-15 cmake_generator: Unix Makefiles shell: bash @@ -87,6 +93,7 @@ jobs: coverage: false # Windows - os: windows-latest + os_name: windows compiler: gfortran cmake_generator: MinGW Makefiles shell: 'msys2 {0}' @@ -154,6 +161,13 @@ jobs: run: | cd TestSuiteBuild ./runSuite + - name: Run memory checks with Valgrind (only Linux) + if: ${{ matrix.os_name == 'linux' && matrix.test_type == 'valgrind' }} + run: | + sudo apt update + sudo apt-get install -y valgrind + cd TestSuiteBuild + valgrind --error-exitcode=1 -s ./runSuite - name: Run tests for coverage if: ${{ matrix.coverage }} run: | From 5555d64d79ea30d00691ba22f5c9e0ee840f6837 Mon Sep 17 00:00:00 2001 From: Andrew Winters Date: Wed, 29 Jul 2026 21:41:05 +0200 Subject: [PATCH 16/17] gate regular versus valgrind jobs --- .github/workflows/ci.yml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 3445ab26..847de88c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -40,6 +40,7 @@ jobs: - os: ubuntu-22.04 os_name: linux compiler: gfortran-10 + cmake_generator: Unix Makefiles shell: bash test_type: valgrind coverage: false @@ -53,6 +54,7 @@ jobs: - os: ubuntu-24.04 os_name: linux compiler: gfortran-13 + cmake_generator: Unix Makefiles shell: bash test_type: valgrind coverage: false @@ -66,6 +68,7 @@ jobs: - os: ubuntu-26.04 os_name: linux compiler: gfortran-15 + cmake_generator: Unix Makefiles shell: bash test_type: valgrind coverage: false @@ -115,6 +118,7 @@ jobs: update: true install: git base-devel mingw-w64-x86_64-toolchain mingw-w64-x86_64-gcc-fortran mingw-w64-x86_64-cmake - uses: actions/cache@v6 + if: matrix.compiler == 'ifx' id: cache with: path: /opt/intel/oneapi @@ -158,6 +162,7 @@ jobs: cd TestSuiteBuild make -j 2 FC=${{ matrix.compiler }} - name: Run tests + if: ${{ matrix.test_type == 'regular' }} run: | cd TestSuiteBuild ./runSuite From cd805a46f91c3a049ec82339204eb86b5cb56deb Mon Sep 17 00:00:00 2001 From: Andrew Winters Date: Wed, 29 Jul 2026 21:42:23 +0200 Subject: [PATCH 17/17] typo fix --- Docs/News.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Docs/News.md b/Docs/News.md index b7700944..278a7417 100644 --- a/Docs/News.md +++ b/Docs/News.md @@ -2,8 +2,8 @@ July 29, 2026 -FTOL now has two versions, as necessary for procedures that need to distinguish between objects declared as TYPE and thos declared as CLASS. See the documentation and the tests for examples. +FTOL now has two versions, as necessary for procedures that need to distinguish between objects declared as TYPE and those declared as CLASS. See the documentation and the tests for examples. May 11, 2025 -The stringValue() and stringValueForKey() functions now use allocated strings, so the requestedLength argument is no longer necessary. Existing code can continue to use the older versions, but those versions are deprecated and undocumented. \ No newline at end of file +The stringValue() and stringValueForKey() functions now use allocated strings, so the requestedLength argument is no longer necessary. Existing code can continue to use the older versions, but those versions are deprecated and undocumented. \ No newline at end of file