
! This console application sample shows how to wrap a Fortran entry point inside
! a C try/except and try/finally 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 for both exception and termination handling.
!
! Compile this program with fpe:0 selected to enable trapping on floating point
! divide by zero.  The code does not use floating point division but the Programmer's Guide
! material that describes this sample wants it on to help make a point.  
!
! From the command line, use
! CL /c wrapper.c
! DF /fpe:0 /noopt /traceback cslexcp2.f90 wrapper.obj
!
! This sample is described in detail in the Visual Fortran Programmer's Guide in the
! Advanced Exception and Termination Handling Considerations chapter.
!
	PROGRAM CSLEXCP2

	INTERFACE
		SUBROUTINE MY_CODE_WRAPPER()
		!DEC$ IF DEFINED(_X86_)
		!DEC$ATTRIBUTES C, ALIAS:'_MY_CODE_WRAPPER' :: MY_CODE_WRAPPER
		!DEC$ ELSE
		!DEC$ATTRIBUTES C, ALIAS:'MY_CODE_WRAPPER' :: MY_CODE_WRAPPER
		!DEC$ ENDIF
		END SUBROUTINE
	END INTERFACE

	CALL MY_CODE_WRAPPER()

	END

	SUBROUTINE MY_CODE()

	INTEGER(4) I,J,K

	OPEN(10,FILE='CSLEXCP2.DAT',STATUS='UNKNOWN',FORM='FORMATTED')
	WRITE (*, *) 'Enter values for I and J when prompted.'
	PRINT *
	WRITE (*, *) 'This program will calculate K=I/J, then prompt for more I, J values'
	PRINT *
	WRITE (*, *) 'Each value of K will be stored in a temporary data file CSLEXCP2.DAT.'
	WRITE (*, *) '  The program will ask if you want to delete this file at the end of the run.'
	PRINT *
	WRITE (*, *) 'If J is 0, you will invoke the error handling routine.'
	PRINT *
	WRITE (*, *) 'When I is 99, the program will exit.'

	DO WHILE (I .NE. 99 )
		PRINT *
		PRINT *, 'I?'
		ACCEPT *,I
		PRINT *, 'J?'
		ACCEPT *,J
		K = I/J
		PRINT *,'K = I/J = ',K
		WRITE(10,'(1X,A,I10)') 'K = ',K
	END DO

	RETURN

	END

	INTEGER(4) FUNCTION MY_EXCEPTION_FILTER_CODE ()
	USE DFWINTY
	CHARACTER(1) REPLY

	! In here, do whatever work you need to do in the face of an
	! unexpected exception.

	PRINT *, 'Hello from MY_EXCEPTION_FILTER_CODE'
	PRINT *,'Do you want to delete the file CSLEXCP2.DAT (Y for yes)?'
	ACCEPT *, REPLY
	IF (REPLY .EQ. 'Y') THEN
		CLOSE(10,DISPOSE='DELETE')
	ELSE
		CLOSE(10,DISPOSE='KEEP')
	END IF

	PRINT *,'Enter A to exercise the termination handler code path,'
	PRINT *,'...or B to pass the exception to the default handler.'
	ACCEPT *,REPLY

	IF (REPLY .EQ. 'A') THEN
		MY_EXCEPTION_FILTER_CODE = EXCEPTION_EXECUTE_HANDLER
	ELSE
		MY_EXCEPTION_FILTER_CODE = EXCEPTION_CONTINUE_SEARCH
	END IF

	RETURN

	END FUNCTION

	SUBROUTINE MY_TERMINATION_HANDLER_CODE()

	! In here, do whatever general work you want to gracefully shutdown
	! the application.  This code gets executed whether an exception
	! occured or not (assuming MY_EXCEPTION_FILTER_CODE does not return
	! EXCEPTION_CONTINUE_SEARCH).

	PRINT *, 'GoodBye from MY_TERMINATION_HANDLER_CODE'
	CALL EXIT(1)

	RETURN

	END
