! HelloWin1.f90
! Public domain 2007-2008 James Van Buskirk
! Compiled with:
! gfortran -Wall HelloWin1.f90 -oHelloWin1 -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
         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
         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
         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
         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
         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
         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
         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
!         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
         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
         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
         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
         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
         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
         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

         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
         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
         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
         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
         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

         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)
         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

program WinMain
   use win32
   use win32_types
   use procs
   use ISO_C_BINDING
   implicit none
   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(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))
end program WinMain