fortran66のブログ

fortran について書きます。

Fortran2003 での C 呼び出し規約と、Win32 での呼び出し規約が、異なっているようなので、以下の内容は間違っているかもしれません。名称の規約しか合っていない可能性があります。

MODULE m_sub
USE ifwin
CONTAINS
INTEGER (LRESULT) FUNCTION MainWndProc( hWnd, mesg, wParam, lParam ) BIND(C, NAME = 'MainWndProc')
IMPLICIT NONE
INTEGER (HANDLE) , VALUE, INTENT(IN) :: hWnd
INTEGER (UINT)   , VALUE, INTENT(IN) :: mesg
INTEGER (fwParam), VALUE, INTENT(IN) :: wParam
INTEGER (flParam), VALUE, INTENT(IN) :: lParam
MainWndProc = 0
SELECT CASE ( mesg )
   CASE (WM_CREATE)
     WRITE(*, *) 'Window : Created !'     
   CASE (WM_DESTROY)
     WRITE(*, *) 'Window : Closed  !'
     CALL PostQuitMessage( 0 )
   CASE (WM_LBUTTONDOWN)
     WRITE(*, *) 'LBUTTONDOWN'
   CASE (WM_RBUTTONDOWN)
     WRITE(*, *) 'RBUTTONDOWN'
   CASE DEFAULT
     MainWndProc = DefWindowProc( hWnd, mesg, wParam, lParam )
END SELECT 
RETURN
END FUNCTION MainWndProc
END MODULE m_sub
!=================================================================
PROGRAM doswin
USE m_sub
IMPLICIT NONE
! Variables
INTEGER (SINT)    :: nCmdShow = SW_SHOWNORMAL
TYPE (T_WNDCLASS) :: wc 
TYPE (T_MSG)      :: mesg
INTEGER (HANDLE)  :: hWndMain
INTEGER (BOOL)    :: iretb
CHARACTER (LEN = 256) :: ClassName  = "Fortran"C
!  Init   Main window
wc%lpszClassName = LOC(ClassName)
wc%lpfnWndProc   = LOC(MainWndProc) ! CALLBACK procedure name
wc%style         = IOR(CS_VREDRAW , CS_HREDRAW)
wc%hInstance     = GetModuleHandle(NULL)
wc%hIcon         = NULL   
wc%hCursor       = LoadCursor( NULL, IDC_ARROW )
wc%hbrBackground = ( COLOR_WINDOW + 1 )
IF (RegisterClass(wc) == 0) STOP ' cannot register ! '
!Init instance
hWndMain = CreateWindowEx(  0, ClassName,              &
                     "FORTRAN DOS Window"C,            &
                     INT(WS_OVERLAPPEDWINDOW),         &
                     CW_USEDEFAULT, CW_USEDEFAULT,     &
                     CW_USEDEFAULT, CW_USEDEFAULT,     &
                     0,                                &
                     0,                                &
                  NULL,                                &
                  NULL                                 )
IF (hWndMain == 0) STOP ' cannot create ! '
iretb = ShowWindow( hWndMain, nCmdShow )
iretb = UpdateWindow( hWndMain )
! Message Loop : Main Loop
DO WHILE ( GetMessage (mesg, NULL, 0, 0) ) 
 iretb = TranslateMessage( mesg )
 iretb = DispatchMessage( mesg )
END DO
iretb = mesg%wParam
STOP
END PROGRAM doswin