steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

ran dos2unix on win32 files

release
erg 2006-07-25 14:04:14 +00:00
parent 11a005b866
commit 66c4e51bcf
11 changed files with 3384 additions and 3384 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
library/io/windows/load.factor
View File

@ -1,24 +1,24 @@
IN: scratchpad IN: scratchpad
USING: alien compiler kernel namespaces parser sequences words ; USING: alien compiler kernel namespaces parser sequences words ;
{ {
{ "gdi32" "gdi32" } { "gdi32" "gdi32" }
{ "user32" "user32" } { "user32" "user32" }
{ "kernel32" "kernel32" } { "kernel32" "kernel32" }
{ "winsock" "ws2_32" } { "winsock" "ws2_32" }
{ "mswsock" "mswsock" } { "mswsock" "mswsock" }
} [ first2 add-simple-library ] each } [ first2 add-simple-library ] each
"libc" "msvcrt.dll" "cdecl" add-library "libc" "msvcrt.dll" "cdecl" add-library
{ {
"io" "io"
"errors" "errors"
"winsock" "winsock"
"io-internals" "io-internals"
"stream" "stream"
"server" "server"
"io-last" "io-last"
} [ "/library/io/windows/" swap ".factor" append3 run-resource ] each } [ "/library/io/windows/" swap ".factor" append3 run-resource ] each
IN: kernel IN: kernel
: default-shell "ui" ; : default-shell "ui" ;

94
library/ui/windows/clipboard.factor
View File

@ -1,47 +1,47 @@
! Copyright (C) 2006 Doug Coleman. ! Copyright (C) 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel win32-api math namespaces io prettyprint errors sequences alien USING: kernel win32-api math namespaces io prettyprint errors sequences alien
libc gadgets ; libc gadgets ;
IN: win32 IN: win32
: (enum-clipboard) ( n -- ) : (enum-clipboard) ( n -- )
EnumClipboardFormats win32-error dup 0 > [ dup , (enum-clipboard) ] when ; EnumClipboardFormats win32-error dup 0 > [ dup , (enum-clipboard) ] when ;
: enum-clipboard ( -- seq ) : enum-clipboard ( -- seq )
[ 0 (enum-clipboard) ] { } make nip ; [ 0 (enum-clipboard) ] { } make nip ;
: paste ( -- str ) : paste ( -- str )
f OpenClipboard drop f OpenClipboard drop
CF_TEXT IsClipboardFormatAvailable 0 = [ CF_TEXT IsClipboardFormatAvailable 0 = [
"no text in clipboard" print "no text in clipboard" print
] [ ] [
! "text found" print ! "text found" print
CF_TEXT GetClipboardData CF_TEXT GetClipboardData
dup GlobalLock swap dup GlobalLock swap
GlobalUnlock drop GlobalUnlock drop
] if ] if
CloseClipboard drop alien>char-string ; CloseClipboard drop alien>char-string ;
: copy ( str -- ) : copy ( str -- )
f OpenClipboard drop f OpenClipboard drop
EmptyClipboard drop EmptyClipboard drop
GMEM_MOVEABLE over length 1+ GlobalAlloc dup 0 = [ GMEM_MOVEABLE over length 1+ GlobalAlloc dup 0 = [
"unable to allocate memory" throw "unable to allocate memory" throw
] when ] when
dup GlobalLock dup GlobalLock
rot dup length memcpy rot dup length memcpy
dup GlobalUnlock drop dup GlobalUnlock drop
CF_TEXT swap SetClipboardData 0 = [ CF_TEXT swap SetClipboardData 0 = [
win32-error win32-error
"SetClipboardData failed" throw "SetClipboardData failed" throw
] when ] when
CloseClipboard drop ; CloseClipboard drop ;
TUPLE: pasteboard ; TUPLE: pasteboard ;
M: pasteboard clipboard-contents ( pb -- str ) drop paste ; M: pasteboard clipboard-contents ( pb -- str ) drop paste ;
M: pasteboard set-clipboard-contents ( str pb -- ) drop copy ; M: pasteboard set-clipboard-contents ( str pb -- ) drop copy ;
: init-clipboard ( -- ) : init-clipboard ( -- )
<pasteboard> clipboard set-global ; <pasteboard> clipboard set-global ;

72
library/ui/windows/gdi32.factor
View File

@ -1,36 +1,36 @@
! Copyright (C) 2005, 2006 Doug Coleman. ! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
USING: alien kernel errors ; USING: alien kernel errors ;
IN: win32-api IN: win32-api
LIBRARY: gdi32 LIBRARY: gdi32
! Stock Logical Objects ! Stock Logical Objects
: WHITE_BRUSH 0 ; inline : WHITE_BRUSH 0 ; inline
: LTGRAY_BRUSH 1 ; inline : LTGRAY_BRUSH 1 ; inline
: GRAY_BRUSH 2 ; inline : GRAY_BRUSH 2 ; inline
: DKGRAY_BRUSH 3 ; inline : DKGRAY_BRUSH 3 ; inline
: BLACK_BRUSH 4 ; inline : BLACK_BRUSH 4 ; inline
: NULL_BRUSH 5 ; inline : NULL_BRUSH 5 ; inline
: HOLLOW_BRUSH NULL_BRUSH ; inline : HOLLOW_BRUSH NULL_BRUSH ; inline
: WHITE_PEN 6 ; inline : WHITE_PEN 6 ; inline
: BLACK_PEN 7 ; inline : BLACK_PEN 7 ; inline
: NULL_PEN 8 ; inline : NULL_PEN 8 ; inline
: OEM_FIXED_FONT 10 ; inline : OEM_FIXED_FONT 10 ; inline
: ANSI_FIXED_FONT 11 ; inline : ANSI_FIXED_FONT 11 ; inline
: ANSI_VAR_FONT 12 ; inline : ANSI_VAR_FONT 12 ; inline
: SYSTEM_FONT 13 ; inline : SYSTEM_FONT 13 ; inline
: DEVICE_DEFAULT_FONT 14 ; inline : DEVICE_DEFAULT_FONT 14 ; inline
: DEFAULT_PALETTE 15 ; inline : DEFAULT_PALETTE 15 ; inline
: SYSTEM_FIXED_FONT 16 ; inline : SYSTEM_FIXED_FONT 16 ; inline
: DEFAULT_GUI_FONT 17 ; inline : DEFAULT_GUI_FONT 17 ; inline
: DC_BRUSH 18 ; inline : DC_BRUSH 18 ; inline
: DC_PEN 19 ; inline : DC_PEN 19 ; inline
FUNCTION: HGDIOBJ GetStockObject ( int fnObject ) ; FUNCTION: HGDIOBJ GetStockObject ( int fnObject ) ;
FUNCTION: int ChoosePixelFormat ( HDC hDC, PFD* ppfd ) ; FUNCTION: int ChoosePixelFormat ( HDC hDC, PFD* ppfd ) ;
FUNCTION: BOOL SetPixelFormat ( HDC hDC, int iPixelFormat, PFD* ppfd ) ; FUNCTION: BOOL SetPixelFormat ( HDC hDC, int iPixelFormat, PFD* ppfd ) ;
FUNCTION: BOOL SwapBuffers ( HDC hDC ) ; FUNCTION: BOOL SwapBuffers ( HDC hDC ) ;

122
library/ui/windows/kernel32.factor
View File

@ -1,61 +1,61 @@
! Copyright (C) 2005, 2006 Doug Coleman. ! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
USING: alien kernel errors ; USING: alien kernel errors ;
IN: win32-api IN: win32-api
LIBRARY: kernel32 LIBRARY: kernel32
! FUNCTION: MAKEINTRESOURCEA ! FUNCTION: MAKEINTRESOURCEA
! FUNCTION: MAKEINTRESOURCEW ! FUNCTION: MAKEINTRESOURCEW
! : MAKEINTRESOURCE \ MAKEINTRESOURCEW \ MAKEINTRESOURCEA unicode-exec ; ! : MAKEINTRESOURCE \ MAKEINTRESOURCEW \ MAKEINTRESOURCEA unicode-exec ;
! #define IS_INTRESOURCE(_r) (((ULONG_PTR)(_r) >> 16) == 0) ! #define IS_INTRESOURCE(_r) (((ULONG_PTR)(_r) >> 16) == 0)
! #define MAKEINTRESOURCEA(i) (LPSTR)((ULONG_PTR)((WORD)(i))) ! #define MAKEINTRESOURCEA(i) (LPSTR)((ULONG_PTR)((WORD)(i)))
! #define MAKEINTRESOURCEW(i) (LPWSTR)((ULONG_PTR)((WORD)(i))) ! #define MAKEINTRESOURCEW(i) (LPWSTR)((ULONG_PTR)((WORD)(i)))
! FUNCTION: DWORD FormatMessage( ! FUNCTION: DWORD FormatMessage(
! DWORD dwFlags, ! DWORD dwFlags,
! LPCVOID lpSource, ! LPCVOID lpSource,
! DWORD dwMessageId, ! DWORD dwMessageId,
! DWORD dwLanguageId, ! DWORD dwLanguageId,
! LPTSTR lpBuffer, ! LPTSTR lpBuffer,
! DWORD nSize, ! DWORD nSize,
! va_list* Arguments ! va_list* Arguments
! ) ; ! ) ;
FUNCTION: HMODULE GetModuleHandleA ( char* lpModulename ) ; FUNCTION: HMODULE GetModuleHandleA ( char* lpModulename ) ;
FUNCTION: HMODULE GetModuleHandleW ( char* lpModulename ) ; FUNCTION: HMODULE GetModuleHandleW ( char* lpModulename ) ;
: GetModuleHandle \ GetModuleHandleW \ GetModuleHandleA unicode-exec ; : GetModuleHandle \ GetModuleHandleW \ GetModuleHandleA unicode-exec ;
! FUNCTION: HMODULE GetModuleHandleEx ( ! FUNCTION: HMODULE GetModuleHandleEx (
! DWORD dwFlags, ! DWORD dwFlags,
! LPCTSTR lpModulename, ! LPCTSTR lpModulename,
! HMODULE* phModule ) ; ! HMODULE* phModule ) ;
FUNCTION: DWORD GetLastError ( ) ; FUNCTION: DWORD GetLastError ( ) ;
: (win32-error) ( id -- string ) : (win32-error) ( id -- string )
"char*" f "error_message" [ "int" ] alien-invoke ; "char*" f "error_message" [ "int" ] alien-invoke ;
: win32-error ( -- ) : win32-error ( -- )
GetLastError dup 0 = [ (win32-error) throw ] unless drop ; GetLastError dup 0 = [ (win32-error) throw ] unless drop ;
: GHND HEX: 40 ; inline : GHND HEX: 40 ; inline
: GMEM_FIXED 0 ; inline : GMEM_FIXED 0 ; inline
: GMEM_MOVEABLE 2 ; inline : GMEM_MOVEABLE 2 ; inline
: GMEM_ZEROINIT HEX: 40 ; inline : GMEM_ZEROINIT HEX: 40 ; inline
: GPTR HEX: 40 ; inline : GPTR HEX: 40 ; inline
FUNCTION: HGLOBAL GlobalAlloc ( UINT uFlags, SIZE_T dwBytes ) ; FUNCTION: HGLOBAL GlobalAlloc ( UINT uFlags, SIZE_T dwBytes ) ;
FUNCTION: LPVOID GlobalLock ( HGLOBAL hMem ) ; FUNCTION: LPVOID GlobalLock ( HGLOBAL hMem ) ;
! FUNCTION: char* GlobalLock ( HGLOBAL hMem ) ; ! FUNCTION: char* GlobalLock ( HGLOBAL hMem ) ;
FUNCTION: BOOL GlobalUnlock ( HGLOBAL hMem ) ; FUNCTION: BOOL GlobalUnlock ( HGLOBAL hMem ) ;

54
library/ui/windows/load.factor
View File

@ -1,27 +1,27 @@
IN: scratchpad IN: scratchpad
USING: alien compiler kernel namespaces parser sequences words ; USING: alien compiler kernel namespaces parser sequences words ;
{ {
{ "gdi32" "gdi32" } { "gdi32" "gdi32" }
{ "user32" "user32" } { "user32" "user32" }
{ "kernel32" "kernel32" } { "kernel32" "kernel32" }
{ "winsock" "ws2_32" } { "winsock" "ws2_32" }
{ "mswsock" "mswsock" } { "mswsock" "mswsock" }
} [ first2 add-simple-library ] each } [ first2 add-simple-library ] each
"libc" "msvcrt.dll" "cdecl" add-library "libc" "msvcrt.dll" "cdecl" add-library
{ {
"windows-messages" "windows-messages"
"types" "types"
"gdi32" "gdi32"
"kernel32" "kernel32"
"user32" "user32"
"opengl32" "opengl32"
"utils" "utils"
"ui" "ui"
"clipboard" "clipboard"
} [ "/library/ui/windows/" swap ".factor" append3 run-resource ] each } [ "/library/ui/windows/" swap ".factor" append3 run-resource ] each
IN: kernel IN: kernel
: default-shell "tty" ; : default-shell "tty" ;

204
library/ui/windows/opengl32.factor
View File

@ -1,102 +1,102 @@
! Copyright (C) 2005, 2006 Doug Coleman. ! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
USING: alien parser namespaces kernel syntax words math io prettyprint ; USING: alien parser namespaces kernel syntax words math io prettyprint ;
IN: win32-api IN: win32-api
! PIXELFORMATDESCRIPTOR flags ! PIXELFORMATDESCRIPTOR flags
: PFD_DOUBLEBUFFER HEX: 00000001 ; inline : PFD_DOUBLEBUFFER HEX: 00000001 ; inline
: PFD_STEREO HEX: 00000002 ; inline : PFD_STEREO HEX: 00000002 ; inline
: PFD_DRAW_TO_WINDOW HEX: 00000004 ; inline : PFD_DRAW_TO_WINDOW HEX: 00000004 ; inline
: PFD_DRAW_TO_BITMAP HEX: 00000008 ; inline : PFD_DRAW_TO_BITMAP HEX: 00000008 ; inline
: PFD_SUPPORT_GDI HEX: 00000010 ; inline : PFD_SUPPORT_GDI HEX: 00000010 ; inline
: PFD_SUPPORT_OPENGL HEX: 00000020 ; inline : PFD_SUPPORT_OPENGL HEX: 00000020 ; inline
: PFD_GENERIC_FORMAT HEX: 00000040 ; inline : PFD_GENERIC_FORMAT HEX: 00000040 ; inline
: PFD_NEED_PALETTE HEX: 00000080 ; inline : PFD_NEED_PALETTE HEX: 00000080 ; inline
: PFD_NEED_SYSTEM_PALETTE HEX: 00000100 ; inline : PFD_NEED_SYSTEM_PALETTE HEX: 00000100 ; inline
: PFD_SWAP_EXCHANGE HEX: 00000200 ; inline : PFD_SWAP_EXCHANGE HEX: 00000200 ; inline
: PFD_SWAP_COPY HEX: 00000400 ; inline : PFD_SWAP_COPY HEX: 00000400 ; inline
: PFD_SWAP_LAYER_BUFFERS HEX: 00000800 ; inline : PFD_SWAP_LAYER_BUFFERS HEX: 00000800 ; inline
: PFD_GENERIC_ACCELERATED HEX: 00001000 ; inline : PFD_GENERIC_ACCELERATED HEX: 00001000 ; inline
: PFD_SUPPORT_DIRECTDRAW HEX: 00002000 ; inline : PFD_SUPPORT_DIRECTDRAW HEX: 00002000 ; inline
! PIXELFORMATDESCRIPTOR flags for use in ChoosePixelFormat only ! PIXELFORMATDESCRIPTOR flags for use in ChoosePixelFormat only
: PFD_DEPTH_DONTCARE HEX: 20000000 ; inline : PFD_DEPTH_DONTCARE HEX: 20000000 ; inline
: PFD_DOUBLEBUFFER_DONTCARE HEX: 40000000 ; inline : PFD_DOUBLEBUFFER_DONTCARE HEX: 40000000 ; inline
: PFD_STEREO_DONTCARE HEX: 80000000 ; inline : PFD_STEREO_DONTCARE HEX: 80000000 ; inline
! pixel types ! pixel types
: PFD_TYPE_RGBA 0 ; inline : PFD_TYPE_RGBA 0 ; inline
: PFD_TYPE_COLORINDEX 1 ; inline : PFD_TYPE_COLORINDEX 1 ; inline
! layer types ! layer types
: PFD_MAIN_PLANE 0 ; inline : PFD_MAIN_PLANE 0 ; inline
: PFD_OVERLAY_PLANE 1 ; inline : PFD_OVERLAY_PLANE 1 ; inline
: PFD_UNDERLAY_PLANE -1 ; inline : PFD_UNDERLAY_PLANE -1 ; inline
: LPD_TYPE_RGBA 0 ; inline : LPD_TYPE_RGBA 0 ; inline
: LPD_TYPE_COLORINDEX 1 ; inline : LPD_TYPE_COLORINDEX 1 ; inline
! wglSwapLayerBuffers flags ! wglSwapLayerBuffers flags
: WGL_SWAP_MAIN_PLANE HEX: 00000001 ; inline : WGL_SWAP_MAIN_PLANE HEX: 00000001 ; inline
: WGL_SWAP_OVERLAY1 HEX: 00000002 ; inline : WGL_SWAP_OVERLAY1 HEX: 00000002 ; inline
: WGL_SWAP_OVERLAY2 HEX: 00000004 ; inline : WGL_SWAP_OVERLAY2 HEX: 00000004 ; inline
: WGL_SWAP_OVERLAY3 HEX: 00000008 ; inline : WGL_SWAP_OVERLAY3 HEX: 00000008 ; inline
: WGL_SWAP_OVERLAY4 HEX: 00000010 ; inline : WGL_SWAP_OVERLAY4 HEX: 00000010 ; inline
: WGL_SWAP_OVERLAY5 HEX: 00000020 ; inline : WGL_SWAP_OVERLAY5 HEX: 00000020 ; inline
: WGL_SWAP_OVERLAY6 HEX: 00000040 ; inline : WGL_SWAP_OVERLAY6 HEX: 00000040 ; inline
: WGL_SWAP_OVERLAY7 HEX: 00000080 ; inline : WGL_SWAP_OVERLAY7 HEX: 00000080 ; inline
: WGL_SWAP_OVERLAY8 HEX: 00000100 ; inline : WGL_SWAP_OVERLAY8 HEX: 00000100 ; inline
: WGL_SWAP_OVERLAY9 HEX: 00000200 ; inline : WGL_SWAP_OVERLAY9 HEX: 00000200 ; inline
: WGL_SWAP_OVERLAY10 HEX: 00000400 ; inline : WGL_SWAP_OVERLAY10 HEX: 00000400 ; inline
: WGL_SWAP_OVERLAY11 HEX: 00000800 ; inline : WGL_SWAP_OVERLAY11 HEX: 00000800 ; inline
: WGL_SWAP_OVERLAY12 HEX: 00001000 ; inline : WGL_SWAP_OVERLAY12 HEX: 00001000 ; inline
: WGL_SWAP_OVERLAY13 HEX: 00002000 ; inline : WGL_SWAP_OVERLAY13 HEX: 00002000 ; inline
: WGL_SWAP_OVERLAY14 HEX: 00004000 ; inline : WGL_SWAP_OVERLAY14 HEX: 00004000 ; inline
: WGL_SWAP_OVERLAY15 HEX: 00008000 ; inline : WGL_SWAP_OVERLAY15 HEX: 00008000 ; inline
: WGL_SWAP_UNDERLAY1 HEX: 00010000 ; inline : WGL_SWAP_UNDERLAY1 HEX: 00010000 ; inline
: WGL_SWAP_UNDERLAY2 HEX: 00020000 ; inline : WGL_SWAP_UNDERLAY2 HEX: 00020000 ; inline
: WGL_SWAP_UNDERLAY3 HEX: 00040000 ; inline : WGL_SWAP_UNDERLAY3 HEX: 00040000 ; inline
: WGL_SWAP_UNDERLAY4 HEX: 00080000 ; inline : WGL_SWAP_UNDERLAY4 HEX: 00080000 ; inline
: WGL_SWAP_UNDERLAY5 HEX: 00100000 ; inline : WGL_SWAP_UNDERLAY5 HEX: 00100000 ; inline
: WGL_SWAP_UNDERLAY6 HEX: 00200000 ; inline : WGL_SWAP_UNDERLAY6 HEX: 00200000 ; inline
: WGL_SWAP_UNDERLAY7 HEX: 00400000 ; inline : WGL_SWAP_UNDERLAY7 HEX: 00400000 ; inline
: WGL_SWAP_UNDERLAY8 HEX: 00800000 ; inline : WGL_SWAP_UNDERLAY8 HEX: 00800000 ; inline
: WGL_SWAP_UNDERLAY9 HEX: 01000000 ; inline : WGL_SWAP_UNDERLAY9 HEX: 01000000 ; inline
: WGL_SWAP_UNDERLAY10 HEX: 02000000 ; inline : WGL_SWAP_UNDERLAY10 HEX: 02000000 ; inline
: WGL_SWAP_UNDERLAY11 HEX: 04000000 ; inline : WGL_SWAP_UNDERLAY11 HEX: 04000000 ; inline
: WGL_SWAP_UNDERLAY12 HEX: 08000000 ; inline : WGL_SWAP_UNDERLAY12 HEX: 08000000 ; inline
: WGL_SWAP_UNDERLAY13 HEX: 10000000 ; inline : WGL_SWAP_UNDERLAY13 HEX: 10000000 ; inline
: WGL_SWAP_UNDERLAY14 HEX: 20000000 ; inline : WGL_SWAP_UNDERLAY14 HEX: 20000000 ; inline
: WGL_SWAP_UNDERLAY15 HEX: 40000000 ; inline : WGL_SWAP_UNDERLAY15 HEX: 40000000 ; inline
: pfd-dwFlags : pfd-dwFlags
PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL bitor PFD_DOUBLEBUFFER bitor ; PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL bitor PFD_DOUBLEBUFFER bitor ;
! TODO: compare to http://www.nullterminator.net/opengl32.html ! TODO: compare to http://www.nullterminator.net/opengl32.html
: make-pfd ( bits -- pfd ) : make-pfd ( bits -- pfd )
"PIXELFORMATDESCRIPTOR" <c-object> "PIXELFORMATDESCRIPTOR" <c-object>
"PIXELFORMATDESCRIPTOR" c-size over set-PIXELFORMATDESCRIPTOR-nSize "PIXELFORMATDESCRIPTOR" c-size over set-PIXELFORMATDESCRIPTOR-nSize
1 over set-PIXELFORMATDESCRIPTOR-nVersion 1 over set-PIXELFORMATDESCRIPTOR-nVersion
pfd-dwFlags over set-PIXELFORMATDESCRIPTOR-dwFlags pfd-dwFlags over set-PIXELFORMATDESCRIPTOR-dwFlags
PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
[ set-PIXELFORMATDESCRIPTOR-cColorBits ] keep [ set-PIXELFORMATDESCRIPTOR-cColorBits ] keep
16 over set-PIXELFORMATDESCRIPTOR-cDepthBits 16 over set-PIXELFORMATDESCRIPTOR-cDepthBits
PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask ; PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask ;
LIBRARY: gl LIBRARY: gl
! FUNCTION: int ReleaseDC ( HWND hWnd, HDC hDC ) ; ! FUNCTION: int ReleaseDC ( HWND hWnd, HDC hDC ) ;
! FUNCTION: HDC ResetDC ( HDC hdc, DEVMODE* lpInitData ) ; ! FUNCTION: HDC ResetDC ( HDC hdc, DEVMODE* lpInitData ) ;
! FUNCTION: BOOL RestoreDC ( HDC hdc, int nSavedDC ) ; ! FUNCTION: BOOL RestoreDC ( HDC hdc, int nSavedDC ) ;
! FUNCTION: int SaveDC( HDC hDC ) ; ! FUNCTION: int SaveDC( HDC hDC ) ;
! FUNCTION: HGDIOBJ SelectObject ( HDC hDC, HGDIOBJ hgdiobj ) ; ! FUNCTION: HGDIOBJ SelectObject ( HDC hDC, HGDIOBJ hgdiobj ) ;
FUNCTION: HGLRC wglCreateContext ( HDC hDC ) ; FUNCTION: HGLRC wglCreateContext ( HDC hDC ) ;
FUNCTION: BOOL wglDeleteContext ( HGLRC hRC ) ; FUNCTION: BOOL wglDeleteContext ( HGLRC hRC ) ;
FUNCTION: BOOL wglMakeCurrent ( HDC hDC, HGLRC hglrc ) ; FUNCTION: BOOL wglMakeCurrent ( HDC hDC, HGLRC hglrc ) ;

734
library/ui/windows/types.factor
View File

@ -1,367 +1,367 @@
! Copyright (C) 2005, 2006 Doug Coleman. ! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
USING: alien namespaces kernel words ; USING: alien namespaces kernel words ;
IN: win32-api IN: win32-api
! http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winprog/winprog/windows_data_types.asp ! http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winprog/winprog/windows_data_types.asp
SYMBOL: unicode f unicode set SYMBOL: unicode f unicode set
: unicode-exec ( unicode-func ascii-func -- func ) : unicode-exec ( unicode-func ascii-func -- func )
unicode get [ unicode get [
drop execute drop execute
] [ ] [
nip execute nip execute
] if ; inline ] if ; inline
: unicode? unicode get ; inline : unicode? unicode get ; inline
: win64? f ; : win64? f ;
! win64 ! win64
! char uchar short ushort int uint long ulong longlong ulonglong ! char uchar short ushort int uint long ulong longlong ulonglong
! 1 1 2 2 * * ? ! 1 1 2 2 * * ?
! win32 ! win32
! char uchar short ushort int uint long ulong longlong ulonglong ! char uchar short ushort int uint long ulong longlong ulonglong
! 1 1 2 2 * * 4 4 8 8 ! 1 1 2 2 * * 4 4 8 8
TYPEDEF: char CHAR TYPEDEF: char CHAR
TYPEDEF: uchar UCHAR TYPEDEF: uchar UCHAR
TYPEDEF: uchar BYTE TYPEDEF: uchar BYTE
TYPEDEF: short wchar_t TYPEDEF: short wchar_t
TYPEDEF: wchar_t WCHAR TYPEDEF: wchar_t WCHAR
TYPEDEF: short SHORT TYPEDEF: short SHORT
TYPEDEF: ushort USHORT TYPEDEF: ushort USHORT
TYPEDEF: ushort WORD TYPEDEF: ushort WORD
TYPEDEF: ulong DWORD TYPEDEF: ulong DWORD
TYPEDEF: int INT TYPEDEF: int INT
TYPEDEF: uint UINT TYPEDEF: uint UINT
TYPEDEF: int BOOL TYPEDEF: int BOOL
TYPEDEF: int* PINT TYPEDEF: int* PINT
TYPEDEF: int* LPINT TYPEDEF: int* LPINT
TYPEDEF: int HFILE TYPEDEF: int HFILE
TYPEDEF: long LONG TYPEDEF: long LONG
TYPEDEF: long* LPLONG TYPEDEF: long* LPLONG
TYPEDEF: long LONG_PTR TYPEDEF: long LONG_PTR
TYPEDEF: long* PLONG_PTR TYPEDEF: long* PLONG_PTR
TYPEDEF: uint ULONG TYPEDEF: uint ULONG
TYPEDEF: ulong ULONG_PTR TYPEDEF: ulong ULONG_PTR
TYPEDEF: ulong* PULONG_PTR TYPEDEF: ulong* PULONG_PTR
TYPEDEF: void VOID TYPEDEF: void VOID
TYPEDEF: void* PVOID TYPEDEF: void* PVOID
TYPEDEF: void* LPVOID TYPEDEF: void* LPVOID
TYPEDEF: void* LPCVOID TYPEDEF: void* LPCVOID
TYPEDEF: float FLOAT TYPEDEF: float FLOAT
! The following is commented out for two reasons. ! The following is commented out for two reasons.
! 1) all of the code in both branches will be run because TYPEDEF: is a ! 1) all of the code in both branches will be run because TYPEDEF: is a
! parsing word ! parsing word
! 2) we are waiting on gcc to be ported to win64/msys ! 2) we are waiting on gcc to be ported to win64/msys
! 3) the TYPEDEF:s are probably wrong. ! 3) the TYPEDEF:s are probably wrong.
! win64? [ ! win64? [
! ! TODO: check these! ! ! TODO: check these!
! TYPEDEF: INT32 HALF_PTR ! TYPEDEF: INT32 HALF_PTR
! TYPEDEF: UINT32 UHALF_PTR ! TYPEDEF: UINT32 UHALF_PTR
! TYPEDEF: long INT_PTR ! TYPEDEF: long INT_PTR
! TYPEDEF: ulong UINT_PTR ! TYPEDEF: ulong UINT_PTR
! TYPEDEF: longlong LONG_PTR ! 64bit ! TYPEDEF: longlong LONG_PTR ! 64bit
! TYPEDEF: ulonglong ULONG_PTR ! 64bit ! TYPEDEF: ulonglong ULONG_PTR ! 64bit
! TYPEDEF: int INT32 ! TYPEDEF: int INT32
! TYPEDEF: uint UINT32 ! TYPEDEF: uint UINT32
! TYPEDEF: uint DWORD32 ! TYPEDEF: uint DWORD32
! TYPEDEF: uint ULONG32 ! TYPEDEF: uint ULONG32
! TYPEDEF: ulong ULONG64 ! TYPEDEF: ulong ULONG64
! TYPEDEF: int* POINTER_32 ! TYPEDEF: int* POINTER_32
! TYPEDEF: long* POINTER_64 ! TYPEDEF: long* POINTER_64
! TYPEDEF: longlong INT64 ! TYPEDEF: longlong INT64
! TYPEDEF: ulonglong UINT64 ! TYPEDEF: ulonglong UINT64
! TYPEDEF: longlong LONGLONG ! 64bit ! TYPEDEF: longlong LONGLONG ! 64bit
! TYPEDEF: ulonglong ULONGLONG ! TYPEDEF: ulonglong ULONGLONG
! TYPEDEF: longlong LONG64 ! TYPEDEF: longlong LONG64
! TYPEDEF: ulonglong DWORD64 ! TYPEDEF: ulonglong DWORD64
! ] [ ! ] [
! Correct for win32 ! Correct for win32
TYPEDEF: short HALF_PTR TYPEDEF: short HALF_PTR
TYPEDEF: ushort UHALF_PTR TYPEDEF: ushort UHALF_PTR
TYPEDEF: int INT_PTR TYPEDEF: int INT_PTR
TYPEDEF: uint UINT_PTR TYPEDEF: uint UINT_PTR
TYPEDEF: int LONG_PTR TYPEDEF: int LONG_PTR
TYPEDEF: ulong ULONG_PTR TYPEDEF: ulong ULONG_PTR
TYPEDEF: int INT32 TYPEDEF: int INT32
TYPEDEF: uint UINT32 TYPEDEF: uint UINT32
TYPEDEF: uint DWORD32 TYPEDEF: uint DWORD32
TYPEDEF: ulong ULONG32 TYPEDEF: ulong ULONG32
TYPEDEF: ulonglong ULONG64 TYPEDEF: ulonglong ULONG64
TYPEDEF: long* POINTER_32 TYPEDEF: long* POINTER_32
TYPEDEF: longlong* POINTER_64 TYPEDEF: longlong* POINTER_64
TYPEDEF: longlong INT64 TYPEDEF: longlong INT64
TYPEDEF: ulonglong UINT64 TYPEDEF: ulonglong UINT64
TYPEDEF: longlong LONGLONG TYPEDEF: longlong LONGLONG
TYPEDEF: ulonglong ULONGLONG TYPEDEF: ulonglong ULONGLONG
TYPEDEF: longlong LONG64 TYPEDEF: longlong LONG64
TYPEDEF: ulonglong DWORD64 TYPEDEF: ulonglong DWORD64
! ] if ! ] if
! unicode? [ ! unicode? [
! TYPEDEF: WCHAR TBYTE ! TYPEDEF: WCHAR TBYTE
! TYPEDEF: WCHAR TCHAR ! TYPEDEF: WCHAR TCHAR
! ] [ ! ] [
TYPEDEF: uchar TBYTE TYPEDEF: uchar TBYTE
TYPEDEF: char TCHAR TYPEDEF: char TCHAR
! ] if ! ] if
! Below down is based on the above definitions ! Below down is based on the above definitions
! There should be no 32/64bit issues ! There should be no 32/64bit issues
TYPEDEF: WORD ATOM TYPEDEF: WORD ATOM
TYPEDEF: BYTE BOOLEAN TYPEDEF: BYTE BOOLEAN
! TYPEDEF: __stdcall CALLBACK ! TYPEDEF: __stdcall CALLBACK
TYPEDEF: DWORD COLORREF TYPEDEF: DWORD COLORREF
TYPEDEF: ULONGLONG DWORDLONG TYPEDEF: ULONGLONG DWORDLONG
TYPEDEF: ULONG_PTR DWORD_PTR TYPEDEF: ULONG_PTR DWORD_PTR
TYPEDEF: PVOID HANDLE TYPEDEF: PVOID HANDLE
TYPEDEF: HANDLE HACCEL TYPEDEF: HANDLE HACCEL
TYPEDEF: HANDLE HBITMAP TYPEDEF: HANDLE HBITMAP
TYPEDEF: HANDLE HBRUSH TYPEDEF: HANDLE HBRUSH
TYPEDEF: HANDLE HCOLORSPACE TYPEDEF: HANDLE HCOLORSPACE
TYPEDEF: HANDLE HCONV TYPEDEF: HANDLE HCONV
TYPEDEF: HANDLE HCONVLIST TYPEDEF: HANDLE HCONVLIST
TYPEDEF: HANDLE HICON TYPEDEF: HANDLE HICON
TYPEDEF: HICON HCURSOR TYPEDEF: HICON HCURSOR
TYPEDEF: HANDLE HDC TYPEDEF: HANDLE HDC
TYPEDEF: HANDLE HDDEDATA TYPEDEF: HANDLE HDDEDATA
TYPEDEF: HANDLE HDESK TYPEDEF: HANDLE HDESK
TYPEDEF: HANDLE HDROP TYPEDEF: HANDLE HDROP
TYPEDEF: HANDLE HDWP TYPEDEF: HANDLE HDWP
TYPEDEF: HANDLE HENMETAFILE TYPEDEF: HANDLE HENMETAFILE
TYPEDEF: HANDLE HFONT TYPEDEF: HANDLE HFONT
TYPEDEF: HANDLE HGDIOBJ TYPEDEF: HANDLE HGDIOBJ
TYPEDEF: HANDLE HGLOBAL TYPEDEF: HANDLE HGLOBAL
TYPEDEF: HANDLE HHOOK TYPEDEF: HANDLE HHOOK
TYPEDEF: HANDLE HINSTANCE TYPEDEF: HANDLE HINSTANCE
TYPEDEF: HANDLE HKEY TYPEDEF: HANDLE HKEY
TYPEDEF: HANDLE HKL TYPEDEF: HANDLE HKL
TYPEDEF: HANDLE HLOCAL TYPEDEF: HANDLE HLOCAL
TYPEDEF: HANDLE HMENU TYPEDEF: HANDLE HMENU
TYPEDEF: HANDLE HMETAFILE TYPEDEF: HANDLE HMETAFILE
TYPEDEF: HINSTANCE HMODULE TYPEDEF: HINSTANCE HMODULE
TYPEDEF: HANDLE HMONITOR TYPEDEF: HANDLE HMONITOR
TYPEDEF: HANDLE HPALETTE TYPEDEF: HANDLE HPALETTE
TYPEDEF: HANDLE HPEN TYPEDEF: HANDLE HPEN
TYPEDEF: LONG HRESULT TYPEDEF: LONG HRESULT
TYPEDEF: HANDLE HRGN TYPEDEF: HANDLE HRGN
TYPEDEF: HANDLE HRSRC TYPEDEF: HANDLE HRSRC
TYPEDEF: HANDLE HSZ TYPEDEF: HANDLE HSZ
TYPEDEF: HANDLE WINSTA ! MS docs say typedef HANDLE WINSTA ; TYPEDEF: HANDLE WINSTA ! MS docs say typedef HANDLE WINSTA ;
TYPEDEF: HANDLE HWINSTA ! typo?? TYPEDEF: HANDLE HWINSTA ! typo??
TYPEDEF: HANDLE HWND TYPEDEF: HANDLE HWND
TYPEDEF: WORD LANGID TYPEDEF: WORD LANGID
TYPEDEF: DWORD LCID TYPEDEF: DWORD LCID
TYPEDEF: DWORD LCTYPE TYPEDEF: DWORD LCTYPE
TYPEDEF: DWORD LGRPID TYPEDEF: DWORD LGRPID
TYPEDEF: LONG_PTR LPARAM TYPEDEF: LONG_PTR LPARAM
TYPEDEF: BOOL* LPBOOL TYPEDEF: BOOL* LPBOOL
TYPEDEF: BYTE* LPBYTE TYPEDEF: BYTE* LPBYTE
TYPEDEF: DWORD* LPCOLORREF TYPEDEF: DWORD* LPCOLORREF
TYPEDEF: CHAR* LPCSTR TYPEDEF: CHAR* LPCSTR
TYPEDEF: WCHAR* LPCWSTR TYPEDEF: WCHAR* LPCWSTR
TYPEDEF: WCHAR* LPWSTR TYPEDEF: WCHAR* LPWSTR
unicode? [ unicode? [
TYPEDEF: LPCWSTR LPCTSTR TYPEDEF: LPCWSTR LPCTSTR
TYPEDEF: LPWSTR LPTSTR TYPEDEF: LPWSTR LPTSTR
TYPEDEF: LPCWSTR PCTSTR TYPEDEF: LPCWSTR PCTSTR
TYPEDEF: LPWSTR PTSTR TYPEDEF: LPWSTR PTSTR
] [ ] [
TYPEDEF: LPCSTR LPCTSTR TYPEDEF: LPCSTR LPCTSTR
TYPEDEF: LPSTR LPTSTR TYPEDEF: LPSTR LPTSTR
TYPEDEF: LPCSTR PCTSTR TYPEDEF: LPCSTR PCTSTR
TYPEDEF: LPSTR PTSTR TYPEDEF: LPSTR PTSTR
] if ] if
TYPEDEF: DWORD* LPDWORD TYPEDEF: DWORD* LPDWORD
TYPEDEF: HANDLE* LPHANDLE TYPEDEF: HANDLE* LPHANDLE
TYPEDEF: CHAR* LPSTR TYPEDEF: CHAR* LPSTR
TYPEDEF: WORD* LPWORD TYPEDEF: WORD* LPWORD
TYPEDEF: WCHAR* LPWSTR TYPEDEF: WCHAR* LPWSTR
TYPEDEF: LONG_PTR LRESULT TYPEDEF: LONG_PTR LRESULT
TYPEDEF: BOOL* PBOOL TYPEDEF: BOOL* PBOOL
TYPEDEF: BOOLEAN* PBOOLEAN TYPEDEF: BOOLEAN* PBOOLEAN
TYPEDEF: BYTE* PBYTE TYPEDEF: BYTE* PBYTE
TYPEDEF: CHAR* PCHAR TYPEDEF: CHAR* PCHAR
TYPEDEF: CHAR* PCSTR TYPEDEF: CHAR* PCSTR
TYPEDEF: WCHAR* PCWSTR TYPEDEF: WCHAR* PCWSTR
TYPEDEF: DWORD* PDWORD TYPEDEF: DWORD* PDWORD
TYPEDEF: DWORDLONG* PDWORDLONG TYPEDEF: DWORDLONG* PDWORDLONG
TYPEDEF: DWORD_PTR* PDWORD_PTR TYPEDEF: DWORD_PTR* PDWORD_PTR
TYPEDEF: DWORD32* PDWORD32 TYPEDEF: DWORD32* PDWORD32
TYPEDEF: DWORD64* PDWORD64 TYPEDEF: DWORD64* PDWORD64
TYPEDEF: FLOAT* PFLOAT TYPEDEF: FLOAT* PFLOAT
TYPEDEF: HALF_PTR* PHALF_PTR TYPEDEF: HALF_PTR* PHALF_PTR
TYPEDEF: HANDLE* PHANDLE TYPEDEF: HANDLE* PHANDLE
TYPEDEF: HKEY* PHKEY TYPEDEF: HKEY* PHKEY
TYPEDEF: INT_PTR* PINT_PTR TYPEDEF: INT_PTR* PINT_PTR
TYPEDEF: INT32* PINT32 TYPEDEF: INT32* PINT32
TYPEDEF: INT64* PINT64 TYPEDEF: INT64* PINT64
TYPEDEF: PDWORD PLCID TYPEDEF: PDWORD PLCID
TYPEDEF: LONG* PLONG TYPEDEF: LONG* PLONG
TYPEDEF: LONGLONG* PLONGLONG TYPEDEF: LONGLONG* PLONGLONG
TYPEDEF: LONG_PTR* PLONG_PTR TYPEDEF: LONG_PTR* PLONG_PTR
TYPEDEF: LONG32* PLONG32 TYPEDEF: LONG32* PLONG32
TYPEDEF: LONG64* PLONG64 TYPEDEF: LONG64* PLONG64
TYPEDEF: SHORT* PSHORT TYPEDEF: SHORT* PSHORT
TYPEDEF: SIZE_T* PSIZE_T TYPEDEF: SIZE_T* PSIZE_T
TYPEDEF: SSIZE_T* PSSIZE_T TYPEDEF: SSIZE_T* PSSIZE_T
TYPEDEF: CHAR* PSTR TYPEDEF: CHAR* PSTR
TYPEDEF: TBYTE* PTBYTE TYPEDEF: TBYTE* PTBYTE
TYPEDEF: TCHAR* PTCHAR TYPEDEF: TCHAR* PTCHAR
TYPEDEF: UCHAR* PUCHAR TYPEDEF: UCHAR* PUCHAR
TYPEDEF: UHALF_PTR* PUHALF_PTR TYPEDEF: UHALF_PTR* PUHALF_PTR
TYPEDEF: UINT* PUINT TYPEDEF: UINT* PUINT
TYPEDEF: UINT_PTR* PUINT_PTR TYPEDEF: UINT_PTR* PUINT_PTR
TYPEDEF: UINT32* PUINT32 TYPEDEF: UINT32* PUINT32
TYPEDEF: UINT64* PUINT64 TYPEDEF: UINT64* PUINT64
TYPEDEF: ULONG* PULONG TYPEDEF: ULONG* PULONG
TYPEDEF: ULONGLONG* PULONGLONG TYPEDEF: ULONGLONG* PULONGLONG
TYPEDEF: ULONG_PTR* PULONG_PTR TYPEDEF: ULONG_PTR* PULONG_PTR
TYPEDEF: ULONG32* PULONG32 TYPEDEF: ULONG32* PULONG32
TYPEDEF: ULONG64* PULONG64 TYPEDEF: ULONG64* PULONG64
TYPEDEF: USHORT* PUSHORT TYPEDEF: USHORT* PUSHORT
TYPEDEF: WCHAR* PWCHAR TYPEDEF: WCHAR* PWCHAR
TYPEDEF: WORD* PWORD TYPEDEF: WORD* PWORD
TYPEDEF: WCHAR* PWSTR TYPEDEF: WCHAR* PWSTR
TYPEDEF: HANDLE SC_HANDLE TYPEDEF: HANDLE SC_HANDLE
TYPEDEF: LPVOID SC_LOCK TYPEDEF: LPVOID SC_LOCK
TYPEDEF: HANDLE SERVICE_STATUS_HANDLE TYPEDEF: HANDLE SERVICE_STATUS_HANDLE
TYPEDEF: ULONG_PTR SIZE_T TYPEDEF: ULONG_PTR SIZE_T
TYPEDEF: LONG_PTR SSIZE_T TYPEDEF: LONG_PTR SSIZE_T
TYPEDEF: LONGLONG USN TYPEDEF: LONGLONG USN
! TYPEDEF: __stdcall WINAPI ! TYPEDEF: __stdcall WINAPI
TYPEDEF: UINT_PTR WPARAM TYPEDEF: UINT_PTR WPARAM
TYPEDEF: RECT* LPRECT TYPEDEF: RECT* LPRECT
TYPEDEF: void* PWNDCLASS TYPEDEF: void* PWNDCLASS
TYPEDEF: void* PWNDCLASSEX TYPEDEF: void* PWNDCLASSEX
TYPEDEF: void* WNDPROC TYPEDEF: void* WNDPROC
! typedef LRESULT (CALLBACK* WNDPROC)(HWND, UINT, WPARAM, LPARAM); ! typedef LRESULT (CALLBACK* WNDPROC)(HWND, UINT, WPARAM, LPARAM);
BEGIN-STRUCT: WNDCLASS BEGIN-STRUCT: WNDCLASS
FIELD: UINT style FIELD: UINT style
FIELD: WNDPROC lpfnWndProc FIELD: WNDPROC lpfnWndProc
FIELD: int cbClsExtra FIELD: int cbClsExtra
FIELD: int cbWndExtra FIELD: int cbWndExtra
FIELD: HINSTANCE hInstance FIELD: HINSTANCE hInstance
FIELD: HICON hIcon FIELD: HICON hIcon
FIELD: HCURSOR hCursor FIELD: HCURSOR hCursor
FIELD: HBRUSH hbrBackground FIELD: HBRUSH hbrBackground
FIELD: LPCTSTR lpszMenuName FIELD: LPCTSTR lpszMenuName
FIELD: LPCTSTR lpszClassName FIELD: LPCTSTR lpszClassName
END-STRUCT END-STRUCT
BEGIN-STRUCT: WNDCLASSEX BEGIN-STRUCT: WNDCLASSEX
FIELD: UINT cbSize FIELD: UINT cbSize
FIELD: UINT style FIELD: UINT style
FIELD: WNDPROC lpfnWndProc FIELD: WNDPROC lpfnWndProc
FIELD: int cbClsExtra FIELD: int cbClsExtra
FIELD: int cbWndExtra FIELD: int cbWndExtra
FIELD: HINSTANCE hInstance FIELD: HINSTANCE hInstance
FIELD: HICON hIcon FIELD: HICON hIcon
FIELD: HCURSOR hCursor FIELD: HCURSOR hCursor
FIELD: HBRUSH hbrBackground FIELD: HBRUSH hbrBackground
FIELD: LPCTSTR lpszMenuName FIELD: LPCTSTR lpszMenuName
FIELD: LPCTSTR lpszClassName FIELD: LPCTSTR lpszClassName
FIELD: HICON hIconSm FIELD: HICON hIconSm
END-STRUCT END-STRUCT
BEGIN-STRUCT: RECT BEGIN-STRUCT: RECT
FIELD: LONG left FIELD: LONG left
FIELD: LONG top FIELD: LONG top
FIELD: LONG right FIELD: LONG right
FIELD: LONG bottom FIELD: LONG bottom
END-STRUCT END-STRUCT
BEGIN-STRUCT: PAINTSTRUCT BEGIN-STRUCT: PAINTSTRUCT
FIELD: HDC hdc FIELD: HDC hdc
FIELD: BOOL fErase FIELD: BOOL fErase
FIELD: RECT rcPaint FIELD: RECT rcPaint
FIELD: BOOL fRestore FIELD: BOOL fRestore
FIELD: BOOL fIncUpdate FIELD: BOOL fIncUpdate
FIELD: BYTE rgbReserved[32] FIELD: BYTE rgbReserved[32]
END-STRUCT END-STRUCT
TYPEDEF: PAINTSTRUCT* LPPAINTSTRUCT TYPEDEF: PAINTSTRUCT* LPPAINTSTRUCT
BEGIN-STRUCT: POINT BEGIN-STRUCT: POINT
FIELD: LONG x FIELD: LONG x
FIELD: LONG y FIELD: LONG y
END-STRUCT END-STRUCT
BEGIN-STRUCT: MSG BEGIN-STRUCT: MSG
FIELD: HWND hWnd FIELD: HWND hWnd
FIELD: UINT message FIELD: UINT message
FIELD: WPARAM wParam FIELD: WPARAM wParam
FIELD: LPARAM lParam FIELD: LPARAM lParam
FIELD: DWORD time FIELD: DWORD time
FIELD: POINT pt FIELD: POINT pt
END-STRUCT END-STRUCT
TYPEDEF: MSG* LPMSG TYPEDEF: MSG* LPMSG
BEGIN-STRUCT: PIXELFORMATDESCRIPTOR BEGIN-STRUCT: PIXELFORMATDESCRIPTOR
FIELD: WORD nSize FIELD: WORD nSize
FIELD: WORD nVersion FIELD: WORD nVersion
FIELD: DWORD dwFlags FIELD: DWORD dwFlags
FIELD: BYTE iPixelType FIELD: BYTE iPixelType
FIELD: BYTE cColorBits FIELD: BYTE cColorBits
FIELD: BYTE cRedBits FIELD: BYTE cRedBits
FIELD: BYTE cRedShift FIELD: BYTE cRedShift
FIELD: BYTE cGreenBits FIELD: BYTE cGreenBits
FIELD: BYTE cGreenShift FIELD: BYTE cGreenShift
FIELD: BYTE cBlueBits FIELD: BYTE cBlueBits
FIELD: BYTE cBlueShift FIELD: BYTE cBlueShift
FIELD: BYTE cAlphaBits FIELD: BYTE cAlphaBits
FIELD: BYTE cAlphaShift FIELD: BYTE cAlphaShift
FIELD: BYTE cAccumBits FIELD: BYTE cAccumBits
FIELD: BYTE cAccumRedBits FIELD: BYTE cAccumRedBits
FIELD: BYTE cAccumGreenBits FIELD: BYTE cAccumGreenBits
FIELD: BYTE cAccumBlueBits FIELD: BYTE cAccumBlueBits
FIELD: BYTE cAccumAlphaBits FIELD: BYTE cAccumAlphaBits
FIELD: BYTE cDepthBits FIELD: BYTE cDepthBits
FIELD: BYTE cStencilBits FIELD: BYTE cStencilBits
FIELD: BYTE cAuxBuffers FIELD: BYTE cAuxBuffers
FIELD: BYTE iLayerType FIELD: BYTE iLayerType
FIELD: BYTE bReserved FIELD: BYTE bReserved
FIELD: DWORD dwLayerMask FIELD: DWORD dwLayerMask
FIELD: DWORD dwVisibleMask FIELD: DWORD dwVisibleMask
FIELD: DWORD dwDamageMask FIELD: DWORD dwDamageMask
END-STRUCT END-STRUCT
BEGIN-STRUCT: RECT BEGIN-STRUCT: RECT
FIELD: LONG left FIELD: LONG left
FIELD: LONG top FIELD: LONG top
FIELD: LONG right FIELD: LONG right
FIELD: LONG bottom FIELD: LONG bottom
END-STRUCT END-STRUCT
TYPEDEF: RECT* PRECT TYPEDEF: RECT* PRECT
TYPEDEF: RECT* LPRECT TYPEDEF: RECT* LPRECT
TYPEDEF: PIXELFORMATDESCRIPTOR PFD TYPEDEF: PIXELFORMATDESCRIPTOR PFD
TYPEDEF: PFD* LPPFD TYPEDEF: PFD* LPPFD
TYPEDEF: HANDLE HGLRC TYPEDEF: HANDLE HGLRC
TYPEDEF: HANDLE HRGN TYPEDEF: HANDLE HRGN

650
library/ui/windows/ui.factor
View File

@ -1,325 +1,325 @@
! Copyright (C) 2005, 2006 Doug Coleman. ! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays errors freetype gadgets gadgets-launchpad USING: alien arrays errors freetype gadgets gadgets-launchpad
gadgets-listener hashtables io kernel math namespaces prettyprint gadgets-listener hashtables io kernel math namespaces prettyprint
sequences strings vectors words win32-api win32-api-messages ; sequences strings vectors words win32-api win32-api-messages ;
USING: inspector threads memory ; USING: inspector threads memory ;
IN: win32 IN: win32
! world-handle is a <win> ! world-handle is a <win>
TUPLE: win hWnd hDC hRC world ; TUPLE: win hWnd hDC hRC world ;
SYMBOL: msg-obj SYMBOL: msg-obj
SYMBOL: class-name SYMBOL: class-name
: random-class-name "Factor" 100000000 random-int unparse append ; : random-class-name "Factor" 100000000 random-int unparse append ;
: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline : ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
: adjust-RECT ( RECT -- ) : adjust-RECT ( RECT -- )
style 0 ex-style AdjustWindowRectEx win32-error=0 ; style 0 ex-style AdjustWindowRectEx win32-error=0 ;
: make-RECT ( width height -- RECT ) : make-RECT ( width height -- RECT )
"RECT" <c-object> [ set-RECT-bottom ] keep [ set-RECT-right ] keep ; "RECT" <c-object> [ set-RECT-bottom ] keep [ set-RECT-right ] keep ;
: make-adjusted-RECT ( width height -- RECT ) : make-adjusted-RECT ( width height -- RECT )
make-RECT dup adjust-RECT ; make-RECT dup adjust-RECT ;
: get-RECT-dimensions ( RECT -- width height ) : get-RECT-dimensions ( RECT -- width height )
[ RECT-right ] keep [ RECT-left - ] keep [ RECT-right ] keep [ RECT-left - ] keep
[ RECT-bottom ] keep RECT-top - ; [ RECT-bottom ] keep RECT-top - ;
: handle-wm-paint ( hWnd uMsg wParam lParam -- ) : handle-wm-paint ( hWnd uMsg wParam lParam -- )
#! wParam and lParam are unused #! wParam and lParam are unused
#! only paint if width/height both > 0 #! only paint if width/height both > 0
3drop window dup rect-dim first2 [ 0 > ] 2apply and [ draw-world ] when ; 3drop window dup rect-dim first2 [ 0 > ] 2apply and [ draw-world ] when ;
: handle-wm-size ( hWnd uMsg wParam lParam -- ) : handle-wm-size ( hWnd uMsg wParam lParam -- )
[ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array [ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array
2nip 2nip
dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ] if ; dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ] if ;
: wm-keydown-codes ( n -- key ) : wm-keydown-codes ( n -- key )
H{ H{
{ 8 "BACKSPACE" } { 8 "BACKSPACE" }
{ 9 "TAB" } { 9 "TAB" }
{ 13 "RETURN" } { 13 "RETURN" }
{ 27 "ESCAPE" } { 27 "ESCAPE" }
{ 33 "PAGE_UP" } { 33 "PAGE_UP" }
{ 34 "PAGE_DOWN" } { 34 "PAGE_DOWN" }
{ 35 "END" } { 35 "END" }
{ 36 "HOME" } { 36 "HOME" }
{ 37 "LEFT" } { 37 "LEFT" }
{ 38 "UP" } { 38 "UP" }
{ 39 "RIGHT" } { 39 "RIGHT" }
{ 40 "DOWN" } { 40 "DOWN" }
{ 45 "INSERT" } { 45 "INSERT" }
{ 46 "DELETE" } { 46 "DELETE" }
} ; } ;
: key-state-down? : key-state-down?
GetKeyState 1 16 shift bitand 0 > ; GetKeyState 1 16 shift bitand 0 > ;
: left-shift? ( -- ? ) VK_LSHIFT key-state-down? ; : left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
: left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ; : left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
: left-alt? ( -- ? ) VK_LMENU key-state-down? ; : left-alt? ( -- ? ) VK_LMENU key-state-down? ;
: right-shift? ( -- ? ) VK_RSHIFT key-state-down? ; : right-shift? ( -- ? ) VK_RSHIFT key-state-down? ;
: right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ; : right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ;
: right-alt? ( -- ? ) VK_RMENU key-state-down? ; : right-alt? ( -- ? ) VK_RMENU key-state-down? ;
: shift? ( -- ? ) left-shift? right-shift? or ; : shift? ( -- ? ) left-shift? right-shift? or ;
: ctrl? ( -- ? ) left-ctrl? right-ctrl? or ; : ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
: alt? ( -- ? ) left-alt? right-alt? or ; : alt? ( -- ? ) left-alt? right-alt? or ;
: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ; : caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
: lower-case? ( -- ? ) shift? caps-lock? and caps-lock? not shift? not and or ; : lower-case? ( -- ? ) shift? caps-lock? and caps-lock? not shift? not and or ;
: key-modifiers ( -- list ) : key-modifiers ( -- list )
[ [
shift? [ S+ , ] when shift? [ S+ , ] when
ctrl? [ C+ , ] when ctrl? [ C+ , ] when
alt? [ A+ , ] when alt? [ A+ , ] when
] { } make [ empty? not ] keep f ? ; ] { } make [ empty? not ] keep f ? ;
: exclude-keys : exclude-keys
H{ H{
! { 8 "BACKSPACE" } ! { 8 "BACKSPACE" }
! { 9 "TAB" } ! { 9 "TAB" }
{ 16 "SHIFT" } { 16 "SHIFT" }
{ 17 "CTRL" } { 17 "CTRL" }
{ 18 "ALT" } { 18 "ALT" }
{ 20 "CAPS-LOCK" } { 20 "CAPS-LOCK" }
{ 27 "ESCAPE" } { 27 "ESCAPE" }
} ; } ;
: exclude-key? ( n -- bool ) exclude-keys hash* nip ; : exclude-key? ( n -- bool ) exclude-keys hash* nip ;
: handle-key? ( n -- bool ) wm-keydown-codes hash* nip ; : handle-key? ( n -- bool ) wm-keydown-codes hash* nip ;
: keystroke>gesture ( n -- <key-down> ) : keystroke>gesture ( n -- <key-down> )
dup wm-keydown-codes hash* [ nip ] [ drop ch>string lower-case? [ >lower ] when ] if dup wm-keydown-codes hash* [ nip ] [ drop ch>string lower-case? [ >lower ] when ] if
key-modifiers swap ; key-modifiers swap ;
SYMBOL: lParam SYMBOL: lParam
SYMBOL: wParam SYMBOL: wParam
SYMBOL: uMsg SYMBOL: uMsg
SYMBOL: hWnd SYMBOL: hWnd
: get-focus ( hWnd -- gadget ) : get-focus ( hWnd -- gadget )
window world-focus ; window world-focus ;
: handle-wm-keydown ( hWnd uMsg wParam lParam -- ) : handle-wm-keydown ( hWnd uMsg wParam lParam -- )
lParam set wParam set uMsg set hWnd set lParam set wParam set uMsg set hWnd set
wParam get exclude-key? [ wParam get exclude-key? [
wParam get keystroke>gesture <key-down> wParam get keystroke>gesture <key-down>
hWnd get get-focus handle-gesture [ hWnd get get-focus handle-gesture [
wParam get ch>string lower-case? [ >lower ] when wParam get ch>string lower-case? [ >lower ] when
hWnd get get-focus user-input hWnd get get-focus user-input
] when ] when
] unless ; ] unless ;
: handle-wm-keyup ( hWnd uMsg wParam lParam -- ) : handle-wm-keyup ( hWnd uMsg wParam lParam -- )
lParam set wParam set uMsg set hWnd set lParam set wParam set uMsg set hWnd set
wParam get keystroke>gesture <key-up> hWnd get get-focus handle-gesture wParam get keystroke>gesture <key-up> hWnd get get-focus handle-gesture
drop ; drop ;
: cleanup-window ( handle -- ) : cleanup-window ( handle -- )
[ win-hRC wglDeleteContext win32-error=0 ] keep [ win-hRC wglDeleteContext win32-error=0 ] keep
[ win-hWnd ] keep win-hDC ReleaseDC win32-error=0 ; [ win-hWnd ] keep win-hDC ReleaseDC win32-error=0 ;
: handle-wm-destroy ( hWnd uMsg wParam lParam -- ) : handle-wm-destroy ( hWnd uMsg wParam lParam -- )
3drop 3drop
window [ world-handle ] keep window [ world-handle ] keep
[ close-world ] keep [ close-world ] keep
[ drop win-hWnd unregister-window ] 2keep [ drop win-hWnd unregister-window ] 2keep
drop cleanup-window drop cleanup-window
0 PostQuitMessage ; 0 PostQuitMessage ;
: handle-wm-set-focus ( hWnd uMsg wParam lParam -- ) : handle-wm-set-focus ( hWnd uMsg wParam lParam -- )
3drop window focus-world ; 3drop window focus-world ;
: handle-wm-kill-focus ( hWnd uMsg wParam lParam -- ) : handle-wm-kill-focus ( hWnd uMsg wParam lParam -- )
3drop window unfocus-world ; 3drop window unfocus-world ;
: mouse-button ( uMsg -- n ) : mouse-button ( uMsg -- n )
{ {
{ [ dup WM_LBUTTONDOWN = ] [ drop 1 ] } { [ dup WM_LBUTTONDOWN = ] [ drop 1 ] }
{ [ dup WM_LBUTTONUP = ] [ drop 1 ] } { [ dup WM_LBUTTONUP = ] [ drop 1 ] }
{ [ dup WM_MBUTTONDOWN = ] [ drop 2 ] } { [ dup WM_MBUTTONDOWN = ] [ drop 2 ] }
{ [ dup WM_MBUTTONUP = ] [ drop 2 ] } { [ dup WM_MBUTTONUP = ] [ drop 2 ] }
{ [ dup WM_RBUTTONDOWN = ] [ drop 3 ] } { [ dup WM_RBUTTONDOWN = ] [ drop 3 ] }
{ [ dup WM_RBUTTONUP = ] [ drop 3 ] } { [ dup WM_RBUTTONUP = ] [ drop 3 ] }
{ [ t ] [ "bad button" throw ] } { [ t ] [ "bad button" throw ] }
} cond ; } cond ;
: mouse-coordinate ( lParam -- seq ) [ lo-word ] keep hi-word 2array ; : mouse-coordinate ( lParam -- seq ) [ lo-word ] keep hi-word 2array ;
: mouse-wheel ( lParam -- n ) hi-word 0 > 1 -1 ? ; : mouse-wheel ( lParam -- n ) hi-word 0 > 1 -1 ? ;
: prepare-mouse ( hWnd uMsg wParam lParam -- world ) : prepare-mouse ( hWnd uMsg wParam lParam -- world )
nip >r mouse-button r> mouse-coordinate rot window ; nip >r mouse-button r> mouse-coordinate rot window ;
: handle-wm-buttondown ( hWnd uMsg wParam lParam -- ) : handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
>r pick SetCapture drop r> >r pick SetCapture drop r>
prepare-mouse send-button-down ; prepare-mouse send-button-down ;
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- ) : handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
ReleaseCapture drop ReleaseCapture drop
prepare-mouse send-button-up ; prepare-mouse send-button-up ;
: handle-wm-mousemove ( hWnd uMsg wParam lParam -- ) : handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
2nip mouse-coordinate swap window move-hand fire-motion ; 2nip mouse-coordinate swap window move-hand fire-motion ;
: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- ) : handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
mouse-coordinate >r mouse-wheel nip r> rot window send-wheel ; mouse-coordinate >r mouse-wheel nip r> rot window send-wheel ;
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- ) : handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
#! message sent if windows needs application to stop dragging #! message sent if windows needs application to stop dragging
3drop drop ReleaseCapture drop ; 3drop drop ReleaseCapture drop ;
: 4dup ( a b c d -- a b c d a b c d ) : 4dup ( a b c d -- a b c d a b c d )
>r >r 2dup r> r> 2swap >r >r 2dup r> r> 2swap ; >r >r 2dup r> r> 2swap >r >r 2dup r> r> 2swap ;
! return 0 if you handle the message, else just let DefWindowProc return its val ! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( hWnd uMsg wParam lParam -- lresult ) : ui-wndproc ( hWnd uMsg wParam lParam -- lresult )
"uint" { "void*" "uint" "long" "long" } [ "uint" { "void*" "uint" "long" "long" } [
[ [
pick pick
! "Message: " write dup get-windows-message-name write ! "Message: " write dup get-windows-message-name write
! " " write dup unparse print flush ! " " write dup unparse print flush
{ {
{ [ dup WM_DESTROY = ] [ drop handle-wm-destroy 0 ] } { [ dup WM_DESTROY = ] [ drop handle-wm-destroy 0 ] }
{ [ dup WM_PAINT = ] { [ dup WM_PAINT = ]
[ drop 4dup handle-wm-paint DefWindowProc ] } [ drop 4dup handle-wm-paint DefWindowProc ] }
{ [ dup WM_SIZE = ] [ drop handle-wm-size 0 ] } { [ dup WM_SIZE = ] [ drop handle-wm-size 0 ] }
! Keyboard events ! Keyboard events
{ [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ] { [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ]
[ drop handle-wm-keydown 0 ] } [ drop handle-wm-keydown 0 ] }
{ [ dup WM_KEYUP = over WM_SYSKEYUP = or ] { [ dup WM_KEYUP = over WM_SYSKEYUP = or ]
[ drop handle-wm-keyup 0 ] } [ drop handle-wm-keyup 0 ] }
{ [ dup WM_SETFOCUS = ] [ drop handle-wm-set-focus 0 ] } { [ dup WM_SETFOCUS = ] [ drop handle-wm-set-focus 0 ] }
{ [ dup WM_KILLFOCUS = ] [ drop handle-wm-kill-focus 0 ] } { [ dup WM_KILLFOCUS = ] [ drop handle-wm-kill-focus 0 ] }
! Mouse events ! Mouse events
{ [ dup WM_LBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] } { [ dup WM_LBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] }
{ [ dup WM_MBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] } { [ dup WM_MBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] }
{ [ dup WM_RBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] } { [ dup WM_RBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] }
{ [ dup WM_LBUTTONUP = ] [ drop handle-wm-buttonup 0 ] } { [ dup WM_LBUTTONUP = ] [ drop handle-wm-buttonup 0 ] }
{ [ dup WM_MBUTTONUP = ] [ drop handle-wm-buttonup 0 ] } { [ dup WM_MBUTTONUP = ] [ drop handle-wm-buttonup 0 ] }
{ [ dup WM_RBUTTONUP = ] [ drop handle-wm-buttonup 0 ] } { [ dup WM_RBUTTONUP = ] [ drop handle-wm-buttonup 0 ] }
{ [ dup WM_MOUSEMOVE = ] [ drop handle-wm-mousemove 0 ] } { [ dup WM_MOUSEMOVE = ] [ drop handle-wm-mousemove 0 ] }
{ [ dup WM_MOUSEWHEEL = ] [ drop handle-wm-mousewheel 0 ] } { [ dup WM_MOUSEWHEEL = ] [ drop handle-wm-mousewheel 0 ] }
{ [ dup WM_CANCELMODE = ] [ drop handle-wm-cancelmode 0 ] } { [ dup WM_CANCELMODE = ] [ drop handle-wm-cancelmode 0 ] }
{ [ t ] [ drop DefWindowProc ] } { [ t ] [ drop DefWindowProc ] }
} cond } cond
] [ error. 0 ] recover ] [ error. 0 ] recover
! "finished handling message" print .s flush ! "finished handling message" print .s flush
] alien-callback ; ] alien-callback ;
: do-events ( -- ) : do-events ( -- )
msg-obj get f 0 0 PM_REMOVE PeekMessage msg-obj get f 0 0 PM_REMOVE PeekMessage
zero? not [ zero? not [
msg-obj get MSG-message WM_QUIT = [ msg-obj get MSG-message WM_QUIT = [
msg-obj get [ TranslateMessage drop ] keep DispatchMessage drop msg-obj get [ TranslateMessage drop ] keep DispatchMessage drop
] unless ] unless
] when ; ] when ;
: event-loop ( -- ) : event-loop ( -- )
! "MSG'D" print flush ! "MSG'D" print flush
windows get empty? [ windows get empty? [
[ do-events ui-step ] ui-try event-loop [ do-events ui-step ] ui-try event-loop
] unless ; ] unless ;
: register-wndclassex ( classname wndproc -- ) : register-wndclassex ( classname wndproc -- )
"WNDCLASSEX" <c-object> "WNDCLASSEX" <c-object>
"WNDCLASSEX" c-size over set-WNDCLASSEX-cbSize "WNDCLASSEX" c-size over set-WNDCLASSEX-cbSize
CS_HREDRAW CS_VREDRAW bitor CS_OWNDC bitor over set-WNDCLASSEX-style CS_HREDRAW CS_VREDRAW bitor CS_OWNDC bitor over set-WNDCLASSEX-style
[ set-WNDCLASSEX-lpfnWndProc ] keep [ set-WNDCLASSEX-lpfnWndProc ] keep
0 over set-WNDCLASSEX-cbClsExtra 0 over set-WNDCLASSEX-cbClsExtra
0 over set-WNDCLASSEX-cbWndExtra 0 over set-WNDCLASSEX-cbWndExtra
f GetModuleHandle over set-WNDCLASSEX-hInstance f GetModuleHandle over set-WNDCLASSEX-hInstance
f IDI_APPLICATION LoadIcon over set-WNDCLASSEX-hIcon f IDI_APPLICATION LoadIcon over set-WNDCLASSEX-hIcon
f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
[ set-WNDCLASSEX-lpszClassName ] keep [ set-WNDCLASSEX-lpszClassName ] keep
RegisterClassEx dup win32-error=0 ; RegisterClassEx dup win32-error=0 ;
: create-window ( width height -- hwnd ) : create-window ( width height -- hwnd )
make-adjusted-RECT make-adjusted-RECT
>r class-name get <malloc-string> f r> >r class-name get <malloc-string> f r>
>r >r >r ex-style r> r> >r >r >r ex-style r> r>
WS_CLIPSIBLINGS WS_CLIPCHILDREN bitor style bitor WS_CLIPSIBLINGS WS_CLIPCHILDREN bitor style bitor
0 0 r> 0 0 r>
get-RECT-dimensions get-RECT-dimensions
f f f GetModuleHandle f CreateWindowEx dup win32-error=0 ; f f f GetModuleHandle f CreateWindowEx dup win32-error=0 ;
: show-window ( hWnd -- ) : show-window ( hWnd -- )
dup SW_SHOW ShowWindow drop ! always succeeds dup SW_SHOW ShowWindow drop ! always succeeds
dup SetForegroundWindow drop dup SetForegroundWindow drop
SetFocus drop ; SetFocus drop ;
: init-win32-ui : init-win32-ui
"MSG" <c-object> msg-obj set "MSG" <c-object> msg-obj set
random-class-name class-name set random-class-name class-name set
class-name get <malloc-string> ui-wndproc class-name get <malloc-string> ui-wndproc
register-wndclassex win32-error=0 ; register-wndclassex win32-error=0 ;
: cleanup-win32-ui ( -- ) : cleanup-win32-ui ( -- )
class-name get <malloc-string> f UnregisterClass drop ; class-name get <malloc-string> f UnregisterClass drop ;
: setup-pixel-format ( hdc -- ) : setup-pixel-format ( hdc -- )
16 make-pfd [ ChoosePixelFormat dup win32-error=0 ] 2keep 16 make-pfd [ ChoosePixelFormat dup win32-error=0 ] 2keep
swapd SetPixelFormat win32-error=0 ; swapd SetPixelFormat win32-error=0 ;
: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0 ; : get-dc ( hWnd -- hDC ) GetDC dup win32-error=0 ;
: get-rc ( hDC -- hRC ) : get-rc ( hDC -- hRC )
dup wglCreateContext dup win32-error=0 dup wglCreateContext dup win32-error=0
[ wglMakeCurrent win32-error=0 ] keep ; [ wglMakeCurrent win32-error=0 ] keep ;
: setup-gl ( hwnd -- hDC hRC ) : setup-gl ( hwnd -- hDC hRC )
get-dc get-dc
dup setup-pixel-format dup setup-pixel-format
dup get-rc ; dup get-rc ;
IN: gadgets IN: gadgets
: open-window* ( world -- ) ! new : open-window* ( world -- ) ! new
[ rect-dim first2 create-window dup setup-gl ] keep [ rect-dim first2 create-window dup setup-gl ] keep
[ <win> ] keep [ <win> ] keep
[ swap win-hWnd register-window ] 2keep [ swap win-hWnd register-window ] 2keep
[ set-world-handle ] 2keep [ set-world-handle ] 2keep
start-world win-hWnd show-window ; start-world win-hWnd show-window ;
: select-gl-context ( handle -- ) : select-gl-context ( handle -- )
[ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0 ; [ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0 ;
: flush-gl-context ( handle -- ) : flush-gl-context ( handle -- )
win-hDC SwapBuffers win32-error=0 ; win-hDC SwapBuffers win32-error=0 ;
! Move window to front ! Move window to front
: raise-window ( world -- ) : raise-window ( world -- )
world-handle win-hWnd SetFocus drop ReleaseCapture drop ; world-handle win-hWnd SetFocus drop ReleaseCapture drop ;
: set-title ( string world -- ) : set-title ( string world -- )
world-handle win-hWnd world-handle win-hWnd
swap <malloc-string> alien-address >r WM_SETTEXT 0 r> SendMessage drop ; swap <malloc-string> alien-address >r WM_SETTEXT 0 r> SendMessage drop ;
IN: shells IN: shells
: ui : ui
[ [
[ [
init-timers init-timers
! init-clipboard ! init-clipboard
init-win32-ui init-win32-ui
restore-windows? [ restore-windows? [
restore-windows restore-windows
] [ ] [
init-ui init-ui
launchpad-window launchpad-window
listener-window listener-window
] if ] if
event-loop event-loop
] with-freetype ] with-freetype
] [ cleanup-win32-ui ] cleanup ; ] [ cleanup-win32-ui ] cleanup ;

2748
library/ui/windows/user32.factor
View File

File diff suppressed because it is too large Load Diff

32
library/ui/windows/utils.factor
View File

@ -1,16 +1,16 @@
! Copyright (C) 2005, 2006 Doug Coleman. ! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
USING: alien parser namespaces kernel syntax words math io prettyprint ; USING: alien parser namespaces kernel syntax words math io prettyprint ;
IN: win32-api IN: win32-api
: win32-error=0 zero? [ win32-error ] when ; : win32-error=0 zero? [ win32-error ] when ;
: win32-error>0 0 > [ win32-error ] when ; : win32-error>0 0 > [ win32-error ] when ;
: win32-error<0 0 < [ win32-error ] when ; : win32-error<0 0 < [ win32-error ] when ;
: win32-error<>0 zero? [ win32-error ] unless ; : win32-error<>0 zero? [ win32-error ] unless ;
: lo-word ( wparam -- lo ) HEX: ffff bitand ; : lo-word ( wparam -- lo ) HEX: ffff bitand ;
: hi-word ( wparam -- hi ) -16 shift ; : hi-word ( wparam -- hi ) -16 shift ;
: msgbox ( str -- ) : msgbox ( str -- )
f swap "DebugMsg" MB_OK MessageBox drop ; f swap "DebugMsg" MB_OK MessageBox drop ;

2010
library/ui/windows/windows-messages.factor
View File

File diff suppressed because it is too large Load Diff