fortran66のブログ

fortran について書きます。

Fortran での C ルーチン呼び出し規約と Win32 での呼び出し規約が異なっているようで、問題が生じる可能性があるようです。

Window 表示のミニマル。
Fortran2003 の C との互換命令を用いて、!DECのコンパイラ拡張を使用しない書き方。
参照 http://d.hatena.ne.jp/fortran66/20080318

LOC() 関数は規格外だが、使わざるおえない。C_LOC は型が異なっているため、インターフェースを書き直さないとうまく行きません。

追記:C言語形式の文字列もDEC拡張の'....'C 接尾語を用いずに、'...'//ACHR(0) に直すことでFortran2003 規格にのっとって実現できます。

窓を開く時と窓を閉じる時に文字列表示。Window 上で右・左クリックで文字列表示。

窓を閉じる。


MODULE win
USE ifwinty
IMPLICIT NONE
CONTAINS
!-----------------------------------------------------
INTEGER (KIND = 4) FUNCTION WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow)
USE user32
USE ifwinty
IMPLICIT NONE
INTEGER (HANDLE), INTENT(IN) :: hInstance, hPrevInstance
INTEGER (LPSTR) , INTENT(IN) :: lpszCmdLine
INTEGER (SINT)  , INTENT(IN) :: nCmdShow

! Variables
TYPE (T_WNDCLASS) :: wc
TYPE (T_MSG)      :: mesg
INTEGER (HANDLE)  :: hWndMain
INTEGER (BOOL)    :: iretb
CHARACTER (LEN = 256) :: ClassName

ClassName = "Fortran"//ACHAR(0) 
!  Init   Main window
WinMain = -1 ! Error code
wc%lpszClassName = LOC(ClassName)
wc%lpfnWndProc   = LOC(MainWndProc)               ! CALLBACK procedure name
wc%style         = IOR(CS_VREDRAW , CS_HREDRAW)
wc%hInstance     = hInstance
wc%hIcon         = NULL
wc%hCursor       = LoadCursor( NULL, IDC_ARROW )
wc%hbrBackground = ( COLOR_WINDOW + 1 )
IF (RegisterClass(wc) == 0) RETURN

!Init instance
WinMain = -2 ! Error code
hWndMain = CreateWindowEx(  0, ClassName,             &
                    "FORTRAN DOS Window"//ACHAR(0) ,            &
                    INT(WS_OVERLAPPEDWINDOW),         &
                    CW_USEDEFAULT, CW_USEDEFAULT,     &
                    CW_USEDEFAULT, CW_USEDEFAULT,     &
                    0,                                &
                    0,                                &
                 NULL,                                &
                 NULL                                 )
IF (hWndMain == 0) RETURN
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

WinMain = mesg%wParam
RETURN
END FUNCTION WinMain
!----------------------------------------------------------
INTEGER (LRESULT) FUNCTION MainWndProc( hWnd, mesg, wParam, lParam ) BIND(C, NAME = 'MainWndProc')
USE user32
USE gdi32
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)

  CASE (WM_DESTROY)
    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 win
!===========================================================================
MODULE subs
USE win
CONTAINS
!---------------------------------------------------------------------------
INTEGER (HANDLE) FUNCTION get_dos_handle()
IMPLICIT NONE
INTERFACE
 INTEGER (HANDLE) FUNCTION GetConsoleWindow() BIND(C, NAME = 'GetConsoleWindow@0') ! Fortran2003
 IMPORT
 END FUNCTION
END INTERFACE
get_dos_handle = GetConsoleWindow() ! not existent in INTEL Fortran
RETURN
END FUNCTION get_dos_handle
!-------------------------------------------------------------------------
INTEGER (HANDLE) FUNCTION get_win_handle()
USE kernel32, ONLY : GetModuleHandle
IMPLICIT NONE
get_win_handle = GetModuleHandle(NULL)
RETURN
END FUNCTION get_win_handle
!--------------------------------------------------------------------------
END MODULE subs
!==========================================================================
PROGRAM doswin
USE subs
IMPLICIT NONE
INTEGER (HANDLE)   :: hDOS, hInstance, hPrevInstance
INTEGER (LPSTR)    :: lpszCmdLine
INTEGER (SINT)     :: nCmdShow
INTEGER (KIND = 4) :: iret
CHARACTER (LEN = 1024) :: text, buff
INTEGER :: i, n, nlen
hDOS      = get_dos_handle()
hInstance = get_win_handle()
n = COMMAND_ARGUMENT_COUNT()              ! Fortran2003
text = ''
DO i = 1, n
 CALL GET_COMMAND_ARGUMENT(i, buff, nlen) ! Fortran2003
 text = TRIM(text) // ' ' // buff(1:nlen) ! Insert a space between args
END DO
text = TRIM(text(2:))//ACHAR(0)           ! delete first space : add NULL (C style)
PRINT '(2Z10, 2a)', hDOS, hInstance, ':', TRIM(text)
lpszCmdLine = LOC(text)                   ! LOC non-standard : address of text
nCmdShow    = SW_SHOWNORMAL
iret = WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow )
STOP
END PROGRAM doswin