! This console application sample shows how to wrap a Fortran entry point inside
! a C try/except block to allow the user to test for exceptions that might occur
! in the protected Fortran code.  It demonstrates how to set up the wrapper routine
! and, on X86 platforms, the interactions between the users exception handling code
! and the Fortran rtl default handler.
!
! Compile this program with fpe:0 selected to enable trapping on floating point
! divide by zero.  From the command line, use
! CL /c wrapper.c
! DF /fpe:0 /noopt /traceback cslexcp4.f90 wrapper.obj
!
! For this example, we assume the user has a code path that, for one reason or another,
! it is desired to check for floating point divide by zero exceptions and take some
! user defined action.  The program could just as well have checked for access violations,
! integer divide by zero, program stack overflow, etc., any exception condition the user
! is interested in.
!
! The main program consists of a DO loop which calls a C routine, DIVIDE_WRAPPER,
! passing it two REAL(8) arguments, A and B, and getting back a status indicating
! if A/B produced an error or not.  DIVIDE_WRAPPER is simply a wrapper around the
! DIVIDE routine which is the Fortran code we want to protect.
!
! The first time through the DO loop, arguments are selected so that no exceptions occur.
! The second line in the try block sets the return status to ALL_IS_WELL, the except
! expression is never evaluated since there is no exception, and DIVIDE_WRAPPER returns
! a 0 to the main program.
!
! The second time through the loop, arguments are selected that generate a floating
! point underflow.  When the underflow trap occurs, the operating system evaluates
! the except expression which in this case means a call to our CHECK_EXCEPTION_INFO
! function.  The argument to CHECK_EXCEPTION_INFO is the return value from
! GetExceptionInformation().  When a trap occurs, the operating system builds 2 data
! structures on the stack that contain the pertinent information about the exception.
! The first data structure is the ExceptionRecord and the second is the ContextRecord.
! GetExceptionInformation() returns a pointer to a data structure, T_EXCEPTION_POINTERS,
! which has 2 members which are pointers to the ExceptionRecord and the ContextRecord.
! CHECK_EXCEPTION_INFO uses the exception code from the ExceptionRecord to determine
! what happened, in this case, an underflow exception.  We want to let the Fortran rtl
! default handler fix up the underflow to 0.0 so our handler will eventually return the
! code EXCEPTION_CONTINUE_SEARCH.  This tells the operating system to go look for
! another handler to service the condition.  But before we return, we'll call TRACEBACKQQ
! so we can see where we were when the underflow occured (and to leave some evidence in
! the program output that we came through this code path).  Since we return
! EXCEPTION_CONTINUE_SEARCH, the code inside the except block (which is refered to as the
! handler in C terminology) does not get executed.  The operating system will continue to
! walk up the chain of exception handlers and find the Fortran rtl handler.  This handler
! will fix up the underflow and return EXCEPTION_CONTINUE_EXECUTION in it's except filter
! function.  This will return execution back to the DIVIDE routine and the operation will
! complete normally.  We'll return to the try block in wrapper.c, set the return status
! to ALL_IS_WELL and return back to the DO loop.
!
! The third time through the loop, arguments are selected that generate a floating
! point divide by zero.  Again, when the trap occurs, the operating system evaluates
! the except expression which again means a call to our CHECK_EXCEPTION_INFO
! function.  This time CHECK_EXCEPTION_INFO examines the exception code from the
! ExceptionRecord and determines a divide by zero exception occured.  We will handle
! this exception by calling TRACEBACKQQ again with the 'We got one' message.  But now
! CHECK_EXCEPTION_INFO will return the code EXCEPTION_EXECUTE_HANDLER.  When the
! operating system sees EXCEPTION_EXECUTE_HANDLER, it will execute the except block in
! wrapper.c (remember, this is the code C refers to as the handler).  The code in the
! except block sets the return status to SAW_DIVIDE_BY_ZERO and execution returns again
! to the DO loop which then executes a STOP statement with the divide by zero message.
!
! On Alpha, you will not see the underflow trap on the second trip through the loop
! because the Alpha hardware automatically sets underflows to 0.0 under fpe:0.  There is
! no trap for that iteration of the loop.
!
! Note that this example just shows a single try-except block (not counting the one
! in the Fortran rtl's main routine).  You can nest try-except blocks if you need to.
! You can also make use of try-finally blocks to do clean up during unwinding if needed.
! A good reference on the subject of structured exception handling (SEH) is the book
! "Advanced Windows", Microsoft Press, by Jeffrey Richter.  It has a chapter on SEH that
! explains how to use exception handlers, termination handlers, exception unwinding, etc.
!
	PROGRAM CSLEXCP4

	INTERFACE
		INTEGER(4) FUNCTION DIVIDE_WRAPPER(A,B)
		!DEC$ IF DEFINED(_X86_)
		!DEC$ATTRIBUTES C, ALIAS:'_DIVIDE_WRAPPER' :: DIVIDE_WRAPPER
		!DEC$ ELSE
		!DEC$ATTRIBUTES C, ALIAS:'DIVIDE_WRAPPER' :: DIVIDE_WRAPPER
		!DEC$ ENDIF
		!DEC$ ATTRIBUTES REFERENCE :: A,B
		REAL(8) A,B
		END FUNCTION
	END INTERFACE

	REAL(8) A(3),B(3)
	INTEGER(4) I,STS

	DATA A /3*1.0D-300/
	DATA B /1.0D-300,1.0D15,0.0D0/

	DO I=1,3
		STS = DIVIDE_WRAPPER(A(I),B(I))
		IF (STS .EQ. 0) THEN
			PRINT *,'ALL IS WELL.'
		ELSEIF (STS .EQ. -1) THEN
			STOP 'STOP FOR DIVIDE BY ZERO EXCEPTION.'
		ELSE
			STOP 'SAW AN UNEXPECTED ERROR.'
		ENDIF
	END DO

	END

	SUBROUTINE DIVIDE(A,B)
	REAL(8) A,B,C

	C = A/B
	PRINT '(1X,A,1E15.7E3)','C = ',C

	RETURN

	END

	INTEGER(4) FUNCTION CHECK_EXCEPTION_INFO ( ExceptionInfo )
	USE DFLIB
	USE DFWINTY
	USE DFWIN
	!DEC$ ATTRIBUTES REFERENCE :: ExceptionInfo
	TYPE(T_EXCEPTION_POINTERS) ExceptionInfo

	TYPE(T_EXCEPTION_RECORD) ERECPTR
	TYPE(T_CONTEXT) CTXPTR

	POINTER(EPTR,ERECPTR)
	POINTER(CTXP,CTXPTR)

	LOGICAL(4) STS

	EPTR = ExceptionInfo.ExceptionRecord
	CTXP = ExceptionInfo.ContextRecord

	IF ( ERECPTR.ExceptionCode .EQ. STATUS_FLOAT_DIVIDE_BY_ZERO ) THEN
		CALL TRACEBACKQQ(STRING='Handler:  Saw floating divide by zero.', &
							USER_EXIT_CODE=-1, &
							EPTR=%LOC(ExceptionInfo))
		CHECK_EXCEPTION_INFO = EXCEPTION_EXECUTE_HANDLER
	ELSEIF ( ERECPTR.ExceptionCode .EQ. STATUS_FLOAT_UNDERFLOW ) THEN
		CALL TRACEBACKQQ(STRING='Handler:  Saw floating underflow, let default handler deal with it on x86.', &
							USER_EXIT_CODE=-1, &
							EPTR=%LOC(ExceptionInfo))
		CHECK_EXCEPTION_INFO = EXCEPTION_CONTINUE_SEARCH
	ELSE
		PRINT *, 'Saw other than expected exception.'
		CHECK_EXCEPTION_INFO = EXCEPTION_CONTINUE_SEARCH
	END IF

	END
