!
! m_throwable --
!   Abstraction of a stack of exceptions.
!   A throwable object is a made of a message (a string) 
!   and a cause (a throwable object).
!
!   A throwable object made be created with no message and no cause,
!   with a message but without a cause, with a cause but without 
!   a message and with both a cause and a message.
!
!   The stack trace associated with the current object can
!   be displayed with throwable_printStackTrace, either on the 
!   standard output or a given unit number or with a callback 
!   display subroutine. The typical output is :
!
!     My throw 3
!     Caused by:My throw 2
!     Caused by:My throw 1
!
!   The throwable_exists service allows to know if 
!   the throwable object has been created, that is, if 
!   an exception has occured. The message associated can be 
!   retrieved with throwable_getmessage and the cause 
!   may be directly accessed with throwable_getcause.
!
! Copyright (c) 2008 Michael Baudin
!
! $Id: m_throwable.f90,v 1.1 2008/04/09 07:29:23 relaxmike Exp $
!
module m_throwable
  implicit none
  private
  !
  ! Public methods
  !
  public :: T_THROWABLE
  public :: throwable_exists
  public :: throwable_free
  public :: throwable_getcause
  public :: throwable_getmessage
  public :: throwable_iscause
  public :: throwable_new
  public :: throwable_printStackTrace
  public :: throwable_write
  !
  ! Maximum number of characters in a message generated by the exception
  !
  integer , parameter :: THROWABLE_MAXIMUM_LENGTH = 500
  !
  ! Derived-type to manage throwable objects
  !
  type T_THROWABLE
     private
     logical :: exists = .false.
     character ( len = THROWABLE_MAXIMUM_LENGTH ) :: message
     type ( T_THROWABLE ), pointer :: cause 
  end type T_THROWABLE
  !
  ! Interface for constructors
  !
  interface throwable_new
     module procedure throwable_new_empty
     module procedure throwable_new_cause
     module procedure throwable_new_message
     module procedure throwable_new_cause_message
  end interface throwable_new
  interface throwable_printStackTrace
     module procedure throwable_printStackTrace_onunit
     module procedure throwable_printStackTrace_callback
  end interface throwable_printStackTrace
contains
  !
  ! throwable_new_empty --
  !   Constructor
  !
  subroutine throwable_new_empty ( this )
    type ( T_THROWABLE ) , pointer :: this
    allocate ( this )
    this % exists = .true.
    this % cause => NULL ()
    this % message = ""
  end subroutine throwable_new_empty
  !
  ! throwable_new_cause --
  !   Constructor
  !
  subroutine throwable_new_cause ( this , cause )
    type ( T_THROWABLE ) , pointer :: this
    type ( T_THROWABLE ), pointer :: cause
    call throwable_new_empty ( this )
    this % cause => cause
    this % message = ""
  end subroutine throwable_new_cause
  !
  ! throwable_new_message --
  !   Constructor
  !
  subroutine throwable_new_message ( this , message )
    type ( T_THROWABLE ) , pointer :: this
    character ( len = *) , intent ( in ) :: message
    call throwable_new_empty ( this )
    this % cause => NULL ()
    this % message = message
  end subroutine throwable_new_message
  !
  ! throwable_new_cause_message --
  !   Constructor
  !
  subroutine throwable_new_cause_message ( this , cause , message )
    type ( T_THROWABLE ) , pointer :: this
    type ( T_THROWABLE ), pointer :: cause
    character ( len = *) , intent ( in ) :: message
    call throwable_new_empty ( this )
    this % cause => cause
    this % message = message
  end subroutine throwable_new_cause_message
  !
  ! throwable_free --
  !   Destructor
  !
  recursive subroutine throwable_free ( this )
    type ( T_THROWABLE ) , pointer :: this
    logical :: causeassociated
    causeassociated = associated ( this % cause )
    if ( causeassociated ) then
       call throwable_free ( this % cause )
    endif
    this % exists = .false.
    deallocate ( this )
  end subroutine throwable_free
  !
  ! throwable_iscause --
  !   Returns .true. if the current throwable object has a cause.
  !
  logical function throwable_iscause ( this )
    type ( T_THROWABLE ) , pointer :: this
    throwable_iscause = associated ( this % cause )
  end function throwable_iscause
  !
  ! throwable_getcause --
  !   Get the cause of the current throwable object
  !
  subroutine throwable_getcause ( this , cause )
    type ( T_THROWABLE ) , pointer :: this
    type ( T_THROWABLE ) , pointer :: cause
    cause => this % cause
  end subroutine throwable_getcause
  !
  ! throwable_getmessage --
  !   Get the message of the current throwable object
  !
  subroutine throwable_getmessage ( this , message )
    type ( T_THROWABLE ) , pointer :: this
    character ( len = *) , intent ( out ) :: message
    message = this % message
  end subroutine throwable_getmessage
  !
  ! throwable_write --
  !   Writes a short description of this throwable on the given unit.
  !
  subroutine throwable_write ( this , unitnumber )
    type ( T_THROWABLE ) , pointer :: this
    integer , intent ( in ) :: unitnumber
    write ( unitnumber , * ) "Throwable:"
    write ( unitnumber , * ) trim ( this % message )
  end subroutine throwable_write
  !
  ! throwable_printStackTrace_onunit --
  !   Prints this throwable and its backtrace to the given unit number.
  ! Arguments :
  !   unitnumber : if present, the messages are written on this unit number.
  !     If not provided, the messages are written on standard output.
  !
  subroutine throwable_printStackTrace_onunit ( this , unitnumber )
    type ( T_THROWABLE ) , pointer :: this
    integer , intent ( in ), optional :: unitnumber
    type ( T_THROWABLE ) , pointer  :: current
    logical :: iscause
    character ( len = THROWABLE_MAXIMUM_LENGTH ) :: message
    write ( message , * ) trim(this % message)
    call printmsg ( message )
    !
    ! Prints the stack causes
    !
    current => this
    iscause = throwable_iscause ( current )
    do while ( iscause )
       current => current % cause
       write ( message , * ) "Caused by:", trim ( current % message )
       call printmsg ( message )
       iscause = throwable_iscause ( current )
    end do
  contains
    subroutine printmsg ( message )
      character (len=*) , intent(in) :: message
      if ( present ( unitnumber ) ) then
         write ( unitnumber , * ) trim ( message )
      else
         write ( * , * ) trim ( message )
      endif
    end subroutine printmsg
  end subroutine throwable_printStackTrace_onunit
  !
  ! throwable_printStackTrace_callback --
  !   Prints this throwable and its backtrace and pass the message to 
  !   the given callback
  !
  subroutine throwable_printStackTrace_callback ( this , callback )
    type ( T_THROWABLE ) , pointer :: this
    external callback
    ! The following is regular fortran but generates an "Internal error" with IVF 8
    !!$    interface interfacecallback
    !!$       subroutine callback ( message )
    !!$         implicit none
    !!$         character ( len = * ) , intent(in) :: message
    !!$       end subroutine callback
    !!$    end interface interfacecallback
    type ( T_THROWABLE ) , pointer  :: current
    logical :: iscause
    character ( len = THROWABLE_MAXIMUM_LENGTH ) :: message
    write ( message , * ) trim ( this % message )
    call callback ( message )
    !
    ! Prints the stack causes
    !
    current => this
    iscause = throwable_iscause ( current )
    do while ( iscause )
       current => current % cause
       write ( message , * ) "Caused by:", trim ( current % message )
       call callback ( message )
       iscause = throwable_iscause ( current )
    end do
  end subroutine throwable_printStackTrace_callback
  !
  ! throwable_exists --
  !   Returns true if the current throwable object is allocated.
  !
  logical function throwable_exists ( this )
    type ( T_THROWABLE ) , pointer :: this
    logical :: isassociated
    isassociated = associated ( this )
    if ( isassociated ) then
       throwable_exists = this % exists
    else
       throwable_exists = .false.
    endif
  end function throwable_exists
end module m_throwable

