! MIT License ! ! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal ! in the Software without restriction, including without limitation the rights ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ! copies of the Software, and to permit persons to whom the Software is ! furnished to do so, subject to the following conditions: ! ! The above copyright notice and this permission notice shall be included in all ! copies or substantial portions of the Software. ! ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ! SOFTWARE. ! ! FTObjectLibrary contains code that, to the best of our knowledge, has been released as ! public domain software: ! * `b3hs_hash_key_jenkins`: originally by Rich Townsend, ! https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005 ! ! --- End License ! !//////////////////////////////////////////////////////////////////////// ! ! FTExceptionClass.f90 ! Created: January 29, 2013 5:06 PM ! By: David Kopriva ! ! !>An FTException object gives a way to pass generic !>information about an exceptional situation. !> !>An FTException object gives a way to pass generic !>information about an exceptional situation. Methods for !>dealing with exceptions are defined in the SharedExceptionManagerModule !>module. !> !>An FTException object wraps: !> !>- A severity indicator !>- A name for the exception !>- An optional dictionary that contains whatever information is deemed necessary. !> !>It is expected that classes will define exceptions that use instances !>of the FTException Class. !> !>### Defined constants: !> !>- FT_ERROR_NONE = 0 !>- FT_ERROR_WARNING = 1 !>- FT_ERROR_FATAL = 2 !> !>### Initialization !> !> CALL e % initFTException(severity,exceptionName,infoDictionary) !> !>Plus the convenience initializers, which automatically create a FTValueDictionary with a single key called "message": !> !> CALL e % initWarningException(msg = "message") !> CALL e % initFatalException(msg = "message") !> !>Plus an assertion exception !> !> CALL e % initAssertionFailureException(msg,expectedValueObject,observedValueObject,level) !> !>### Destruction !> !> CALL releaseFTException(e) [pointers] !> !>###Setting the infoDictionary !> !> CALL e % setInfoDictionary(infoDictionary) !>###Getting the infoDictionary !> !> dict => e % infoDictionary !>###Getting the name of the exception !> !> name = e % exceptionName() !>###Getting the severity level of the exception !> !> level = e % severity() !> Severity levels are FT_ERROR_WARNING or FT_ERROR_FATAL !>###Printing the exception !> !> CALL e % printDescription() !> ! !//////////////////////////////////////////////////////////////////////// ! Module FTExceptionClass USE FTStackClass USE FTDictionaryClass USE FTValueDictionaryClass USE FTLinkedListIteratorClass IMPLICIT NONE ! ! ---------------- ! Global constants ! ---------------- ! INTEGER, PARAMETER :: FT_ERROR_NONE = 0, FT_ERROR_WARNING = 1, FT_ERROR_FATAL = 2 INTEGER, PARAMETER :: ERROR_MSG_STRING_LENGTH = 132 CHARACTER(LEN=21), PARAMETER :: FTFatalErrorException = "FTFatalErrorException" CHARACTER(LEN=23), PARAMETER :: FTWarningErrorException = "FTWarningErrorException" CHARACTER(LEN=27), PARAMETER :: FTAssertionFailureException = "FTAssertionFailureException" ! ! --------------- ! Error base type ! --------------- ! TYPE, EXTENDS(FTObject) :: FTException INTEGER, PRIVATE :: severity_ CHARACTER(LEN=ERROR_MSG_STRING_LENGTH), PRIVATE :: exceptionName_ CLASS(FTDictionary), POINTER, PRIVATE :: infoDictionary_ => NULL() ! ! -------- CONTAINS ! -------- ! PROCEDURE :: initFTException PROCEDURE :: initWarningException PROCEDURE :: initFatalException PROCEDURE :: initAssertionFailureException FINAL :: destructException PROCEDURE :: setInfoDictionary PROCEDURE :: infoDictionary PROCEDURE :: exceptionName PROCEDURE :: severity PROCEDURE :: printDescription => printFTExceptionDescription PROCEDURE :: className => exceptionClassName END TYPE FTException INTERFACE cast MODULE PROCEDURE castToException END INTERFACE cast ! ! ======== CONTAINS ! ======== ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE initWarningException(self,msg) ! ! --------------------------------------------- !>A convenience initializer for a warning error !>that includes the key "message" in the !>infoDictionary. Use this initializer as an !>example of how to write one's own exception. ! -------------------------------------------- ! IMPLICIT NONE CLASS(FTException) :: self CHARACTER(LEN=*) :: msg CLASS(FTValueDictionary), POINTER :: userDictionary => NULL() CLASS(FTDictionary) , POINTER :: dictPtr => NULL() ALLOCATE(userDictionary) CALL userDictionary % initWithSize(64) CALL userDictionary % addValueForKey(msg,"message") dictPtr => userDictionary CALL self % initFTException(severity = FT_ERROR_WARNING,& exceptionName = FTWarningErrorException,& infoDictionary = dictPtr) CALL releaseMemberDictionary(self) END SUBROUTINE initWarningException ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE initFatalException(self,msg) ! ! --------------------------------------------- !>A convenience initializer for a fatal error !>that includes the key "message" in the !>infoDictionary.Use this initializer as an !>example of how to write one's own exception. ! -------------------------------------------- ! IMPLICIT NONE CLASS(FTException) :: self CHARACTER(LEN=*) :: msg CLASS(FTValueDictionary), POINTER :: userDictionary => NULL() CLASS(FTDictionary) , POINTER :: dictPtr => NULL() ALLOCATE(userDictionary) CALL userDictionary % initWithSize(8) CALL userDictionary % addValueForKey(msg,"message") dictPtr => userDictionary CALL self % initFTException(severity = FT_ERROR_FATAL,& exceptionName = FTFatalErrorException,& infoDictionary = dictPtr) CALL releaseMemberDictionary(self) END SUBROUTINE initFatalException ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE initFTException(self,severity,exceptionName,infoDictionary) ! ! ----------------------------------- !>The main initializer for the class ! ----------------------------------- ! IMPLICIT NONE CLASS(FTException) :: self INTEGER :: severity CHARACTER(LEN=*) :: exceptionName CLASS(FTDictionary), POINTER, OPTIONAL :: infoDictionary CALL self % FTObject % init() self % severity_ = severity self % exceptionName_ = exceptionName self % infoDictionary_ => NULL() IF(PRESENT(infoDictionary) .AND. ASSOCIATED(infoDictionary)) THEN CALL self % setInfoDictionary(infoDictionary) END IF END SUBROUTINE initFTException ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE initAssertionFailureException(self,msg,expectedValueObject,observedValueObject,level) ! ! ------------------------------------------------ !>A convenience initializer for an assertion error !>that includes the keys: !> !>-"message" !>-"expectedValue" !>-"observedValue" !> !>in the infoDictionary ! ! ------------------------------------------------ ! IMPLICIT NONE CLASS(FTException) :: self CLASS(FTValue), POINTER :: expectedValueObject, ObservedValueObject INTEGER :: level CHARACTER(LEN=*) :: msg CLASS(FTValueDictionary), POINTER :: userDictionary => NULL() CLASS(FTDictionary) , POINTER :: dictPtr => NULL() CLASS(FTObject) , POINTER :: objectPtr => NULL() ALLOCATE(userDictionary) CALL userDictionary % initWithSize(8) CALL userDictionary % addValueForKey(msg,"message") objectPtr => expectedValueObject CALL userDictionary % addObjectForKey(object = objectPtr,key = "expectedValue") objectPtr => ObservedValueObject CALL userDictionary % addObjectForKey(object = objectPtr,key = "observedValue") dictPtr => userDictionary CALL self % initFTException(severity = level,& exceptionName = FTAssertionFailureException,& infoDictionary = dictPtr) CALL releaseMemberDictionary(self) END SUBROUTINE initAssertionFailureException ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE releaseFTException(self) IMPLICIT NONE TYPE(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 releaseFTException ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE destructException(self) ! ! ------------------------------------------------------------- !>The destructor for the class. Do not call this directly. Call !>the release() procedure instead ! ------------------------------------------------------------- ! IMPLICIT NONE TYPE(FTException) :: self CALL releaseMemberDictionary(self) END SUBROUTINE destructException ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE setInfoDictionary( self, dict ) ! ! --------------------------------------------- !>Sets and retains the exception infoDictionary ! --------------------------------------------- ! IMPLICIT NONE CLASS(FTException) :: self CLASS(FTDictionary), POINTER :: dict IF(ASSOCIATED(self % infoDictionary_)) CALL releaseMemberDictionary(self) self % infoDictionary_ => dict CALL self % infoDictionary_ % retain() END SUBROUTINE setInfoDictionary ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE releaseMemberDictionary(self) IMPLICIT NONE CLASS(FTException) :: self CLASS(FTObject), POINTER :: obj IF(ASSOCIATED(self % infoDictionary_)) THEN obj => self % infoDictionary_ CALL releaseFTObject(self = obj) IF(.NOT. ASSOCIATED(obj)) self% infoDictionary_ => NULL() END IF END SUBROUTINE releaseMemberDictionary ! !//////////////////////////////////////////////////////////////////////// ! FUNCTION infoDictionary(self) ! ! --------------------------------------------- !>Returns the exception's infoDictionary. Does !>not transfer ownership/reference count is !>unchanged. ! --------------------------------------------- ! IMPLICIT NONE CLASS(FTException) :: self CLASS(FTDictionary), POINTER :: infoDictionary infoDictionary => self % infoDictionary_ END FUNCTION infoDictionary ! !//////////////////////////////////////////////////////////////////////// ! FUNCTION exceptionName(self) ! ! --------------------------------------------- !>Returns the string representing the name set !>for the exception. ! --------------------------------------------- ! IMPLICIT NONE CLASS(FTException) :: self CHARACTER(LEN=ERROR_MSG_STRING_LENGTH) :: exceptionName exceptionName = self % exceptionName_ END FUNCTION exceptionName ! !//////////////////////////////////////////////////////////////////////// ! INTEGER FUNCTION severity(self) ! ! --------------------------------------------- !>Returns the severity level of the exception. ! --------------------------------------------- ! IMPLICIT NONE CLASS(FTException) :: self severity = self % severity_ END FUNCTION severity ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE printFTExceptionDescription(self,iUnit) ! ! ---------------------------------------------- !>A basic printing of the exception and the info !>held in the infoDictionary. ! ---------------------------------------------- ! IMPLICIT NONE CLASS(FTException) :: self INTEGER :: iUnit CLASS(FTDictionary), POINTER :: dict => NULL() ! WRITE(iUnit,*) "-------------" WRITE(iUnit,*) " " WRITE(iUnit,*) "Exception Named: ", TRIM(self % exceptionName()) dict => self % infoDictionary() IF(ASSOCIATED(dict)) CALL dict % printDescription(iUnit) END SUBROUTINE printFTExceptionDescription ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE castToException(obj,cast) ! ! ----------------------------------------------------- !>Cast the base class FTObject to the FTException class ! ----------------------------------------------------- ! IMPLICIT NONE CLASS(FTObject) , POINTER :: obj CLASS(FTException), POINTER :: cast cast => NULL() SELECT TYPE (e => obj) TYPE is (FTException) cast => e CLASS DEFAULT END SELECT END SUBROUTINE castToException ! !//////////////////////////////////////////////////////////////////////// ! FUNCTION exceptionFromObject(obj) RESULT(cast) ! ! ----------------------------------------------------- ! Cast the base class FTObject to the FTException class ! ----------------------------------------------------- ! IMPLICIT NONE CLASS(FTObject) , POINTER :: obj CLASS(FTException), POINTER :: cast cast => NULL() SELECT TYPE (e => obj) TYPE is (FTException) cast => e CLASS DEFAULT END SELECT END FUNCTION exceptionFromObject ! !//////////////////////////////////////////////////////////////////////// ! ! ----------------------------------------------------------------- !> Class name returns a string with the name of the type of the object !> !> ### Usage: !> !> PRINT *, obj % className() !> if( obj % className = "FTException") !> FUNCTION exceptionClassName(self) RESULT(s) IMPLICIT NONE CLASS(FTException) :: self CHARACTER(LEN=CLASS_NAME_CHARACTER_LENGTH) :: s s = "FTException" IF( self % refCount() >= 0) CONTINUE !Quiet unused variable warnings END FUNCTION exceptionClassName END Module FTExceptionClass ! !//////////////////////////////////////////////////////////////////////// ! !@mark - Module SharedExceptionManagerModule !> !>All exceptions are posted to the SharedExceptionManagerModule. !> !>To use exceptions,first initialize it !> CALL initializeFTExceptions !>From that point on, all exceptions will be posted there. Note that the !>FTTestSuiteManager class will initialize the SharedExceptionManagerModule, !>so there is no need to do the initialization separately if the FTTestSuiteManager !>class has been initialized. !> !>The exceptions are posted to a stack. To access the exceptions they will be !>peeked or popped from that stack. !> !>###Initialization !> CALL initializeFTExceptions !>###Finalization !> CALL destructFTExceptions !>###Throwing an exception !> CALL throw(exception) !>###Getting the number of exceptions !> n = errorCount() !>###Getting the maximum exception severity !> s = maximumErrorSeverity() !>###Catching all exceptions !> IF(catch()) THEN !> Do something with the exceptions !> END IF !>###Getting the named exception caught !> CLASS(FTException), POINTER :: e !> e => errorObject() !>###Popping the top exception !> e => popLastException() !>###Peeking the top exception !> e => peekLastException() !>###Catching an exception with a given name !> IF(catch(name)) THEN !> !Do something with the exception, e.g. !> e => errorObject() !> d => e % infoDictionary() !> userDictionary => valueDictionaryFromDictionary(dict = d) !> msg = userDictionary % stringValueForKey("message",FTDICT_KWD_STRING_LENGTH) !> END IF !>###Printing all exceptions !> call printAllExceptions !> USE FTExceptionClass IMPLICIT NONE ! ! -------------------- ! Global error stack ! -------------------- ! TYPE(FTStack) , POINTER, PRIVATE :: errorStack => NULL() TYPE(FTException), POINTER, PRIVATE :: currentError_ => NULL() INTEGER , PRIVATE :: maxErrorLevel INTERFACE catch MODULE PROCEDURE catchAll MODULE PROCEDURE catchErrorWithName END INTERFACE catch PRIVATE :: catchAll, catchErrorWithName ! ! ======== CONTAINS ! ======== ! ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE initializeFTExceptions ! !>Called at start of execution. Will be called automatically if an !>exception is thrown. ! IMPLICIT NONE IF ( .NOT.ASSOCIATED(errorStack) ) THEN ALLOCATE(errorStack) CALL errorStack % init() currentError_ => NULL() END IF maxErrorLevel = FT_ERROR_NONE END SUBROUTINE initializeFTExceptions ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE destructFTExceptions ! !>Called at the end of execution. This procedure will announce if there !>are uncaught exceptions raised and print them. ! IMPLICIT NONE CLASS(FTObject), POINTER :: obj ! ! -------------------------------------------------- ! First see if there are any uncaught exceptions and ! report them if there are. ! -------------------------------------------------- ! IF ( catch() ) THEN PRINT * PRINT *," ***********************************" IF(errorStack % COUNT() == 1) THEN PRINT *, " An uncaught exception was raised:" ELSE PRINT *, " Uncaught exceptions were raised:" END IF PRINT *," ***********************************" PRINT * CALL printAllExceptions END IF ! ! ----------------------- ! Destruct the exceptions ! ----------------------- ! obj => errorStack CALL releaseFTObject(self = obj) IF(.NOT. ASSOCIATED(obj)) errorStack => NULL() CALL releaseCurrentError END SUBROUTINE destructFTExceptions ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE throw(exceptionToThrow) ! !>Throws the exception: exceptionToThrow ! IMPLICIT NONE TYPE (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 throw ! !//////////////////////////////////////////////////////////////////////// ! LOGICAL FUNCTION catchAll() ! ! ------------------------------------------- !>Returns .TRUE. if there are any exceptions. ! ------------------------------------------- ! IMPLICIT NONE IF ( .NOT.ASSOCIATED(errorStack) ) THEN catchAll = .FALSE. RETURN END IF catchAll = .false. IF ( errorStack % count() > 0 ) THEN catchAll = .true. END IF CALL releaseCurrentError END FUNCTION catchAll ! !//////////////////////////////////////////////////////////////////////// ! INTEGER FUNCTION errorCount() ! ! ------------------------------------------ !>Returns the number of exceptions that have !>been thrown. ! ------------------------------------------ ! IMPLICIT NONE IF ( .NOT.ASSOCIATED(errorStack) ) THEN CALL initializeFTExceptions END IF errorCount = errorStack % count() END FUNCTION ! !//////////////////////////////////////////////////////////////////////// ! INTEGER FUNCTION maximumErrorSeverity() ! ! ----------------------------------------------- !>Returns the maxSeverity of exceptions that have !>been thrown. ! ----------------------------------------------- ! IMPLICIT NONE IF ( .NOT.ASSOCIATED(errorStack) ) THEN CALL initializeFTExceptions END IF maximumErrorSeverity = maxErrorLevel END FUNCTION maximumErrorSeverity ! !//////////////////////////////////////////////////////////////////////// ! LOGICAL FUNCTION catchErrorWithName(exceptionName) ! ! -------------------------------------------- !>Returns .TRUE. if there is an exception with !>the requested name. If so, it pops the !>exception and saves the pointer to it so that !>it can be accessed with the currentError() !>function. ! -------------------------------------------- ! IMPLICIT NONE CHARACTER(LEN=*) :: exceptionName TYPE(FTLinkedListIterator) :: iterator CLASS(FTLinkedList), POINTER :: ptr => NULL() CLASS(FTObject) , POINTER :: obj => NULL() CLASS(FTException) , POINTER :: e => NULL() catchErrorWithName = .false. IF ( .NOT.ASSOCIATED(errorStack) ) THEN CALL initializeFTExceptions RETURN END IF IF ( errorStack % COUNT() == 0 ) THEN RETURN END IF ptr => errorStack CALL iterator % initWithFTLinkedList(ptr) CALL iterator % setToStart() DO WHILE (.NOT.iterator % isAtEnd()) obj => iterator % object() CALL cast(obj,e) IF ( e % exceptionName() == exceptionName ) THEN CALL setCurrentError(e) catchErrorWithName = .true. CALL errorStack % remove(obj) EXIT END IF CALL iterator % moveToNext() END DO END FUNCTION catchErrorWithName ! !//////////////////////////////////////////////////////////////////////// ! FUNCTION errorObject() ! ! ------------------------------------------- !>Returns a pointer to the current exception. ! ------------------------------------------- ! IMPLICIT NONE CLASS(FTException), POINTER :: errorObject IF ( .NOT.ASSOCIATED(errorStack) ) THEN CALL initializeFTExceptions END IF errorObject => currentError_ END FUNCTION errorObject ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE setCurrentError(e) IMPLICIT NONE CLASS(FTException) , POINTER :: e ! ! -------------------------------------------------------------- ! Check first to see if there is a current error. Since it ! is retained, the current one must be released before resetting ! the pointer. ! -------------------------------------------------------------- ! CALL releaseCurrentError ! ! ------------------------------------ ! Set the pointer and retain ownership ! ------------------------------------ ! currentError_ => e CALL currentError_ % retain() END SUBROUTINE setCurrentError ! !//////////////////////////////////////////////////////////////////////// ! FUNCTION popLastException() ! ! ---------------------------------------------------------------- !>Get the last exception posted. This is popped from the stack. !>The caller is responsible for releasing the object after popping ! ---------------------------------------------------------------- ! IMPLICIT NONE CLASS(FTException), POINTER :: popLastException CLASS(FTObject) , POINTER :: obj => NULL() obj => NULL() popLastException => NULL() IF ( .NOT.ASSOCIATED(errorStack) ) THEN CALL initializeFTExceptions ELSE CALL errorStack % pop(obj) IF(ASSOCIATED(obj)) CALL cast(obj,popLastException) END IF END FUNCTION popLastException ! !//////////////////////////////////////////////////////////////////////// ! FUNCTION peekLastException() ! ! ---------------------------------------------------------------- !>Get the last exception posted. This is NOT popped from the stack. !>The caller does not own the object. ! ---------------------------------------------------------------- ! IMPLICIT NONE CLASS(FTException), POINTER :: peekLastException CLASS(FTObject) , POINTER :: obj => NULL() IF ( .NOT.ASSOCIATED(errorStack) ) THEN CALL initializeFTExceptions END IF peekLastException => NULL() obj => errorStack % peek() CALL cast(obj,peekLastException) END FUNCTION peekLastException ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE printAllExceptions IMPLICIT NONE TYPE(FTLinkedListIterator) :: iterator CLASS(FTLinkedList), POINTER :: list => NULL() CLASS(FTObject) , POINTER :: objectPtr => NULL() CLASS(FTException) , POINTER :: e => NULL() list => errorStack CALL iterator % initWithFTLinkedList(list) ! ! ---------------------------------------------------- ! Write out the descriptions of each of the exceptions ! ---------------------------------------------------- ! CALL iterator % setToStart DO WHILE (.NOT.iterator % isAtEnd()) objectPtr => iterator % object() CALL cast(objectPtr,e) CALL e % printDescription(6) CALL iterator % moveToNext() END DO END SUBROUTINE printAllExceptions ! !//////////////////////////////////////////////////////////////////////// ! SUBROUTINE releaseCurrentError IMPLICIT NONE CLASS(FTObject), POINTER :: obj IF ( ASSOCIATED(currentError_) ) THEN obj => currentError_ CALL releaseFTObject(self = obj) IF(.NOT. ASSOCIATED(obj)) currentError_ => NULL() END IF END SUBROUTINE releaseCurrentError END MODULE SharedExceptionManagerModule