!
! To build the Intel debug configuration from the command line,
!
! First build the dll:
!
! df /check:bounds /compile_only /debug:full /fpe:0 /dll /nologo /traceback
!    /warn:argument_checking /warn:nofileopt geteptrs_s2.f90
! 
! link kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib
!      shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib
!      /nologo /subsystem:windows /dll /incremental:no /pdb:geteptrs_dll.pdb
!      /debug /machine:I386 /out:geteptrs_dll.dll /implib:geteptrs_dll.lib
!      /pdbtype:sept geteptrs_s2.obj
!
! Then build the main program:
!
! cl /nologo /MD /W3 /Gm /GX /ZI /Od
!    /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /D "_X86_" 
!    /YX /FD /GZ /c geteptrs_main.c
!
! link geteptrs_dll.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib
!      advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib
!      odbccp32.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib
!      advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib
!      /nologo /subsystem:console /incremental:no /pdb:geteptrs_main.pdb /debug
!      /machine:I386 /out:geteptrs_main.exe /pdbtype:sept geteptrs_main.obj
!
! GETEPTRS_S2.F90 
! This Fortran DLL project demonstrates the use of GETEXCEPTIONPTRSQQ()
! in a user handler which was established with SIGNALQQ() or signal().
!
! Objectives:
!
!   - Show how to use the result to get a traceback with TRACEBACKQQ().
!
!   - Show how to use the result to access the exception context record.
!
! On Intel, in the dll project, set the Fortran Floating Point option
! to 0 (/fpe:0) so the test will generate a floating divide by zero trap.
! This is the default on Alpha platforms.
!
! The workspace includes a WIN32 console application, geteptrs_main.c,
! written in C, that unmasks floating divide by zero traps (on Intel)
! and calls the DLL SET_HANDLER() function to establish hand_fpe() as
! a SIGFPE handler.  It then calls into the DLL code to generate the
! exception.  Note that the handler could just as well have been established
! in the C code with a call to signal() directly.

!!!!!!!!!!!!!!!!!!!!!!!!
!                      !
! Function SET_HANDLER !
!                      !
!!!!!!!!!!!!!!!!!!!!!!!!

  INTEGER(4) FUNCTION SET_HANDLER()
  !DEC$ ATTRIBUTES DLLEXPORT::SET_HANDLER

  USE DFLIB

  INTERFACE   
     FUNCTION  HAND_FPE (SIGID, EXCEPT)
        !DEC$ ATTRIBUTES C :: HAND_FPE
        INTEGER(4) HAND_FPE
        INTEGER(2)  SIGID, EXCEPT
     END FUNCTION
  END INTERFACE

  INTEGER(4)  IRET

  IRET = SIGNALQQ(SIG$FPE, HAND_FPE)
  SET_HANDLER = IRET

  END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!
!                      !
! Function GETEPTRS_S2 !
!                      !
!!!!!!!!!!!!!!!!!!!!!!!!

  REAL(4) FUNCTION GETEPTRS_S2(R1)
  !DEC$ ATTRIBUTES DLLEXPORT::GETEPTRS_S2
  REAL(4) R1

  INTERFACE   
     REAL(4) FUNCTION BING(X)
		REAL(4) X
     END FUNCTION
  END INTERFACE

  ! Cause divide by zero exception if R1 is 0.0
  GETEPTRS_S2 = BING(R1)

  END FUNCTION

!!!!!!!!!!!!!!!!!
!               !
! Function BING !
!               !
!!!!!!!!!!!!!!!!!

  REAL(4) FUNCTION BING(X)
  !DEC$ ATTRIBUTES DLLEXPORT::BING
  REAL(4) X

  INTERFACE   
     REAL(4) FUNCTION BANG(X)
		REAL(4) X
     END FUNCTION
  END INTERFACE

  BING = BANG(X)

  END FUNCTION

!!!!!!!!!!!!!!!!!
!               !
! Function BANG !
!               !
!!!!!!!!!!!!!!!!!

  REAL(4) FUNCTION BANG(X)
  !DEC$ ATTRIBUTES DLLEXPORT::BANG
  REAL(4) X

  INTERFACE   
     REAL(4) FUNCTION BONG(X)
        REAL(4) X
     END FUNCTION
  END INTERFACE

  BANG = BONG(X)

  END FUNCTION

!!!!!!!!!!!!!!!!!
!               !
! Function BONG !
!               !
!!!!!!!!!!!!!!!!!

  REAL(4) FUNCTION BONG(X)
  !DEC$ ATTRIBUTES DLLEXPORT::BONG
  REAL(4) X

  BONG = 3.0E0/X

  END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                    !
! Exception handler routine HAND_FPE !
!                                    !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  INTEGER(4) FUNCTION HAND_FPE (SIGNUM, EXCNUM)
  !DEC$ ATTRIBUTES C :: HAND_FPE
  !DEC$ ATTRIBUTES DLLEXPORT::HAND_FPE

  USE DFLIB
  USE DFWINTY

  INTEGER(2)  SIGNUM, EXCNUM
!DEC$ IF DEFINED(_X86_)
  INTEGER(2)  FPCW, FPSW, FPTW
!DEC$ ENDIF
  INTEGER(4)  EPTRS
  TYPE(T_EXCEPTION_POINTERS) EPTS
  TYPE(T_CONTEXT) CTX
  POINTER(EPT,EPTS)
  POINTER(CTXP,CTX)

  EPTRS = GETEXCEPTIONPTRSQQ()
  EPT = EPTRS
  CTXP = EPTS.ContextRecord

  SELECT CASE(EXCNUM)
     CASE( FPE$ZERODIVIDE )
        CALL TRACEBACKQQ("Floating Divide-By-Zero!",USER_EXIT_CODE=-1,EPTR=EPTRS)
!DEC$ IF DEFINED(_X86_)
		WRITE(6,*) ''
		WRITE(6,*) 'Selected fields from the exception context record:'
		WRITE(6,*) ''
		FPCW = CTX.FloatSave.ControlWord .AND. 16#0000FFFF
		FPSW = CTX.FloatSave.StatusWord .AND. 16#0000FFFF
		FPTW = CTX.FloatSave.TagWord .AND. 16#0000FFFF
		WRITE(6,'(1X,A,Z4.4)') 'FPCW at exception:  ',FPCW
		WRITE(6,'(1X,A,Z4.4)') 'FPSW at exception:  ',FPSW
		WRITE(6,'(1X,A,Z4.4)') 'FP tag word at exception:  ',FPTW
		WRITE(6,*) ''
!DEC$ ELSEIF DEFINED(_ALPHA_)
		WRITE(6,*) ''
		WRITE(6,*) 'Selected fields from the exception context record:'
		WRITE(6,*) ''
		WRITE(6,'(1X,A,Z16.16)') 'Fpcr at exception:  ',CTX.FPCR
		WRITE(6,'(1X,A,Z16.16)') 'SoftFpcr at exception:  ',CTX.SOFTFPCR
		WRITE(6,'(1X,A,Z16.16)') 'Fir at exception:  ',CTX.FIR
		WRITE(6,*) ''
!DEC$ ENDIF
       STOP 'Floating point exception: Zero divide - aborting'
     CASE DEFAULT
        STOP 'Floating point exception other than Divide-By-Zero - aborting'
  END SELECT

  HAND_FPE = 1

  END