c The assertion facility used when testing from Fortran.
c See assert.inc for details and examples.
c
c @author J. Czechowski IV / Jay Hallam
c @version $Id: assert.for,v 1.4 2007/11/02 20:00:16 jxc Exp $
c


c**********************************************************************c
c       Performs initialization
c       @param verb   Be verbose when using asserts?
c**********************************************************************c
      subroutine ASSERT_INIT(verb)
      implicit none
      include 'primitive.inc'
      include 'assert.inc'
      logical*4 verb

      assertRec.verbose      = verb
      assertRec.num_tests    = 0
      assertRec.num_failed   = 0
      assertRec.res_name_len = 0
      assertRec.res_name     = ''
      
      end

c**********************************************************************c
      subroutine ASSERT_RESET()
      implicit none
      include 'primitive.inc'
      include 'assert.inc'

      assertRec.num_tests = 0
      assertRec.num_failed = 0
      end
      
c**********************************************************************c
c Calls ASSERT_INIT with verbose as directed by the named switch (with
c default value (if switch not present)
      subroutine ASSERT_AUTOINIT(verb,stat)
      implicit none
      include 'primitive.inc'
      include 'assert.inc'
      character*(*) verb
      character*(*) stat

      call assert_init(.false.)
      assertRec.res_name_len = M$GET_USWITCH(stat,assertRec.res_name)
      assertRec.verbose      = M$GET_SSWITCH_DEF(verb,1)
      end
      
c**********************************************************************c
c       Handles assertions.
c       @param msg    Description of the test.
c       @param status Indicates if the test passed (T) or failed (F).
      subroutine ASSERT(msg,status)
        implicit none
        include 'primitive.inc'
        include 'assert.inc'
        character*(*) msg
        logical*4     status
        integer*4     lmsg
        integer*4     lpad
        character*128 pad
        
        pad = '..................................................'
     &        //'............'
        lmsg = M$LENGTH(msg)
        lpad = M$LENGTH(pad)
        assertRec.num_tests = assertRec.num_tests + 1
        
        if (status) then
          if (assertRec.verbose) then
            call M$INFO('  '//msg(1:lmsg)//' '
     &                  //pad(1:lpad-lmsg)//' PASS')
          endif
        else
          assertRec.num_failed = assertRec.num_failed + 1
          if (assertRec.verbose) then
            call M$WARNING('  '//msg(1:lmsg)//' '
     &                     //pad(1:lpad-lmsg)//' FAIL <--')
          endif
        endif
      end

c**********************************************************************c
      FUNCTION ASSERT_getNumTests()
      implicit none
      include 'primitive.inc'
      include 'assert.inc'
      
      ASSERT_getNumTests = assertRec.num_tests
      end

c**********************************************************************c
      FUNCTION ASSERT_getNumFailed()
      implicit none
      include 'primitive.inc'
      include 'assert.inc'
      
      ASSERT_getNumFailed = assertRec.num_failed
      end

c**********************************************************************c
      subroutine assert_dump()
      implicit none
      include 'primitive.inc'
      include 'assert.inc'
      character*(L_max_ascii) tests
      character*(L_max_ascii) failed
      integer*4               ltests
      integer*4               lfailed
        
      ltests  = M$L2A(assert_getNumTests(),  tests)
      lfailed = M$L2A(assert_getNumFailed(), failed)

      call M$INFO('  Ran '//tests(1:ltests)//' Fortran '
     &          //' tests '//failed(1:lfailed)//' failed.')

      end

c**********************************************************************c
      subroutine assert_putStatus(res_name)
      implicit none
      include 'primitive.inc'
      include 'assert.inc'
      character*(*) res_name
      integer*4 stat

      if (assert_getNumFailed() .eq. 0) then
        stat = M$PUT_RESULT(res_name, 'PASS', 4, 0, 'A', 0)
      else
        stat = M$PUT_RESULT(res_name, 'FAIL', 4, 0, 'A', 0)
      endif
      end


c**********************************************************************c
c This is a convenience method similar to individually calling
c assert_dump() and assert_putStatus(res_name) but used along
c with assert_autoinit(..)
c
      subroutine assert_autoreport()
      implicit none
      include 'primitive.inc'
      include 'assert.inc'

      if (assertRec.verbose) then
        call assert_dump()
      endif
      if (assertRec.res_name_len .gt. 0) then
        call assert_putStatus(assertRec.res_name)
      endif
      end
