ESTABLISHQQ

Module

USE IFESTABLISH

result = ESTABLISHQQ (handler_routine,context,prev_handler,prev_context)

Results

The result type for ESTABLISHQQ is LOGICAL(4). It indicates whether the handler was successfully established. .TRUE. means it was established successfully; .FALSE. means it was not.

The handler routine is called when an error occurs. The result for the handler is set by your code in the handler. .TRUE. means that the error has been handled and the application should not issue an error message. .FALSE. means that the application should issue an error message and continue as if there had never been a handler.

After you specify ESTABLISHQQ and an error occurs, the following input arguments are set up by the RTL when it calls the handler routine:

If you want to handle errors using a C/C++ handler, use the ISO_C_BINDINGS module features to call the C/C++ routine.

Example

! Compile with "-fpe0 -check bounds".
!
program example
use ifestablish
implicit none
    
     procedure(establishqq_handler), pointer :: old_handler_1
     procedure(establishqq_handler), pointer :: old_handler_2
     procedure(establishqq_handler), pointer :: old_handler_3
     procedure(establishqq_handler)          :: my_handler_1
     procedure(establishqq_handler)          :: my_handler_2
     procedure(establishqq_handler)          :: my_handler_3
  
     logical                 :: ret
     integer(INT_PTR_KIND()) :: old_context, my_context = 0
     real,    volatile       :: x,y,z
     integer, volatile       :: i, eleven, a(10)

     my_context = 1
     eleven = 11

     ! Test that handlers can be established and restored.
     !
     old_handler_1 => null()
     print *, "== Establish first handler"
     ret = ESTABLISHQQ(my_handler_1, my_context, old_handler_1, old_context)

     if (associated(old_handler_1)) then
         print *, "** Unexpected old handler on first ESTABLISH **"
         ret =  old_handler_1(100, .true., "call number one", 1 )
         print *, "back from call of old handler with", ret
     else
         print *,"== Got expected NULL old handler"
     end if

     print *,"== Violate array bounds; expect first handler"
     i = a(eleven)

     ! Establish second handler
     !
     old_handler_2 => null()
     print *, "== Establish second handler"
     ret = ESTABLISHQQ(my_handler_2, my_context, old_handler_2, old_context)

     if (associated(old_handler_2)) then
         print *, "== Expect first handler as old handler"
         ret =  old_handler_2(100, .true., "call number one", 1 )
     else
         print *,"** Unexpectedly didn't get first handler as old handler **"
     end if

     print *,"== Violate array bounds; expect second handler"
     i = a(eleven)

     ! Establish third handler
     !
     old_handler_3 => null()
     print *, "== Establish third handler"
     ret = ESTABLISHQQ(my_handler_3, my_context, old_handler_3, old_context)
     !print *, "Got return value ", ret, "old context", old_context

     if (associated(old_handler_3)) then
         print *, "== Expect second handler as old handler"
         ret =  old_handler_3(100, .true., "call number one", 1 )
         !print *, "back from call of old handler with", ret

     else
         print *,"** Unexpectedly didn't get second handler as old handler **"
     end if

     print *,"== Violate array bounds; expect third handler"
     i = a(eleven)

     ! Put back old handlers in stack-wise order, testing.
     !
    ret = ESTABLISHQQ(old_handler_3, old_context)
     print *,"== Violate array bounds; expect second handler"
     i = a(eleven)

     ret = ESTABLISHQQ(old_handler_2, old_context)
     print *,"== Violate array bounds; expect first handler"
     i = a(eleven)

     ret = ESTABLISHQQ(old_handler_1, old_context)
     print *,"== Violate array bounds; expect no handler and exit"
     i = a(eleven)
end

function my_handler_1 (error_code, continuable, message_string, context)
     use, intrinsic :: iso_c_binding
     implicit none
     logical :: my_handler_1

     ! Arguments
     !
     integer, intent(in) :: error_code               ! RTL error code from IOSTAT table
     logical, intent(in) :: continuable              ! True if condition is continuable
     character(*), intent(in) :: message_string      ! Formatted message string a la ERRMSG/IOMSG
     integer(INT_PTR_KIND()), intent(in) :: context    ! Address-sized integer passed in to call 
                                                       ! ESTABLISHQQ, for whatever purpose
                                                       ! the programmer desires
                                                                               
     my_handler_1 = .TRUE. ! Continue by default

     if (context == 1) then
         print *, "    Handler 1, continue"

     else if (context == 2) then
         print *, "    Handler 1, continue"

     else if (context == 3) then
         print *, "    Handler 1, code should be 73: ", error_code
         if (continuable) then
             print *,"        - is continuable (** an error! **)"
         else
             print *,"        - not continuable"
  end if
         ! We will return .TRUE., asking to continue, but because this is not
         ! a continuable error, the application will exit.

      else
         print *, "    ** Error -- wrong context value"
      end if

      return

end function my_handler_1

function my_handler_2 (error_code, continuable, message_string, context)
     use, intrinsic :: iso_c_binding
     implicit none
     logical :: my_handler_2

     ! Arguments
     !
     integer, intent(in) :: error_code             ! RTL error code from IOSTAT table
     logical, intent(in) :: continuable            ! True if condition is continuable
     character(*), intent(in) :: message_string    ! Formatted message string a la ERRMSG/IOMSG
     integer(INT_PTR_KIND()), intent(in) :: context    ! Address-sized integer passed in to call 
                                                       ! ESTABLISHQQ, for whatever purpose
                                                       ! the programmer desires
     if (context == 1) then
         print *,"    Handler 2, continue"
         my_handler_2 = .TRUE. ! Continue

     else if (context == 2) then
         print *, "    Handler 2, exit"
         my_handler_2 = .FALSE. ! Exit
     end if

     return
end function my_handler_2

function my_handler_3 (error_code, continuable, message_string, context)
     use, intrinsic :: iso_c_binding
     implicit none

     ! Arguments
     !
     logical :: my_handler_3
     integer, intent(in) :: error_code             ! RTL error code from IOSTAT table
     logical, intent(in) :: continuable            ! True if condition is continuable
     character(*), intent(in) :: message_string    ! Formatted message string a la ERRMSG/IOMSG
     integer(INT_PTR_KIND()), intent(in) :: context    ! Address-sized integer passed in to call 
                                                       ! ESTABLISHQQ, for whatever purpose
                                                       ! the programmer desires     
     if (context == 1) then
         print *,"    Handler 3, continue"
     else if (context == 2) then
         print *, "    Handler 3, error is ", error_code, message_string
     end if

     my_handler_3 = .TRUE. ! Continue
     return

end function my_handler_3