itm_assert.f90

Go to the documentation of this file.

module itm_assert

  !> Assertions for Fortran 90, written by H.-J. Klingshirn

  !> @author 

  use itm_types , itm_r8 => r8, itm_r4 => r4
  use itm_string 

  implicit none

  private

  public assertsetstopmode, assertsetmsgprefix, assertstoponfailed, assert, assertequal, assertreset

  logical, save :: defaultdostop = .true.
  integer, save :: failcount = 0
  integer, save :: msgprefixlen = 0
  character(256), save :: msgprefix

contains

  !> Private subroutine that handles a failed assertion. Prints out the
  !> fail message (msgPrefix + failmsg, depending on what is given), and 
  !> either stops of does assertion bookkeeping. 

  !> @param failmsg The fail message to print
  !> @param doStop Controls whether to stop execution. If doStop .true., 
  !> the program is stopped. If .false., only the fail message is printed
  !> and bookkeeping is done for delayed stopping (@see assertStopOnFailed)

  subroutine assertfail( failmsg, doStop )
    character(*), intent(in), optional :: failmsg
    logical, intent(in), optional :: dostop

    ! internal
    logical :: ldostop

    ldostop = defaultdostop
    if ( present( dostop ) ) ldostop = dostop

    if ( present( failmsg ) ) then
            if ( msgprefixlen > 0 ) then
                    write (*,*) 'itm_assert: '//msgprefix(1:msgprefixlen)//' '//failmsg
            else
                    write (*,*) 'itm_assert: '//failmsg       
            end if
    else
            if ( msgprefixlen > 0 ) then
                    write (*,*) 'itm_assert: '//msgprefix(1:msgprefixlen)
            end if
    end if

    if ( ldostop ) then
       stop "itm_assert: an assertion failed, stopping immediately."
    else
       failcount = failcount + 1
       write(*,*) "itm_assert: an assertion failed, continuing."
    end if
    
  end subroutine assertfail


  !> Set the default assertion stop behaviour. 

  !> @param doStop .true. means immediate
  !> stop on fail, .false. means don't stop on fail (for use with 
  !> delayed stopping, @see assertStopOnFailed). The default value is .true.,
  !> it is set if doStop is omitted.
  subroutine assertsetstopmode( doStop )
    logical, intent(in), optional :: dostop

    if ( present( dostop ) ) then
            defaultdostop = dostop
    else
            ! if no argument given, just set default again
            defaultdostop = .true.           
    end if
    
  end subroutine assertsetstopmode


  !> Set a prefix for the assertion fail message.
  !> @param prefix The prefix string for the fail messages. Optional. If 
  !> omitted, clear the prefix string (i.e. no prefix is used anymore)
  subroutine assertsetmsgprefix( prefix )
    character(len=*), intent(in), optional :: prefix

    if ( present( prefix ) ) then
            msgprefixlen = min( len(prefix), len( msgprefix ) )
            msgprefix(1:msgprefixlen) = prefix(1:msgprefixlen)
    else
            msgprefixlen = 0
    end if
    
  end subroutine assertsetmsgprefix


  !> Reset the assertion module to its default state.
  !>
  !> Reset stop mode and message prefix to their default values.
  !> Also resets the fail counter, i.e. any previous failed assertions are forgotton.
  subroutine assertreset()
    call assertsetstopmode()       
    call assertsetmsgprefix()
    failcount = 0
  end subroutine assertreset
  

  !> Stop if a previously called assertion failed (delayed stop). 

  !> This is useful if the
  !> default stop mode is set to continue on failed assertions (which
  !> can be enabled by call assertSetStopMode( .false. ). 

  !> @param failmsg Message to print if assertion(s) failed.
  !> @param doStop Controls stop behaviour, @see assert. Overrides the default
  !> set with @see assertSetStopMode

  subroutine assertstoponfailed( failmsg, doStop )
    character(*), intent(in), optional :: failmsg
    logical, intent(in), optional :: dostop

    ! internal
    logical :: ldostop 
    
    ldostop = .true. ! default for this routine is to stop, regardless of current module default    
    if ( present( dostop ) ) ldostop = dostop ! ...but can be overridden again with optional argument

    if ( present( failmsg ) ) then
            ! ...use given message
            call assert( failcount == 0, failmsg, ldostop )
    else
            ! ...or substitute generic message
            call assert( failcount == 0, itmint2str( failcount )//' assertions failed', ldostop )
    end if
    failcount = 0

  end subroutine assertstoponfailed
  

  !> A generic assertion, tests a given logical expression. 

  !> If it evaluates to .false.,
  !> print the fail message and possibly stop execution.
  !> 
  !> @param test The logical expression to test.
  !> @param failmsg The message to print on fail. If omitted, a generic message is printed. Can be modified with a prefix (see assertSetMsgPrefix)
  !> @param doStop Controls whether to stop execution. If doStop .true., 
  !> the program is stopped. If .false., only the fail message is printed
  !> and bookkeeping is done for delayed stopping (see assertStopOnFailed).
  !> If given, overrides the default behaviour  set by assertSetStopMode.

  !> @see assertStopOnFailed
  !> @see assertSetStopMode
  !> @see assertSetMsgPrefix

  !> @author H.-J. Klingshirn 
  !> @version 1.0 

  subroutine assert( test, failmsg, doStop )
    logical, intent(in) :: test
    character(*), intent(in), optional :: failmsg
    logical, intent(in), optional :: dostop

    if ( .not. test ) then
       call assertfail( failmsg, dostop )
    end if

  end subroutine assert


  !> Test double precision floating point numbers for equality.

  !> @param x1, x2 The values to test
  !> @param failmsg Same as for assert
  !> @param doStop Same as for assert
  !> @see assert

  subroutine assertequal( x1, x2, failmsg, doStop )
    real(ITM_R8), intent(in) :: x1, x2
    character(*), intent(in), optional :: failmsg
    logical, intent(in), optional :: dostop

    ! x1 is reference value
    ! x2 is actual value

    if ( .not. ( ( ( x1 + 2 * spacing( real( x1 ) ) ) >= x2 ) &
           & .and. ( x1 - 2 * spacing( real( x1 ) ) ) <= x2 ) ) then

       call assertfail( failmsg, dostop )

    end if
    
  end subroutine assertequal


end module itm_assert