trixi-framework / FTObjectLibrary / 30206241592

! 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 releaseFTExceptionClass(e) [pointers]

!>        CALL releaseFTException(e) [pointers, TYPE]

!>

!>###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

!     ========

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! ---------------------------------------------

!>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()

         CALL self % initFTException(severity       = FT_ERROR_WARNING,&

                                     exceptionName  = FTWarningErrorException,&

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! ---------------------------------------------

!>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()

         CALL self % initFTException(severity       = FT_ERROR_FATAL,&

                                     exceptionName  = FTFatalErrorException,&

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! -----------------------------------

!>The main initializer for the class 

! -----------------------------------

!

         IMPLICIT NONE

         CLASS(FTException)                     :: self

         INTEGER                                :: severity

         CHARACTER(LEN=*)                       :: exceptionName

         CLASS(FTDictionary), POINTER, OPTIONAL :: infoDictionary

         END IF 

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! ------------------------------------------------

!>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()

         CALL self % initFTException(severity       = level,&

                                     exceptionName  = FTAssertionFailureException,&

!

!//////////////////////////////////////////////////////////////////////// 

! 

         IMPLICIT NONE

         CLASS(FTException) , POINTER :: self

         CLASS(FTObject)    , POINTER :: obj

      END SUBROUTINE releaseFTExceptionClass

!

!//////////////////////////////////////////////////////////////////////// 

! 

         IMPLICIT NONE

         TYPE(FTException)  , POINTER :: self

         CLASS(FTObject)    , POINTER :: obj

      END SUBROUTINE releaseFTException

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! -------------------------------------------------------------

!>The destructor for the class. Do not call this directly. Call

!>the release() procedure instead

! -------------------------------------------------------------

!

         IMPLICIT NONE  

         TYPE(FTException)       :: self

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! ---------------------------------------------

!>Sets and retains the exception infoDictionary

! ---------------------------------------------

!

         IMPLICIT NONE

         CLASS(FTException)           :: self

         CLASS(FTDictionary), POINTER :: dict

!

!//////////////////////////////////////////////////////////////////////// 

! 

         IMPLICIT NONE  

         CLASS(FTException)       :: self

         CLASS(FTObject), POINTER :: obj

         END IF

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! ---------------------------------------------

!>Returns the exception's infoDictionary. Does

!>not transfer ownership/reference count is 

!>unchanged.

! ---------------------------------------------

!

        IMPLICIT NONE  

        CLASS(FTException) :: self

        CLASS(FTDictionary), POINTER :: infoDictionary

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! ---------------------------------------------

!>Returns the string representing the name set

!>for the exception.

! ---------------------------------------------

!

        IMPLICIT NONE  

        CLASS(FTException) :: self

        CHARACTER(LEN=ERROR_MSG_STRING_LENGTH) :: exceptionName

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! ---------------------------------------------

!>Returns the severity level of the exception.

! ---------------------------------------------

!

        IMPLICIT NONE  

        CLASS(FTException) :: self

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! ----------------------------------------------

!>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,*) "-------------"

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! -----------------------------------------------------

!>Cast the base class FTObject to the FTException class

! -----------------------------------------------------

!

         IMPLICIT NONE  

         CLASS(FTObject)   , POINTER :: obj

         CLASS(FTException), POINTER :: cast

         SELECT TYPE (e => obj)

            TYPE is (FTException)

            CLASS DEFAULT

         END SELECT

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

!     -----------------------------------------------------

!     Cast the base class FTObject to the FTException class

!     -----------------------------------------------------

!

         IMPLICIT NONE  

         CLASS(FTObject)   , POINTER :: obj

         CLASS(FTException), POINTER :: cast

         SELECT TYPE (e => obj)

            TYPE is (FTException)

            CLASS DEFAULT

         END SELECT

!

!//////////////////////////////////////////////////////////////////////// 

! 

!      -----------------------------------------------------------------

!> Class name returns a string with the name of the type of the object

!>

!>  ### Usage:

!>

!>        PRINT *,  obj % className()

!>        if( obj % className = "FTException")

!>

         IMPLICIT NONE  

         CLASS(FTException)                         :: self

         CHARACTER(LEN=CLASS_NAME_CHARACTER_LENGTH) :: s

!

!//////////////////////////////////////////////////////////////////////// 

! 

!@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")

!>         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

!     ========

!

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

!>Called at start of execution. Will be called automatically if an 

!>exception is thrown.

!

         IMPLICIT NONE

         END IF

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

!>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.

!        --------------------------------------------------

!

           ELSE

           END IF

         END IF 

!

!        -----------------------

!        Destruct the exceptions

!        -----------------------

!

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

!>Throws the exception: exceptionToThrow

!

         IMPLICIT NONE  

         TYPE (FTException), POINTER :: exceptionToThrow

         CLASS(FTObject)   , POINTER :: ptr => NULL()

         END IF 

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

!>Throws the exception: exceptionToThrow

!

         IMPLICIT NONE  

         CLASS (FTException), POINTER :: exceptionToThrow

         CLASS(FTObject)    , POINTER :: ptr => NULL()

         END IF 

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! -------------------------------------------

!>Returns .TRUE. if there are any exceptions.

! -------------------------------------------

!

         IMPLICIT NONE

         END IF 

         END IF

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! ------------------------------------------

!>Returns the number of exceptions that have 

!>been thrown.

! ------------------------------------------

!

         IMPLICIT NONE

         END IF 

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! -----------------------------------------------

!>Returns the maxSeverity of exceptions that have 

!>been thrown.

! -----------------------------------------------

!

         IMPLICIT NONE

         END IF 

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! --------------------------------------------

!>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

         CLASS(FTLinkedList), POINTER :: ptr => NULL()

         CLASS(FTObject)    , POINTER :: obj => NULL()

         CLASS(FTException) , POINTER :: e   => NULL()

         END IF 

         END IF 

           END IF 

         END DO

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! -------------------------------------------

!>Returns a pointer to the current exception.

! -------------------------------------------

!

         IMPLICIT NONE

         CLASS(FTException), POINTER :: errorObject

         END IF 

!

!//////////////////////////////////////////////////////////////////////// 

! 

         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.

!        --------------------------------------------------------------

!

!

!        ------------------------------------

!        Set the pointer and retain ownership

!        ------------------------------------

!

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! ----------------------------------------------------------------

!>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()

         ELSE

         END IF 

!

!//////////////////////////////////////////////////////////////////////// 

! 

!

! ----------------------------------------------------------------

!>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()

         END IF 

!

!//////////////////////////////////////////////////////////////////////// 

! 

         IMPLICIT NONE  

         CLASS(FTLinkedList), POINTER :: list      => NULL()

         CLASS(FTObject)    , POINTER :: objectPtr => NULL()

         CLASS(FTException) , POINTER :: e         => NULL()

!

!       ----------------------------------------------------

!       Write out the descriptions of each of the exceptions

!       ----------------------------------------------------

!

         END DO

!

!//////////////////////////////////////////////////////////////////////// 

! 

         IMPLICIT NONE

         CLASS(FTObject), POINTER :: obj

         END IF 

      END MODULE SharedExceptionManagerModule