!
! Build notes:
! This code needs to be compiled with the /fpe:0 option enabled in both debug and
! release configurations.
! Also, in the release configuration, enable /traceback and optimize:none.
!
!/****************************************************************************
!
!        FUNCTION: CenterWindow (HWND, HWND)
!
!        PURPOSE:  Center one window over another
!
!        COMMENTS:
!
!        Dialog boxes take on the screen position that they were designed at,
!        which is not always appropriate. Centering the dialog over a particular
!        window usually results in a better position.
!
!****************************************************************************/

subroutine CenterWindow (hwndChild, hwndParent)
use dfwin
use gene_inc
integer         hwndChild, hwndParent
type (T_RECT)     rChild, rParent
integer         wChild, hChild, wParent, hParent
integer         wScreen, hScreen, xNew, yNew
integer         hdc
integer*4       retval

! Get the Height and Width of the child window
   retval = GetWindowRect (hwndChild, rChild)
   wChild = rChild.right - rChild.left
   hChild = rChild.bottom - rChild.top

! Get the Height and Width of the parent window
   retval = GetWindowRect (hwndParent, rParent)
   wParent = rParent.right - rParent.left
   hParent = rParent.bottom - rParent.top

! Get the display limits
   hdc = GetDC (hwndChild)
   wScreen = GetDeviceCaps (hdc, HORZRES)
   hScreen = GetDeviceCaps (hdc, VERTRES)
   retval = ReleaseDC (hwndChild, hdc)

! Calculate new X position, then adjust for screen
   xNew = rParent.left + ((wParent - wChild) /2)
   if (xNew .LT. 0) then
      xNew = 0
   else if ((xNew+wChild) .GT. wScreen) then
      xNew = wScreen - wChild
   end if

! Calculate new Y position, then adjust for screen
   yNew = rParent.top  + ((hParent - hChild) /2)
   if (yNew .LT. 0) then
      yNew = 0
   else if ((yNew+hChild) .GT. hScreen) then
      yNew = hScreen - hChild
   end if

! Set it, and return
   ret = SetWindowPos (hwndChild, NULL, xNew, yNew, 0, 0,            &
                  IOR(SWP_NOSIZE , SWP_NOZORDER))
end


!/****************************************************************************
!
!        FUNCTION: AboutDlgProc(HWND, UINT, WPARAM, LPARAM)
!
!        PURPOSE:  Processes messages for "About" dialog box
!
!        MESSAGES:
!
!        WM_INITDIALOG - initialize dialog box
!        WM_COMMAND    - Input received
!
!        COMMENTS:
!
!        Display version information from the version section of the
!        application resource.
!
!        Wait for user to click on "Ok" button, then close the dialog box.
!
!****************************************************************************/

integer*4 function AboutDlgProc( hDlg, message, uParam, lParam )
!DEC$ IF DEFINED(_X86_)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_AboutDlgProc@16' :: AboutDlgProc
!DEC$ ELSE
!DEC$ ATTRIBUTES STDCALL, ALIAS : 'AboutDlgProc' :: AboutDlgProc
!DEC$ ENDIF
use dfwin
use gene_inc

integer     hDlg        !// window handle of the dialog box
integer     message     !// type of message
integer     uParam      !// message-specific information
integer     lParam
integer*4   hfontDlg
save        hfontDlg

integer     dwVerHnd
integer     dwVerInfoSize
integer     uVersionLen
integer     bRetCode
integer     i
character*256   szFullPath
character*256   szResult
character*256   szGetName
character*256   lpversion

common      hinst
COMMON /globdata/ ghInstance
integer*4		    ghInstance

integer*4           lpstrVffInfo
integer*4           hMem
integer*4           ret
character*100       lpszTempBuffer

lparam = lparam
   select case (message)
      case (WM_INITDIALOG)   ! message: initialize dialog box
         ! Create a font to use
         lpszTempBuffer = ""C
         hfontDlg = CreateFont(14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,&
                        IOR(INT(VARIABLE_PITCH) , INT(FF_SWISS)), ""C)

         ! Center the dialog over the application window
         call CenterWindow (hDlg, GetWindow (hDlg, GW_OWNER))

         ! Get version information from the application
         ret = GetModuleFileName (INT(ghInstance), szFullPath,     &
                               len(szFullPath))
         dwVerInfoSize = GetFileVersionInfoSize(szFullPath,   &
                                       LOC(dwVerHnd))

         if (dwVerInfoSize .NE. 0) then
            ! If we were able to get the information, process it:
            hMem = GlobalAlloc(GMEM_MOVEABLE, INT(dwVerInfoSize))
            lpstrVffInfo  = GlobalLock(hMem)
            ret = GetFileVersionInfo (szFullPath, dwVerHnd, &
            dwVerInfoSize, lpstrVffInfo)

            ! Walk through the dialog items that we want to replace:
            do i = DLG_VERFIRST, DLG_VERLAST
               ret = GetDlgItemText(hDlg, i, szResult,      &
                             len(szResult))

               szGetName = "\\StringFileInfo\\040904E4\\"C
               ret =lstrcat(szGetName,szResult)

               bRetCode  =  VersionQueryValue(lpstrVffInfo,       &
                                            LOC(szGetName),       &
                                            LOC(lpVersion),       &
                                            LOC(uVersionLen)) ! For MIPS strictness

               if ( bRetCode .NE. 0 ) then
                    ! Replace dialog item text with version info
                  ret = lstrcpy(szResult,lpVersion)
                  retval = SetDlgItemText(hDlg, i,szResult)
                  retval = SendMessage (GetDlgItem (hDlg, i),   &
                                   WM_SETFONT, hfontDlg, TRUE)
               end if
            end do

            retval = GlobalUnlock(hMem)
            retval = GlobalFree(hMem)
         end if
         AboutDlgProc = 1
         return
      case (WM_COMMAND)                      ! message: received a command
         if ((LoWord(uParam) .EQ. IDOK) &       !OK Selected
            .OR. (LoWord(uParam) .EQ. IDCANCEL)) then  ! System menu close command?
            ret = EndDialog(hDlg, TRUE)        ! Exit the dialog
            ret = DeleteObject (hfontDlg)
            AboutDlgProc = 1
            return
         end if
   end select
   AboutDlgProc = 0 ! Didn't process the message
   return
end

!/****************************************************************************
!
!        FUNCTION: ERROR_SIMULATOR(TEST_SELECT)
!
!        PURPOSE:  Generate specific error conditions to exercise the exception
!                  and error handling mechanisms being demonstrated.
!
!        COMMENTS:
!
!        This routine unmasks floating point traps and does silly things to
!        cause errors to happen.  The idea is to simulate errors which might
!        occur in a more significant application code, and demonstrate a technique
!        for containing them.  Imagine that this routine is replaced with your
!        application code.
!
!****************************************************************************/

INTEGER(4) FUNCTION ERROR_SIMULATOR(TEST_SELECT)
	!DEC$ IF DEFINED(_X86_)
	!DEC$ ATTRIBUTES ALIAS : '_ERROR_SIMULATOR@4' :: ERROR_SIMULATOR
	!DEC$ ELSE
	!DEC$ ATTRIBUTES ALIAS : 'ERROR_SIMULATOR' :: ERROR_SIMULATOR
	!DEC$ ENDIF
	USE GENE_INC
	USE DFLIB
	INCLUDE 'IOSDEF.FOR'
	REAL(8) A, B, C
	INTEGER(4) TEST_SELECT
	INTEGER(4) STS, IA, IB, IC
!DEC$ IF DEFINED(_X86_)
	INTEGER(2) CTL,TRAP_ENABLES
!DEC$ ENDIF

	TYPE ITEM
			CHARACTER*80		:: STR
			INTEGER				:: VALUE
			TYPE(ITEM), POINTER :: NEXT_ITEM
	END TYPE ITEM
	TYPE (ITEM), POINTER :: LIST_PTR

!DEC$ IF DEFINED(_X86_)
	CALL GETCONTROLFPQQ(CTL)
	CTL = CTL .AND. (.NOT. FPCW$MCW_EM)
	TRAP_ENABLES = FPCW$MCW_EM .XOR. (FPCW$OVERFLOW .OR. FPCW$ZERODIVIDE .OR. FPCW$INVALID)
	CTL = CTL .OR. TRAP_ENABLES
	CALL SETCONTROLFPQQ(CTL)
!DEC$ ENDIF

	SELECT CASE ( TEST_SELECT )
		CASE (IDM_FLT_OVF)
			A = 1.0D300
			B = 2.0D-300
			C = A/B
			ERROR_SIMULATOR = 0
		CASE (IDM_FLT_INV)
			A = -1.0D0
			B = SQRT(A)
			ERROR_SIMULATOR = 0
		CASE (IDM_FLT_DVZ)
			A = 1.0D0
			B = 0.0D0
			C = A/B
			ERROR_SIMULATOR = 0
		CASE (IDM_INT_DVZ)
			IA = 1
			IB = 0
			IC = IA/IB
			ERROR_SIMULATOR = 0
		CASE (IDM_ACCVIO)
			! This should generate an access violation
			ALLOCATE(LIST_PTR)
			LIST_PTR => LIST_PTR%NEXT_ITEM
			LIST_PTR%VALUE = 4
			ERROR_SIMULATOR = 0
		CASE (IDM_BAD_OPN)
			OPEN(10,FILE='NONEXISTENT_FILE.DAT',STATUS='OLD',IOSTAT=STS)
			IF (STS .EQ. FOR$IOS_FILNOTFOU) THEN
				CALL TRACEBACKQQ(STRING='Error Simulator:  attempted OPEN of nonexistent file.', &
							USER_EXIT_CODE=-1)
			ELSEIF (STS .NE. FOR$IOS_SUCCESS) THEN
				CALL TRACEBACKQQ(STRING='Error Simulator:  unexpected file OPEN error.', &
							USER_EXIT_CODE=-1)
			END IF
			ERROR_SIMULATOR = STS
		CASE DEFAULT
			ERROR_SIMULATOR = 0
	END SELECT

	RETURN

	END FUNCTION

!/****************************************************************************
!
!        FUNCTION: CHECK_EXCEPTION_INFO ( ExceptionInfo )
!
!        PURPOSE:  Exception filter function
!
!        COMMENTS:
!
!        This function will determine what the exception was, clear the hardware
!        floating point status in the case of a floating point exception, and
!        produce a traceback report with a specific error message.  If the exception
!        was one expected to be handled here, EXCEPTION_EXECUTE_HANDLER is returned.
!        Otherwise, EXCEPTION_CONTINUE_SEARCH is returned.
!
!****************************************************************************/

	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
!DEC$ IF DEFINED(_X86_)
		CALL CLEARSTATUSFPQQ()
!DEC$ ENDIF
		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_OVERFLOW ) THEN
!DEC$ IF DEFINED(_X86_)
		CALL CLEARSTATUSFPQQ()
!DEC$ ENDIF
		CALL TRACEBACKQQ(STRING='Handler:  Saw floating overflow.', &
							USER_EXIT_CODE=-1, &
							EPTR=%LOC(ExceptionInfo))
		CHECK_EXCEPTION_INFO = EXCEPTION_EXECUTE_HANDLER
	ELSEIF ( ERECPTR.ExceptionCode .EQ. STATUS_FLOAT_INVALID_OPERATION ) THEN
!DEC$ IF DEFINED(_X86_)
		CALL CLEARSTATUSFPQQ()
!DEC$ ENDIF
		CALL TRACEBACKQQ(STRING='Handler:  Saw floating invalid operation.', &
							USER_EXIT_CODE=-1, &
							EPTR=%LOC(ExceptionInfo))
		CHECK_EXCEPTION_INFO = EXCEPTION_EXECUTE_HANDLER
	ELSEIF ( ERECPTR.ExceptionCode .EQ. STATUS_ACCESS_VIOLATION ) THEN
		CALL TRACEBACKQQ(STRING='Handler:  Saw access violation.', &
							USER_EXIT_CODE=-1, &
							EPTR=%LOC(ExceptionInfo))
		CHECK_EXCEPTION_INFO = EXCEPTION_EXECUTE_HANDLER
	ELSEIF ( ERECPTR.ExceptionCode .EQ. STATUS_INTEGER_DIVIDE_BY_ZERO ) THEN
		CALL TRACEBACKQQ(STRING='Handler:  Saw integer divide by zero.', &
							USER_EXIT_CODE=-1, &
							EPTR=%LOC(ExceptionInfo))
		CHECK_EXCEPTION_INFO = EXCEPTION_EXECUTE_HANDLER
	ELSE
		PRINT *, 'Saw other than expected exception.'
		CHECK_EXCEPTION_INFO = EXCEPTION_CONTINUE_SEARCH
	END IF

	END
