json_throw_exception Subroutine

private subroutine json_throw_exception(json, msg, found)

Throw an exception in the json_core. This routine sets the error flag, and prevents any subsequent routine from doing anything, until json_clear_exceptions is called.

Arguments

Type IntentOptional AttributesName
class(json_core), intent(inout) :: json
character(kind=CK,len=*), intent(in) :: msg

the error message

logical(kind=LK), intent(inout), optional :: found

if the caller is handling the exception with an optimal return argument. If so, json%stop_on_error is ignored.


Contents

Source Code


Source Code

    subroutine json_throw_exception(json,msg,found)

#ifdef __INTEL_COMPILER
    use ifcore, only: tracebackqq
#endif

    implicit none

    class(json_core),intent(inout)      :: json
    character(kind=CK,len=*),intent(in) :: msg    !! the error message
    logical(LK),intent(inout),optional  :: found  !! if the caller is handling the
                                                  !! exception with an optimal return
                                                  !! argument. If so, `json%stop_on_error`
                                                  !! is ignored.

    logical(LK) :: stop_on_error

    json%exception_thrown = .true.
    json%err_message = trim(msg)
    stop_on_error = json%stop_on_error .and. .not. present(found)

    if (stop_on_error) then

#ifdef __INTEL_COMPILER
        ! for Intel, we raise a traceback and quit
        call tracebackqq(string=trim(msg), user_exit_code=0)
#else
        write(error_unit,'(A)') 'JSON-Fortran Exception: '//trim(msg)
        error stop 1
#endif

    elseif (json%is_verbose) then

        write(output_unit,'(A)') '***********************'
        write(output_unit,'(A)') 'JSON-Fortran Exception: '//trim(msg)

!#if defined __GFORTRAN__
!        call backtrace()  ! (have to compile with -fbacktrace -fall-intrinsics flags)
!#endif

#ifdef __INTEL_COMPILER
        call tracebackqq(user_exit_code=-1)  ! print a traceback and return
#endif

        write(output_unit,'(A)') '***********************'

    end if

    end subroutine json_throw_exception