diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 6100749d..847de88c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -15,31 +15,93 @@ 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_name }} - ${{ matrix.compiler }} - ${{ matrix.test_type }} - ${{ github.event_name }} runs-on: ${{ matrix.os }} strategy: fail-fast: false matrix: include: + # Linux - os: ubuntu-22.04 + os_name: linux compiler: gfortran-10 cmake_generator: Unix Makefiles shell: bash - - os: ubuntu-latest + test_type: regular + coverage: true + - os: ubuntu-22.04 + os_name: linux + compiler: gfortran-10 + cmake_generator: Unix Makefiles + shell: bash + test_type: valgrind + coverage: false + - os: ubuntu-24.04 + os_name: linux + compiler: gfortran-13 + cmake_generator: Unix Makefiles + shell: bash + test_type: regular + coverage: false + - os: ubuntu-24.04 + os_name: linux compiler: gfortran-13 cmake_generator: Unix Makefiles shell: bash + test_type: valgrind + coverage: false + - os: ubuntu-26.04 + os_name: linux + compiler: gfortran-15 + cmake_generator: Unix Makefiles + shell: bash + test_type: regular + coverage: false + - os: ubuntu-26.04 + os_name: linux + compiler: gfortran-15 + cmake_generator: Unix Makefiles + shell: bash + test_type: valgrind + coverage: false + - os: ubuntu-latest + os_name: linux + compiler: ifx + cmake_generator: Unix Makefiles + shell: bash + test_type: regular + 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 + test_type: regular + coverage: false + # Windows - os: windows-latest + os_name: windows 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: run: @@ -55,6 +117,35 @@ 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 + if: matrix.compiler == 'ifx' + 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 @@ -71,17 +162,25 @@ jobs: cd TestSuiteBuild make -j 2 FC=${{ matrix.compiler }} - name: Run tests + if: ${{ matrix.test_type == 'regular' }} 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.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 @@ -89,7 +188,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 }} diff --git a/Docs/News.md b/Docs/News.md index e515d4c1..278a7417 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 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 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 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..8d0fdca8 100644 --- a/Source/FTObjects/FTDictionaryClass.f90 +++ b/Source/FTObjects/FTDictionaryClass.f90 @@ -107,6 +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 ! !//////////////////////////////////////////////////////////////////////// ! @@ -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..d1571bfd 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() ! @@ -718,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()) @@ -833,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 a93d3959..20b83d8e 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() @@ -729,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) @@ -873,6 +890,7 @@ Module FTLinkedListIteratorClass ! PROCEDURE :: init => initEmpty PROCEDURE :: initWithFTLinkedList + PROCEDURE :: initWithFTLinkedListClass FINAL :: destructIterator PROCEDURE :: isAtEnd => FTLinkedListIsAtEnd PROCEDURE :: object => FTLinkedListObject @@ -880,6 +898,7 @@ Module FTLinkedListIteratorClass PROCEDURE :: linkedList => returnLinkedList PROCEDURE :: className => linkedListIteratorClassName PROCEDURE :: setLinkedList + PROCEDURE :: setLinkedListClass PROCEDURE :: setToStart PROCEDURE :: moveToNext PROCEDURE :: removeCurrentRecord @@ -917,7 +936,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 @@ -936,6 +955,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) @@ -950,6 +993,20 @@ SUBROUTINE releaseFTLinkedListIterator(self) IF(.NOT.ASSOCIATED(obj)) self => NULL() END SUBROUTINE releaseFTLinkedListIterator ! +!//////////////////////////////////////////////////////////////////////// +! + SUBROUTINE releaseFTLinkedListIteratorClass(self) + IMPLICIT NONE + CLASS(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 @@ -1018,7 +1075,7 @@ END FUNCTION FTLinkedListIsAtEnd ! !//////////////////////////////////////////////////////////////////////// ! - SUBROUTINE setLinkedList(self,list) + SUBROUTINE setLinkedListClass(self,list) IMPLICIT NONE CLASS(FTLinkedListIterator) :: self CLASS(FTLinkedList), POINTER :: list @@ -1026,6 +1083,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/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..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,33 +165,46 @@ SUBROUTINE releaseFTMutableObjectArray(self) CLASS(FTObject) , POINTER :: obj IF(.NOT. ASSOCIATED(self)) RETURN - obj => self CALL release(obj) IF(.NOT.ASSOCIATED(obj)) self => NULL() 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 !> 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 DO i = 1, self % count_ obj => self % array(i) % object - IF ( ASSOCIATED(obj) ) CALL releaseFTObject(self = obj) + 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 ! !//////////////////////////////////////////////////////////////////////// diff --git a/Source/FTObjects/FTSparseMatrixClass.f90 b/Source/FTObjects/FTSparseMatrixClass.f90 index af01e3fd..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()) @@ -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..ef74e008 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") @@ -113,7 +117,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") ! ! --------------------------------------------------------------------------------- @@ -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) - CALL iterator % initWithFTLinkedList(list) + 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") @@ -272,8 +281,9 @@ 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") + CALL releaseFTLinkedList(listType) ! ! ------------------------------------------------------------------- ! Normally we would now check if the list should be deallocated. But @@ -289,8 +299,14 @@ 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) +! +! ---------------------------------------------- +! Operations on the class version of the pointer +! ---------------------------------------------- +! END SUBROUTINE basicTests ! !//////////////////////////////////////////////////////////////////////// @@ -352,7 +368,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()) @@ -370,7 +386,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 +446,7 @@ SUBROUTINE TestAppendingLists ! Clean up ! -------- ! - CALL releaseFTLinkedList(list1) + CALL releaseFTLinkedListClass(list1) CALL releaseFTLinkedListIterator(iterator) END SUBROUTINE TestAppendingLists @@ -481,7 +497,7 @@ SUBROUTINE TestDeletingObjects ! ------------------------------------------------------------ ! ALLOCATE(iterator) - CALL iterator % initwithFTLinkedList(list) + CALL iterator % initwithFTLinkedListClass(list) ! ! --------------- ! Delete the tail @@ -546,7 +562,7 @@ SUBROUTINE TestDeletingObjects ! Clean up ! -------- ! - CALL releaseFTLinkedList(list) + CALL releaseFTLinkedListClass(list) CALL releaseFTLinkedListIterator(iterator) END SUBROUTINE TestDeletingObjects @@ -604,8 +620,8 @@ SUBROUTINE TestInsertingObjects ! --------------------------------- ! ALLOCATE(iterator) - CALL iterator % initwithFTLinkedList(list) - CALL releaseFTLinkedList(list) + CALL iterator % initwithFTLinkedListClass(list) + CALL releaseFTLinkedListClass(list) CALL iterator % setToStart() DO j = 1, 3 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 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")