From: Phillip Helbig---undress to reply on
In article
<8bb49fdc-7788-477f-94c5-c1af4d21e809(a)z10g2000yqb.googlegroups.com>, The
Star King <jfb(a)npl.co.uk> writes:

> > > !GCC$ ATTRIBUTES STDCALL
> > > which i wasn't aware of but which is reminiscent of the Intel Fortran
> > > !DEC$ command.

Aahhh yes---Directive-Enhanced Compilation. I'm sure Steve Lionel can
give us some of the history of this preprocessor command. :-)

From: dpb on
The Star King wrote:
....

> This means that the Fortran program will not have a main "program"
> declaration. How can gfortran cope with this?

Same way as for any other Win32 API declaration -- build what you need.

Sotoo (CVF-compatible; do whatever it is in your compiler to get similar
results)

integer function WinMain(hInstance, hPrevInstance, lpCmdLine, nCmdShow )
!DEC$ ATTRIBUTES STDCALL, ALIAS : 'WinMain' :: WinMain
....
integer :: hInstance, hPrevInstance, nCmdShow
integer :: lpCmdLine
....
integer hInstance, hPrevInstance, nCmdShow, lpCmdLine

type (T_MSG) :: mesg
....
if (hPrevInstance .eq. 0) then
if (InitApplication(hInstance)== 0) then
WinMain = FALSE
return
end if
end if
hInst = hInstance
....
do while (GetMessage(mesg, NULL, 0, 0))
i = TranslateMessage(mesg)
i = DispatchMessage(mesg)
end do
WinMain = mesg%wParam
end

etc., ...

If there hasn't been a module built for WinMain and friends specific for
the particular compiler, your mission, should you choose to accept it,
.... :)

It's tedious but basically a straightforward process, much of which can
be automated. What's actually available as starting points in the open
source genre I'm not aware but I'd think somebody would have a pretty
good handle on it that could be modified to any particular compiler's
extensions.

This does assume there is a way to do the name-mangling required...

--
From: Steve Lionel on
On 7/20/2010 6:27 AM, Phillip Helbig---undress to reply wrote:
> In article
> <8bb49fdc-7788-477f-94c5-c1af4d21e809(a)z10g2000yqb.googlegroups.com>, The
> Star King<jfb(a)npl.co.uk> writes:
>
>>>> !GCC$ ATTRIBUTES STDCALL
>>>> which i wasn't aware of but which is reminiscent of the Intel Fortran
>>>> !DEC$ command.
>
> Aahhh yes---Directive-Enhanced Compilation. I'm sure Steve Lionel can
> give us some of the history of this preprocessor command. :-)
>

Certainly I could, but I think you know it already. I will comment that
pretty much all Fortran compilers with comment-like directives follow
the general format of ! (or C) followed by three letters and then $.
(An exception is OpenMP which uses !$OMP.) !DIR$ is another popular
"introducer" and Intel Fortran also recognizes it.

--
Steve Lionel
Developer Products Division
Intel Corporation
Nashua, NH

For email address, replace "invalid" with "com"

User communities for Intel Software Development Products
http://software.intel.com/en-us/forums/
Intel Software Development Products Support
http://software.intel.com/sites/support/
My Fortran blog
http://www.intel.com/software/drfortran
From: FX on
> You need to prepare a WinMain function and at least one callback
> function for Windows to call.

If you have a main PROGRAM in your Fortran code (as opposed to only
subroutines and functions), your compiler has the task of getting the OS
to run it appropriately (creating whatever machine code entry point is
expected by the application loader).

--
FX
From: James Van Buskirk on
"The Star King" <jfb(a)npl.co.uk> wrote in message
news:8bb49fdc-7788-477f-94c5-c1af4d21e809(a)z10g2000yqb.googlegroups.com...

> James, thanks very much for your reply. Sorry, I didn't realise the
> functions you mentioned were win32 functions. However, to get a
> program running in a window a little more "magic" is needed. You need
> to prepare a WinMain function and at least one callback function for
> Windows to call. These are generally written in C as

> int WINAPI WinMain (HINSTANCE hinstance, HINSTANCED hPrevInstance,
> PSTR szCmdLine, int iCmdShow);
> LRESULT CALLBACK WndProc (HWND hwnd, UINT iMsg, WPARAM wParam, LPARAM
> lParam);

> This means that the Fortran program will not have a main "program"
> declaration. How can gfortran cope with this?

It just can these days. I updated my Fortran adaptation of Petzold's
Hello, world program. Comcast seems to have made it more difficult
to update my web page just now, however, so here it comes:

C:\gfortran\clf\HelloWin>type HelloWin2.f90
! HelloWin2.f90
! Public domain 2007-2010 James Van Buskirk
! Compiled with:
! gfortran -Wall -mwindows HelloWin2.f90 -oHelloWin2 -lgdi32

module win32_types
use ISO_C_BINDING
implicit none
private

public WNDCLASSEX_T
type, bind(C) :: WNDCLASSEX_T
integer(C_INT) cbSize
integer(C_INT) style
type(C_FUNPTR) lpfnWndProc
integer(C_INT) cbClsExtra
integer(C_INT) cbWndExtra
integer(C_INTPTR_T) hInstance
integer(C_INTPTR_T) hIcon
integer(C_INTPTR_T) hCursor
integer(C_INTPTR_T) hbrBackground
type(C_PTR) lpszMenuName
type(C_PTR) lpszClassName
integer(C_INTPTR_T) hIconSm
end type WNDCLASSEX_T

public POINT_T
type, bind(C) :: POINT_T
integer(C_LONG) x
integer(C_LONG) y
end type POINT_T

public MSG_T
type, bind(C) :: MSG_T
integer(C_INTPTR_T) hwnd
integer(C_INT) message
integer(C_INTPTR_T) wParam
integer(C_INTPTR_T) lParam
integer(C_LONG) time
type(POINT_T) pt
end type MSG_T

public RECT_T
type, bind(C) :: RECT_T
integer(C_LONG) left
integer(C_LONG) top
integer(C_LONG) right
integer(C_LONG) bottom
end type RECT_T

public PAINTSTRUCT_T
type, bind(C) :: PAINTSTRUCT_T
integer(C_INTPTR_T) hdc
integer(C_INT) fErase
type(RECT_T) rcPaint
integer(C_INT) fRestore
integer(C_INT) fIncUpdate
integer(C_INT8_T) rgbReserved(32)
end type PAINTSTRUCT_T
end module win32_types

module win32
use ISO_C_BINDING
implicit none
private

public GetModuleHandle
interface
function GetModuleHandle(lpModuleName) &
bind(C,name='GetModuleHandleA')

use ISO_C_BINDING
implicit none
!GCC$ ATTRIBUTES STDCALL :: GetModuleHandle
integer(C_INTPTR_T) GetModuleHandle
character(kind=C_CHAR) lpModuleName(*)
end function GetModuleHandle
end interface

public GetCommandLine
interface
function GetCommandLine() &
bind(C,name='GetCommandLineA')

use ISO_C_BINDING
implicit none
!GCC$ ATTRIBUTES STDCALL :: GetCommandLine
type(C_PTR) GetCommandLine
end function GetCommandLine
end interface

public DefWindowProc
interface
function DefWindowProc(hwnd, Msg, wParam, lParam) &
bind(C,name='DefWindowProcA')

use ISO_C_BINDING
implicit none
!GCC$ ATTRIBUTES STDCALL :: DefWindowProc
integer(C_LONG) DefWindowProc
integer(C_INTPTR_T), value :: hwnd
integer(C_INT), value :: Msg
integer(C_INTPTR_T), value :: wParam
integer(C_INTPTR_T), value :: lParam
end function DefWindowProc
end interface

public LoadIcon
interface
function LoadIcon(hInstance, lpIconName) &
bind(C,name='LoadIconA')

use ISO_C_BINDING
implicit none
!GCC$ ATTRIBUTES STDCALL :: LoadIcon
integer(C_INTPTR_T) LoadIcon
integer(C_INTPTR_T), value :: hInstance
character(kind=C_CHAR) lpIconName(*)
end function LoadIcon
end interface

public LoadCursor
interface
function LoadCursor(hInstance, lpCursorName) &
bind(C,name='LoadCursorA')

use ISO_C_BINDING
implicit none
!GCC$ ATTRIBUTES STDCALL :: LoadCursor
integer(C_INTPTR_T) LoadCursor
integer(C_INTPTR_T), value :: hInstance
character(kind=C_CHAR) lpCursorName(*)
end function LoadCursor
end interface

public GetStockObject
interface
function GetStockObject(fnObject) &
bind(C,name='GetStockObject')

use ISO_C_BINDING
implicit none
!GCC$ ATTRIBUTES STDCALL :: GetStockObject
integer(C_INTPTR_T) GetStockObject
integer(C_INT), value :: fnObject
end function GetStockObject
end interface

integer(C_INT), parameter, public :: WHITE_BRUSH = 0 ! Stock object

public RegisterClassEx
interface
function RegisterClassEx(WndClass) &
bind(C,name='RegisterClassExA')

use ISO_C_BINDING
use win32_types
implicit none
!GCC$ ATTRIBUTES STDCALL :: RegisterClassEx
integer(C_SHORT) RegisterClassEx
type(WNDCLASSEX_T) WndClass
end function RegisterClassEx
end interface

! Work around bug in libuser32.a
! public CreateWindow
! interface
! function CreateWindow(lpClassName, lpWindowName, dwStyle, &
! x, y, nWidth, nHeight, hwndParent, hMenu, hInstance, &
! lpParam) bind(C,name='CreateWindow')
!
! use ISO_C_BINDING
! implicit none
!!GCC$ ATTRIBUTES STDCALL :: CreateWindow
! integer(C_INTPTR_T) CreateWindow
! character(kind=C_CHAR) lpClassName(*)
! character(kind=C_CHAR) lpWindowName(*)
! integer(C_LONG), value :: dwStyle
! integer(C_INT), value :: x
! integer(C_INT), value :: y
! integer(C_INT), value :: nWidth
! integer(C_INT), value :: nHeight
! integer(C_INTPTR_T), value :: hWndParent
! integer(C_INTPTR_T), value :: hMenu
! integer(C_INTPTR_T), value :: hInstance
! type(C_PTR), value :: lpParam
! end function CreateWindow
! end interface

public CreateWindowEx
interface
function CreateWindowEx(dwExStyle, lpClassName, &
lpWindowName, dwStyle, x, y, nWidth, nHeight, &
hwndParent, hMenu, hInstance, lpParam) &
bind(C,name='CreateWindowExA')

use ISO_C_BINDING
implicit none
!GCC$ ATTRIBUTES STDCALL :: CreateWindowEx
integer(C_INTPTR_T) CreateWindowEx
integer(C_LONG), value :: dwExStyle
character(kind=C_CHAR) lpClassName(*)
character(kind=C_CHAR) lpWindowName(*)
integer(C_LONG), value :: dwStyle
integer(C_INT), value :: x
integer(C_INT), value :: y
integer(C_INT), value :: nWidth
integer(C_INT), value :: nHeight
integer(C_INTPTR_T), value :: hWndParent
integer(C_INTPTR_T), value :: hMenu
integer(C_INTPTR_T), value :: hInstance
type(C_PTR), value :: lpParam
end function CreateWindowEx
end interface

public ShowWindow
interface
function ShowWindow(hWnd,nCmdShow) bind(C,name='ShowWindow')
use ISO_C_BINDING
implicit none
!GCC$ ATTRIBUTES STDCALL :: ShowWindow
integer(C_INT) ShowWindow
integer(C_INTPTR_T), value :: hWnd
integer(C_INT), value :: nCmdShow
end function ShowWindow
end interface

public UpdateWindow
interface
function UpdateWindow(hWnd) bind(C,name='UpdateWindow')
use ISO_C_BINDING
implicit none
!GCC$ ATTRIBUTES STDCALL :: UpdateWindow
integer(C_INT) UpdateWindow
integer(C_INTPTR_T), value :: hWnd
end function UpdateWindow
end interface

public GetMessage
interface
function GetMessage(lpMsg,hWnd,wMsgFilterMin,wMsgFilterMax) &
bind(C,name='GetMessageA')

use ISO_C_BINDING
use win32_types
implicit none
!GCC$ ATTRIBUTES STDCALL :: GetMessage
integer(C_INT) GetMessage
type(MSG_T) lpMsg
integer(C_INTPTR_T), value :: hWnd
integer(C_INT), value :: wMsgFilterMin
integer(C_INT), value :: wMsgFilterMax
end function GetMessage
end interface

public TranslateMessage
interface
function TranslateMessage(lpMsg) bind(C,name='TranslateMessage')
use ISO_C_BINDING
use win32_types
implicit none
!GCC$ ATTRIBUTES STDCALL :: TranslateMessage
integer(C_INT) TranslateMessage
type(MSG_T) lpMsg
end function TranslateMessage
end interface

public DispatchMessage
interface
function DispatchMessage(lpMsg) bind(C,name='DispatchMessageA')
use ISO_C_BINDING
use win32_types
implicit none
!GCC$ ATTRIBUTES STDCALL :: DispatchMessage
integer(C_LONG) DispatchMessage
type(MSG_T) lpMsg
end function DispatchMessage
end interface

public ExitProcess
interface
subroutine ExitProcess(uExitCode) bind(C,name='ExitProcess')
use ISO_C_BINDING
implicit none
!GCC$ ATTRIBUTES STDCALL :: ExitProcess

integer(C_INT), value :: uExitCode
end subroutine ExitProcess
end interface

public BeginPaint
interface
function BeginPaint(hwnd,lpPaint) bind(C,name='BeginPaint')
use ISO_C_BINDING
use win32_types
implicit none
!GCC$ ATTRIBUTES STDCALL :: BeginPaint
integer(C_INTPTR_T) BeginPaint
integer(C_INTPTR_T), value :: hwnd
type(PAINTSTRUCT_T) lpPaint
end function BeginPaint
end interface

public GetClientRect
interface
function GetClientRect(hwnd,lpRect) bind(C,name='GetClientRect')
use ISO_C_BINDING
use win32_types
implicit none
!GCC$ ATTRIBUTES STDCALL :: GetClientRect
integer(C_INT) GetClientRect
integer(C_INTPTR_T), value :: hwnd
type(RECT_T) lpRect
end function GetClientRect
end interface

public DrawText
interface
function DrawText(hdc, lpString, nCount, lpRect, &
uFormat) bind(C,name='DrawTextA')

use ISO_C_BINDING
use win32_types
implicit none
!GCC$ ATTRIBUTES STDCALL :: DrawText
integer(C_INT) DrawText
integer(C_INTPTR_T), value :: hdc
character(kind=C_CHAR) lpString(*)
integer(C_INT), value :: nCount
type(RECT_T) lpRect
integer(C_INT), value :: uFormat
end function DrawText
end interface

public EndPaint
interface
function EndPaint(hwnd,lpPaint) bind(C,name='EndPaint')
use ISO_C_BINDING
use win32_types
implicit none
!GCC$ ATTRIBUTES STDCALL :: EndPaint
integer(C_INT) EndPaint
integer(C_INTPTR_T), value :: hwnd
type(PAINTSTRUCT_T) lpPaint
end function EndPaint
end interface

public PostQuitMessage
interface
subroutine PostQuitMessage(nExitCode) bind(C,name='PostQuitMessage')
use ISO_C_BINDING
implicit none
!GCC$ ATTRIBUTES STDCALL :: PostQuitMessage

integer(C_INT), value :: nExitCode
end subroutine PostQuitMessage
end interface
end module win32

module procs
use win32
use win32_types
use ISO_C_BINDING
implicit none
private
public WndProc
contains
function WndProc(hwnd, iMsg, wParam, lParam) bind(C)
!GCC$ ATTRIBUTES STDCALL :: WndProc
integer(C_LONG) WndProc
integer(C_INTPTR_T), value :: hwnd
integer(C_INT), value :: iMsg
integer(C_INTPTR_T), value :: wParam
integer(C_INTPTR_T), value :: lParam
integer(C_INTPTR_T) hdc
type(PAINTSTRUCT_T) ps
type(RECT_T) rect
integer(C_INT) result4
character(kind=C_CHAR) message*(80)

select case(iMsg)
case(1) ! WM_CREATE
WndProc = 0
return
case(15) ! WM_PAINT
hdc = BeginPaint(hwnd, ps)
result4 = GetClientRect(hwnd, rect)
message = 'Hello, gfortran!'//achar(0)
result4 = DrawText(hdc, message, -1, rect, 37)
result4 = EndPaint(hwnd, ps)
WndProc = 0
return
case(2) ! WM_DESTROY
call PostQuitMessage(0)
WndProc = 0
return
end select

WndProc = DefWindowProc(hwnd, iMsg, wParam, lParam)
end function WndProc
end module procs

function WinMain(hInstance, hPrevInstance, lpCmdLine, nCmdShow) bind(C,
name='Wi
nMain')
!program WinMain
use win32
use win32_types
use procs
use ISO_C_BINDING
implicit none
!GCC$ ATTRIBUTES STDCALL :: WinMain
integer(C_INT) WinMain
integer(C_INTPTR_T), value :: hInstance
integer(C_INTPTR_T), value :: hPrevInstance
type(C_PTR), value :: lpCmdLine
integer(C_INT), value :: nCmdShow
character(kind=C_CHAR), pointer :: pcNull(:)
! integer(C_INTPTR_T) hInstance
! type(C_PTR) szCommandLine
type(WNDCLASSEX_T) WndClass
character(kind=C_CHAR), pointer :: cDefault(:)
character(kind=C_CHAR), target :: szAppName*(80)
integer(C_SHORT) result2
integer(C_INTPTR_T) hwnd
character(kind=C_CHAR), target :: szWindowCaption*(80)
integer(C_INT) result4
type(MSG_T) msg
integer(C_INT) argh4

nullify(pcNull)
! hInstance = GetModuleHandle(pcNull)
! szCommandLine = GetCommandLine()
call C_F_POINTER(lpCmdLine,cDefault,[0])
! call C_F_POINTER(szCommandLine,cDefault,[0])
szAppName = 'HelloWin'//achar(0)
WndClass%cbSize = size(transfer(Wndclass,[0_C_INT8_T]))
WndClass%style = 3 ! ior(CS_HREDRAW, CS_VREDRAW)
WndClass%lpfnWndProc = C_FUNLOC(WndProc)
WndClass%cbClsExtra = 0
WndClass%cbWndExtra = 0
WndClass%hInstance = hInstance
WndClass%hIcon = LoadIcon(0_C_INTPTR_T, cDefault) ! IDI_APPLICATION
WndClass%hCursor = LoadCursor(0_C_INTPTR_T, cDefault) ! IDC_ARROW
WndClass%hbrBackground = GetStockObject(WHITE_BRUSH)
WndClass%lpszMenuName = C_NULL_PTR
WndClass%lpszClassName = C_LOC(szAppName(1:1))
WndClass%hIconSm = LoadIcon(0_C_INTPTR_T, cDefault) ! IDI_APPLICATION

result2 = RegisterClassEx(WndClass)

szWindowCaption = 'The Hello Program'//achar(0)
! Workaround for bug
! hwnd = CreateWindow(szAppName, szWindowCaption, &
! 13565952, -2147483648, -2147483648, -2147483648, &
! -2147483648, 0_C_INTPTR_T, 0_C_INTPTR_T, hInstance, &
! C_NULL_PTR)
argh4 = -2147483647-1
! Workaround for libuser32.a bug
! hwnd = CreateWindow(szAppName, szWindowCaption, &
! 13565952, argh4, argh4, argh4, argh4, 0_C_INTPTR_T, &
! 0_C_INTPTR_T, hInstance, C_NULL_PTR)
hwnd = CreateWindowEx(0, szAppName, szWindowCaption, &
13565952, argh4, argh4, argh4, argh4, 0_C_INTPTR_T, &
0_C_INTPTR_T, hInstance, C_NULL_PTR)

result4 = ShowWindow(hwnd, 10) ! SW_SHOWDEFAULT
result4 = UpdateWindow(hwnd)

do while(GetMessage(msg, 0_C_INTPTR_T, 0, 0) /= 0)
result4 = TranslateMessage(msg)
result4 = DispatchMessage(msg)
end do

call ExitProcess(int(msg%wParam, C_INT))
WinMain = 0
end function WinMain
!end program WinMain

C:\gfortran\clf\HelloWin>gfortran -Wall -mwindows
HelloWin2.f90 -oHelloWin2 -lgd
i32
HelloWin2.f90:403.41:

function WinMain(hInstance, hPrevInstance, lpCmdLine, nCmdShow) bind(C,
name='W
1
Warning: Unused dummy argument 'hprevinstance' at (1)
HelloWin2.f90:403.62:

function WinMain(hInstance, hPrevInstance, lpCmdLine, nCmdShow) bind(C,
name='W
1
Warning: Unused dummy argument 'ncmdshow' at (1)

C:\gfortran\clf\HelloWin>HelloWin2

C:\gfortran\clf\HelloWin>gfortran -v
Built by Equation Solution < http://www.Equation.com>.
Using built-in specs.
COLLECT_GCC=gfortran
COLLECT_LTO_WRAPPER=c:/gcc_equation/bin/../libexec/gcc/x86_64-pc-mingw32/4.5.0/l
to-wrapper.exe
Target: x86_64-pc-mingw32
Configured with:
.../gcc-4.5-20091217-mingw/configure --host=x86_64-pc-mingw32 --
build=x86_64-unknown-linux-gnu --target=x86_64-pc-mingw32 --prefix=/home/gfortra
n/gcc-home/binary/mingw32/native/x86_64/gcc/4.5-20091217 --with-gmp=/home/gfortr
an/gcc-home/binary/mingw32/native/x86_64/gmp --with-mpfr=/home/gfortran/gcc-home
/binary/mingw32/native/x86_64/mpfr --with-mpc=/home/gfortran/gcc-home/binary/min
gw32/native/x86_64/mpc --with-sysroot=/home/gfortran/gcc-home/binary/mingw32/cro
ss/x86_64/gcc/4.5-20091217 --with-gcc --with-gnu-ld --with-gnu-as --disable-shar
ed --disable-nls --disable-tls --enable-libgomp --enable-languages=c,fortran,c++
--enable-threads=win32 --disable-win32-registry
Thread model: win32
gcc version 4.5.0 20091217 (experimental) (GCC)

Well, you can't see what it did because it popped up a command window
and that was the 64-bit compiler. Results for the 32-bit compiler:

C:\gfortran\clf\HelloWin>gfortran -Wall -mwindows
HelloWin2.f90 -oHelloWin2 -lgd
i32
HelloWin2.f90:403.41:

function WinMain(hInstance, hPrevInstance, lpCmdLine, nCmdShow) bind(C,
name='W
1
Warning: Unused dummy argument 'hprevinstance' at (1)
HelloWin2.f90:403.62:

function WinMain(hInstance, hPrevInstance, lpCmdLine, nCmdShow) bind(C,
name='W
1
Warning: Unused dummy argument 'ncmdshow' at (1)

C:\gfortran\clf\HelloWin>HelloWin2

C:\gfortran\clf\HelloWin>gfortran -v
Built by Equation Solution <http://www.Equation.com>.
Using built-in specs.
Target: i386-pc-mingw32
Configured with:
.../gcc-4.5-20090813-mingw/configure --host=i386-pc-mingw32 --bu
ild=x86_64-unknown-linux-gnu --target=i386-pc-mingw32 --prefix=/home/gfortran/gc
c-home/binary/mingw32/native/x86_32/gcc/4.5-20090813 --with-gcc --with-gnu-ld
--
with-gnu-as --disable-shared --disable-nls --disable-tls --with-gmp=/home/gfortr
an/gcc-home/binary/mingw32/native/x86_32/gmp --with-mpfr=/home/gfortran/gcc-home
/binary/mingw32/native/x86_32/mpfr --enable-languages=c,fortran,c++ --with-sysro
ot=/home/gfortran/gcc-home/binary/mingw32/cross/x86_32/gcc/4.5-20090813 --enable
-libgomp --enable-threads=win32 --disable-win32-registry
Thread model: win32
gcc version 4.5.0 20090813 (experimental) (GCC)

You will have to try it out for yourself as again the program popped
up a window. Also I checked with Task Manager that this program was
indeed 32-bit (and the other was 64-bit.) If all you need is OpenGL,
I am not sure that you really need a Windows program; maybe OpenGL
can pop up a graphics window from a console program.

--
write(*,*) transfer((/17.392111325966148d0,6.5794487871554595D-85, &
6.0134700243160014d-154/),(/'x'/)); end