win32.patch
erg
parent
b8a66d6132
commit
ce6d8ae88e
|
|
@ -0,0 +1,66 @@
|
|||
! :folding=indent:collapseFolds=1:
|
||||
|
||||
! $Id: win32-errors.factor,v 1.11 2005/12/22 02:30:00 erg Exp $
|
||||
!
|
||||
! Copyright (C) 2004 Mackenzie Straight.
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions are met:
|
||||
!
|
||||
! 1. Redistributions of source code must retain the above copyright notice,
|
||||
! this list of conditions and the following disclaimer.
|
||||
!
|
||||
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
||||
! this list of conditions and the following disclaimer in the documentation
|
||||
! and/or other materials provided with the distribution.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
||||
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
||||
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
||||
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
||||
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
IN: win32-api
|
||||
USE: errors
|
||||
USE: kernel
|
||||
USE: io-internals
|
||||
USE: math
|
||||
USE: parser
|
||||
USE: alien
|
||||
USE: words
|
||||
USE: sequences
|
||||
|
||||
|
||||
: ERROR_SUCCESS 0 ; inline
|
||||
: ERROR_HANDLE_EOF 38 ; inline
|
||||
: ERROR_IO_PENDING 997 ; inline
|
||||
: WAIT_TIMEOUT 258 ; inline
|
||||
|
||||
: FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 ;
|
||||
: FORMAT_MESSAGE_IGNORE_INSERTS HEX: 00000200 ;
|
||||
: FORMAT_MESSAGE_FROM_STRING HEX: 00000400 ;
|
||||
: FORMAT_MESSAGE_FROM_HMODULE HEX: 00000800 ;
|
||||
: FORMAT_MESSAGE_FROM_SYSTEM HEX: 00001000 ;
|
||||
: FORMAT_MESSAGE_ARGUMENT_ARRAY HEX: 00002000 ;
|
||||
: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF ;
|
||||
|
||||
: MAKELANGID ( primary sub -- lang )
|
||||
10 shift bitor ;
|
||||
|
||||
: LANG_NEUTRAL 0 ;
|
||||
: SUBLANG_DEFAULT 1 ;
|
||||
|
||||
: GetLastError ( -- int )
|
||||
"int" "kernel32" "GetLastError" [ ] alien-invoke ;
|
||||
|
||||
: win32-error-message ( id -- string )
|
||||
"char*" f "error_message" [ "int" ] alien-invoke ;
|
||||
|
||||
: win32-throw-error ( -- )
|
||||
GetLastError win32-error-message throw ;
|
||||
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: alien kernel errors ;
|
||||
IN: win32-api
|
||||
|
||||
LIBRARY: gdi32
|
||||
|
||||
! Stock Logical Objects
|
||||
: WHITE_BRUSH 0 ; inline
|
||||
: LTGRAY_BRUSH 1 ; inline
|
||||
: GRAY_BRUSH 2 ; inline
|
||||
: DKGRAY_BRUSH 3 ; inline
|
||||
: BLACK_BRUSH 4 ; inline
|
||||
: NULL_BRUSH 5 ; inline
|
||||
: HOLLOW_BRUSH NULL_BRUSH ; inline
|
||||
: WHITE_PEN 6 ; inline
|
||||
: BLACK_PEN 7 ; inline
|
||||
: NULL_PEN 8 ; inline
|
||||
: OEM_FIXED_FONT 10 ; inline
|
||||
: ANSI_FIXED_FONT 11 ; inline
|
||||
: ANSI_VAR_FONT 12 ; inline
|
||||
: SYSTEM_FONT 13 ; inline
|
||||
: DEVICE_DEFAULT_FONT 14 ; inline
|
||||
: DEFAULT_PALETTE 15 ; inline
|
||||
: SYSTEM_FIXED_FONT 16 ; inline
|
||||
: DEFAULT_GUI_FONT 17 ; inline
|
||||
: DC_BRUSH 18 ; inline
|
||||
: DC_PEN 19 ; inline
|
||||
|
||||
FUNCTION: HGDIOBJ GetStockObject ( int fnObject ) ;
|
||||
FUNCTION: int ChoosePixelFormat ( HDC hDC, PFD* ppfd ) ;
|
||||
FUNCTION: BOOL SetPixelFormat ( HDC hDC, int iPixelFormat, PFD* ppfd ) ;
|
||||
|
||||
FUNCTION: BOOL SwapBuffers ( HDC hDC ) ;
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,125 @@
|
|||
! $Id: win32-io-internals.factor,v 1.15 2006/01/28 20:49:31 spestov Exp $
|
||||
!
|
||||
! Copyright (C) 2004, 2005 Mackenzie Straight.
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions are met:
|
||||
!
|
||||
! 1. Redistributions of source code must retain the above copyright notice,
|
||||
! this list of conditions and the following disclaimer.
|
||||
!
|
||||
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
||||
! this list of conditions and the following disclaimer in the documentation
|
||||
! and/or other materials provided with the distribution.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
||||
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
||||
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
||||
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
||||
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
IN: win32-io-internals
|
||||
USING: alien arrays errors kernel kernel-internals math namespaces threads
|
||||
vectors win32-api io generic io-internals sequences ;
|
||||
|
||||
SYMBOL: completion-port
|
||||
SYMBOL: io-queue
|
||||
|
||||
TUPLE: io-queue free-list callbacks ;
|
||||
TUPLE: io-callback overlapped quotation stream ;
|
||||
|
||||
GENERIC: expire
|
||||
|
||||
: expected-error? ( -- bool )
|
||||
[
|
||||
ERROR_IO_PENDING ERROR_HANDLE_EOF ERROR_SUCCESS WAIT_TIMEOUT
|
||||
] member? ;
|
||||
|
||||
: handle-io-error ( -- )
|
||||
GetLastError expected-error? [ win32-throw-error ] unless ;
|
||||
|
||||
: queue-error ( len/status -- len/status )
|
||||
GetLastError expected-error? [ drop f ] unless ;
|
||||
|
||||
: add-completion ( handle -- )
|
||||
completion-port get f 1 CreateIoCompletionPort drop ;
|
||||
|
||||
: get-access ( -- file-mode )
|
||||
"file-mode" get first2
|
||||
GENERIC_WRITE 0 ? >r
|
||||
GENERIC_READ 0 ? r> bitor ;
|
||||
|
||||
: get-sharemode ( -- share-mode )
|
||||
FILE_SHARE_READ FILE_SHARE_WRITE bitor ;
|
||||
|
||||
: get-create ( -- creation-disposition )
|
||||
"file-mode" get first2 [
|
||||
[ OPEN_ALWAYS ] [ CREATE_ALWAYS ] if
|
||||
] [
|
||||
[ OPEN_EXISTING ] [ 0 ] if
|
||||
] if ;
|
||||
|
||||
: win32-open-file ( file r w -- handle )
|
||||
[
|
||||
2array "file-mode" set
|
||||
get-access get-sharemode f get-create FILE_FLAG_OVERLAPPED f
|
||||
CreateFile dup INVALID_HANDLE_VALUE = [ win32-throw-error ] when
|
||||
dup add-completion
|
||||
] with-scope ;
|
||||
|
||||
: <overlapped> ( -- overlapped )
|
||||
"overlapped-ext" <malloc-object> ;
|
||||
|
||||
C: io-queue ( -- queue )
|
||||
[ V{ } clone swap set-io-queue-callbacks ] keep ;
|
||||
|
||||
C: io-callback ( -- callback )
|
||||
io-queue get io-queue-callbacks [ push ] 2keep
|
||||
length 1- <overlapped> [ set-overlapped-ext-user-data ] keep
|
||||
swap [ set-io-callback-overlapped ] keep ;
|
||||
|
||||
: alloc-io-callback ( quot stream -- overlapped )
|
||||
io-queue get io-queue-free-list [
|
||||
first2 io-queue get [ set-io-queue-free-list ] keep
|
||||
io-queue-callbacks nth
|
||||
] [ <io-callback> ] if*
|
||||
[ set-io-callback-stream ] keep
|
||||
[ set-io-callback-quotation ] keep
|
||||
io-callback-overlapped ;
|
||||
|
||||
: get-io-callback ( index -- callback )
|
||||
dup io-queue get io-queue-callbacks nth swap
|
||||
io-queue get [ io-queue-free-list 2array ] keep set-io-queue-free-list
|
||||
[ f swap set-io-callback-stream ] keep
|
||||
io-callback-quotation ;
|
||||
|
||||
: (wait-for-io) ( timeout -- error overlapped len )
|
||||
>r completion-port get 0 <int> 0 <int> 0 <int>
|
||||
pick over r> -rot >r >r GetQueuedCompletionStatus r> r> ;
|
||||
|
||||
: overlapped>callback ( overlapped -- callback )
|
||||
*int dup zero? [
|
||||
drop f
|
||||
] [
|
||||
<alien> overlapped-ext-user-data get-io-callback
|
||||
] if ;
|
||||
|
||||
: cancel-timedout ( -- )
|
||||
io-queue get
|
||||
io-queue-callbacks [ io-callback-stream [ expire ] when* ] each ;
|
||||
|
||||
: wait-for-io ( timeout -- callback len )
|
||||
(wait-for-io) overlapped>callback swap *int
|
||||
rot [ queue-error ] unless ;
|
||||
|
||||
: win32-init-io ( -- )
|
||||
stdio off
|
||||
INVALID_HANDLE_VALUE f f 1 CreateIoCompletionPort
|
||||
completion-port set
|
||||
<io-queue> io-queue set ;
|
||||
|
||||
|
|
@ -0,0 +1,124 @@
|
|||
! :folding=indent:collapseFolds=1:
|
||||
|
||||
! $Id: win32-io.factor,v 1.4 2005/07/23 06:11:07 eiz Exp $
|
||||
!
|
||||
! Copyright (C) 2004 Mackenzie Straight.
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions are met:
|
||||
!
|
||||
! 1. Redistributions of source code must retain the above copyright notice,
|
||||
! this list of conditions and the following disclaimer.
|
||||
!
|
||||
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
||||
! this list of conditions and the following disclaimer in the documentation
|
||||
! and/or other materials provided with the distribution.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
||||
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
||||
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
||||
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
||||
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
IN: win32-api
|
||||
USE: kernel
|
||||
USE: alien
|
||||
|
||||
BEGIN-STRUCT: overlapped-ext
|
||||
FIELD: int internal
|
||||
FIELD: int internal-high
|
||||
FIELD: int offset
|
||||
FIELD: int offset-high
|
||||
FIELD: void* event
|
||||
FIELD: int user-data
|
||||
END-STRUCT
|
||||
|
||||
: GENERIC_READ HEX: 80000000 ;
|
||||
: GENERIC_WRITE HEX: 40000000 ;
|
||||
: GENERIC_EXECUTE HEX: 20000000 ;
|
||||
: GENERIC_ALL HEX: 10000000 ;
|
||||
|
||||
: CREATE_NEW 1 ;
|
||||
: CREATE_ALWAYS 2 ;
|
||||
: OPEN_EXISTING 3 ;
|
||||
: OPEN_ALWAYS 4 ;
|
||||
: TRUNCATE_EXISTING 5 ;
|
||||
|
||||
: FILE_SHARE_READ 1 ;
|
||||
: FILE_SHARE_WRITE 2 ;
|
||||
: FILE_SHARE_DELETE 4 ;
|
||||
|
||||
: FILE_FLAG_WRITE_THROUGH HEX: 80000000 ;
|
||||
: FILE_FLAG_OVERLAPPED HEX: 40000000 ;
|
||||
: FILE_FLAG_NO_BUFFERING HEX: 20000000 ;
|
||||
: FILE_FLAG_RANDOM_ACCESS HEX: 10000000 ;
|
||||
: FILE_FLAG_SEQUENTIAL_SCAN HEX: 08000000 ;
|
||||
: FILE_FLAG_DELETE_ON_CLOSE HEX: 04000000 ;
|
||||
: FILE_FLAG_BACKUP_SEMANTICS HEX: 02000000 ;
|
||||
: FILE_FLAG_POSIX_SEMANTICS HEX: 01000000 ;
|
||||
: FILE_FLAG_OPEN_REPARSE_POINT HEX: 00200000 ;
|
||||
: FILE_FLAG_OPEN_NO_RECALL HEX: 00100000 ;
|
||||
: FILE_FLAG_FIRST_PIPE_INSTANCE HEX: 00080000 ;
|
||||
|
||||
: STD_INPUT_HANDLE -10 ;
|
||||
: STD_OUTPUT_HANDLE -11 ;
|
||||
: STD_ERROR_HANDLE -12 ;
|
||||
|
||||
: INVALID_HANDLE_VALUE -1 <alien> ;
|
||||
: INVALID_FILE_SIZE HEX: FFFFFFFF ;
|
||||
|
||||
: INFINITE HEX: FFFFFFFF ;
|
||||
|
||||
: GetStdHandle ( id -- handle )
|
||||
"void*" "kernel32" "GetStdHandle" [ "int" ] alien-invoke ;
|
||||
|
||||
: GetFileSize ( handle out -- int )
|
||||
"int" "kernel32" "GetFileSize" [ "void*" "void*" ] alien-invoke ;
|
||||
|
||||
: SetConsoleTextAttribute ( handle attrs -- ? )
|
||||
"bool" "kernel32" "SetConsoleTextAttribute" [ "void*" "int" ]
|
||||
alien-invoke ;
|
||||
|
||||
: GetConsoleTitle ( buf size -- len )
|
||||
"int" "kernel32" "GetConsoleTitleA" [ "int" "int" ] alien-invoke ;
|
||||
|
||||
: SetConsoleTitle ( str -- ? )
|
||||
"bool" "kernel32" "SetConsoleTitleA" [ "char*" ] alien-invoke ;
|
||||
|
||||
: ReadFile ( handle buffer len out-len overlapped -- ? )
|
||||
"bool" "kernel32" "ReadFile"
|
||||
[ "void*" "int" "int" "void*" "overlapped-ext*" ]
|
||||
alien-invoke ;
|
||||
|
||||
: WriteFile ( handle buffer len out-len overlapped -- ? )
|
||||
"bool" "kernel32" "WriteFile"
|
||||
[ "void*" "int" "int" "void*" "overlapped-ext*" ]
|
||||
alien-invoke ;
|
||||
|
||||
: CreateIoCompletionPort ( handle existing-port key numthreads -- )
|
||||
"void*" "kernel32" "CreateIoCompletionPort"
|
||||
[ "void*" "void*" "void*" "int" ]
|
||||
alien-invoke ;
|
||||
|
||||
: GetQueuedCompletionStatus
|
||||
( port out-len out-key out-overlapped timeout -- ? )
|
||||
"bool" "kernel32" "GetQueuedCompletionStatus"
|
||||
[ "void*" "void*" "void*" "void*" "int" ]
|
||||
alien-invoke ;
|
||||
|
||||
: CreateFile ( name access sharemode security create flags template -- handle )
|
||||
"void*" "kernel32" "CreateFileA"
|
||||
[ "char*" "int" "int" "void*" "int" "int" "void*" ]
|
||||
alien-invoke ;
|
||||
|
||||
: CloseHandle ( handle -- ? )
|
||||
"bool" "kernel32" "CloseHandle" [ "void*" ] alien-invoke ;
|
||||
|
||||
: CancelIo ( handle -- )
|
||||
"bool" "kernel32" "CancelIo" [ "void*" ] alien-invoke drop ;
|
||||
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: alien kernel errors ;
|
||||
IN: win32-api
|
||||
|
||||
LIBRARY: kernel32
|
||||
|
||||
! FUNCTION: MAKEINTRESOURCEA
|
||||
! FUNCTION: MAKEINTRESOURCEW
|
||||
|
||||
! : MAKEINTRESOURCE \ MAKEINTRESOURCEW \ MAKEINTRESOURCEA unicode-exec ;
|
||||
! #define IS_INTRESOURCE(_r) (((ULONG_PTR)(_r) >> 16) == 0)
|
||||
! #define MAKEINTRESOURCEA(i) (LPSTR)((ULONG_PTR)((WORD)(i)))
|
||||
! #define MAKEINTRESOURCEW(i) (LPWSTR)((ULONG_PTR)((WORD)(i)))
|
||||
|
||||
|
||||
! FUNCTION: DWORD FormatMessage(
|
||||
! DWORD dwFlags,
|
||||
! LPCVOID lpSource,
|
||||
! DWORD dwMessageId,
|
||||
! DWORD dwLanguageId,
|
||||
! LPTSTR lpBuffer,
|
||||
! DWORD nSize,
|
||||
! va_list* Arguments
|
||||
! ) ;
|
||||
|
||||
|
||||
|
||||
FUNCTION: HMODULE GetModuleHandleA ( char* lpModulename ) ;
|
||||
FUNCTION: HMODULE GetModuleHandleW ( char* lpModulename ) ;
|
||||
|
||||
: GetModuleHandle \ GetModuleHandleW \ GetModuleHandleA unicode-exec ;
|
||||
|
||||
|
||||
! FUNCTION: HMODULE GetModuleHandleEx (
|
||||
! DWORD dwFlags,
|
||||
! LPCTSTR lpModulename,
|
||||
! HMODULE* phModule ) ;
|
||||
|
||||
|
||||
|
||||
FUNCTION: DWORD GetLastError ( ) ;
|
||||
|
||||
: (win32-error) ( id -- string )
|
||||
"char*" f "error_message" [ "int" ] alien-invoke ;
|
||||
|
||||
: win32-error ( -- )
|
||||
GetLastError dup 0 = [ (win32-error) throw ] unless drop ;
|
||||
|
||||
: GHND HEX: 40 ; inline
|
||||
: GMEM_FIXED 0 ; inline
|
||||
: GMEM_MOVEABLE 2 ; inline
|
||||
: GMEM_ZEROINIT HEX: 40 ; inline
|
||||
: GPTR HEX: 40 ; inline
|
||||
|
||||
FUNCTION: HGLOBAL GlobalAlloc ( UINT uFlags, SIZE_T dwBytes ) ;
|
||||
FUNCTION: LPVOID GlobalLock ( HGLOBAL hMem ) ;
|
||||
! FUNCTION: char* GlobalLock ( HGLOBAL hMem ) ;
|
||||
FUNCTION: BOOL GlobalUnlock ( HGLOBAL hMem ) ;
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
IN: scratchpad
|
||||
USING: alien compiler kernel namespaces parser sequences words ;
|
||||
|
||||
{
|
||||
{ "gdi32" "gdi32" }
|
||||
{ "user32" "user32" }
|
||||
{ "kernel32" "kernel32" }
|
||||
{ "winsock" "ws2_32" }
|
||||
{ "mswsock" "mswsock" }
|
||||
} [ first2 add-simple-library ] each
|
||||
"libc" "msvcrt.dll" "cdecl" add-library
|
||||
|
||||
{
|
||||
"windows-messages"
|
||||
"types"
|
||||
"gdi32"
|
||||
"kernel32"
|
||||
"user32"
|
||||
"opengl32"
|
||||
"utils"
|
||||
|
||||
"io"
|
||||
"errors"
|
||||
"winsock"
|
||||
"io-internals"
|
||||
"stream"
|
||||
"server"
|
||||
} [ "/library/io/windows/" swap ".factor" append3 run-resource ] each
|
||||
|
||||
"native-io" get [
|
||||
"/library/bootstrap/win32-io.factor" run-resource
|
||||
] when
|
||||
|
||||
IN: kernel
|
||||
: default-shell "ui" ;
|
||||
|
|
@ -0,0 +1,102 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: alien parser namespaces kernel syntax words math io prettyprint ;
|
||||
IN: win32-api
|
||||
|
||||
! PIXELFORMATDESCRIPTOR flags
|
||||
: PFD_DOUBLEBUFFER HEX: 00000001 ; inline
|
||||
: PFD_STEREO HEX: 00000002 ; inline
|
||||
: PFD_DRAW_TO_WINDOW HEX: 00000004 ; inline
|
||||
: PFD_DRAW_TO_BITMAP HEX: 00000008 ; inline
|
||||
: PFD_SUPPORT_GDI HEX: 00000010 ; inline
|
||||
: PFD_SUPPORT_OPENGL HEX: 00000020 ; inline
|
||||
: PFD_GENERIC_FORMAT HEX: 00000040 ; inline
|
||||
: PFD_NEED_PALETTE HEX: 00000080 ; inline
|
||||
: PFD_NEED_SYSTEM_PALETTE HEX: 00000100 ; inline
|
||||
: PFD_SWAP_EXCHANGE HEX: 00000200 ; inline
|
||||
: PFD_SWAP_COPY HEX: 00000400 ; inline
|
||||
: PFD_SWAP_LAYER_BUFFERS HEX: 00000800 ; inline
|
||||
: PFD_GENERIC_ACCELERATED HEX: 00001000 ; inline
|
||||
: PFD_SUPPORT_DIRECTDRAW HEX: 00002000 ; inline
|
||||
|
||||
! PIXELFORMATDESCRIPTOR flags for use in ChoosePixelFormat only
|
||||
: PFD_DEPTH_DONTCARE HEX: 20000000 ; inline
|
||||
: PFD_DOUBLEBUFFER_DONTCARE HEX: 40000000 ; inline
|
||||
: PFD_STEREO_DONTCARE HEX: 80000000 ; inline
|
||||
|
||||
! pixel types
|
||||
: PFD_TYPE_RGBA 0 ; inline
|
||||
: PFD_TYPE_COLORINDEX 1 ; inline
|
||||
|
||||
! layer types
|
||||
: PFD_MAIN_PLANE 0 ; inline
|
||||
: PFD_OVERLAY_PLANE 1 ; inline
|
||||
: PFD_UNDERLAY_PLANE -1 ; inline
|
||||
|
||||
: LPD_TYPE_RGBA 0 ; inline
|
||||
: LPD_TYPE_COLORINDEX 1 ; inline
|
||||
|
||||
! wglSwapLayerBuffers flags
|
||||
: WGL_SWAP_MAIN_PLANE HEX: 00000001 ; inline
|
||||
: WGL_SWAP_OVERLAY1 HEX: 00000002 ; inline
|
||||
: WGL_SWAP_OVERLAY2 HEX: 00000004 ; inline
|
||||
: WGL_SWAP_OVERLAY3 HEX: 00000008 ; inline
|
||||
: WGL_SWAP_OVERLAY4 HEX: 00000010 ; inline
|
||||
: WGL_SWAP_OVERLAY5 HEX: 00000020 ; inline
|
||||
: WGL_SWAP_OVERLAY6 HEX: 00000040 ; inline
|
||||
: WGL_SWAP_OVERLAY7 HEX: 00000080 ; inline
|
||||
: WGL_SWAP_OVERLAY8 HEX: 00000100 ; inline
|
||||
: WGL_SWAP_OVERLAY9 HEX: 00000200 ; inline
|
||||
: WGL_SWAP_OVERLAY10 HEX: 00000400 ; inline
|
||||
: WGL_SWAP_OVERLAY11 HEX: 00000800 ; inline
|
||||
: WGL_SWAP_OVERLAY12 HEX: 00001000 ; inline
|
||||
: WGL_SWAP_OVERLAY13 HEX: 00002000 ; inline
|
||||
: WGL_SWAP_OVERLAY14 HEX: 00004000 ; inline
|
||||
: WGL_SWAP_OVERLAY15 HEX: 00008000 ; inline
|
||||
: WGL_SWAP_UNDERLAY1 HEX: 00010000 ; inline
|
||||
: WGL_SWAP_UNDERLAY2 HEX: 00020000 ; inline
|
||||
: WGL_SWAP_UNDERLAY3 HEX: 00040000 ; inline
|
||||
: WGL_SWAP_UNDERLAY4 HEX: 00080000 ; inline
|
||||
: WGL_SWAP_UNDERLAY5 HEX: 00100000 ; inline
|
||||
: WGL_SWAP_UNDERLAY6 HEX: 00200000 ; inline
|
||||
: WGL_SWAP_UNDERLAY7 HEX: 00400000 ; inline
|
||||
: WGL_SWAP_UNDERLAY8 HEX: 00800000 ; inline
|
||||
: WGL_SWAP_UNDERLAY9 HEX: 01000000 ; inline
|
||||
: WGL_SWAP_UNDERLAY10 HEX: 02000000 ; inline
|
||||
: WGL_SWAP_UNDERLAY11 HEX: 04000000 ; inline
|
||||
: WGL_SWAP_UNDERLAY12 HEX: 08000000 ; inline
|
||||
: WGL_SWAP_UNDERLAY13 HEX: 10000000 ; inline
|
||||
: WGL_SWAP_UNDERLAY14 HEX: 20000000 ; inline
|
||||
: WGL_SWAP_UNDERLAY15 HEX: 40000000 ; inline
|
||||
|
||||
|
||||
|
||||
: pfd-dwFlags
|
||||
PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL bitor PFD_DOUBLEBUFFER bitor ;
|
||||
|
||||
! TODO: compare to http://www.nullterminator.net/opengl32.html
|
||||
: make-pfd ( bits -- pfd )
|
||||
"PIXELFORMATDESCRIPTOR" <c-object>
|
||||
"PIXELFORMATDESCRIPTOR" c-size over set-PIXELFORMATDESCRIPTOR-nSize
|
||||
1 over set-PIXELFORMATDESCRIPTOR-nVersion
|
||||
pfd-dwFlags over set-PIXELFORMATDESCRIPTOR-dwFlags
|
||||
PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
|
||||
[ set-PIXELFORMATDESCRIPTOR-cColorBits ] keep
|
||||
16 over set-PIXELFORMATDESCRIPTOR-cDepthBits
|
||||
PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask ;
|
||||
|
||||
|
||||
LIBRARY: gl
|
||||
|
||||
|
||||
! FUNCTION: int ReleaseDC ( HWND hWnd, HDC hDC ) ;
|
||||
! FUNCTION: HDC ResetDC ( HDC hdc, DEVMODE* lpInitData ) ;
|
||||
! FUNCTION: BOOL RestoreDC ( HDC hdc, int nSavedDC ) ;
|
||||
! FUNCTION: int SaveDC( HDC hDC ) ;
|
||||
! FUNCTION: HGDIOBJ SelectObject ( HDC hDC, HGDIOBJ hgdiobj ) ;
|
||||
|
||||
FUNCTION: HGLRC wglCreateContext ( HDC hDC ) ;
|
||||
FUNCTION: BOOL wglDeleteContext ( HGLRC hRC ) ;
|
||||
FUNCTION: BOOL wglMakeCurrent ( HDC hDC, HGLRC hglrc ) ;
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
! $Id: win32-server.factor,v 1.13 2006/01/28 20:49:31 spestov Exp $
|
||||
!
|
||||
! Copyright (C) 2004, 2005 Mackenzie Straight.
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions are met:
|
||||
!
|
||||
! 1. Redistributions of source code must retain the above copyright notice,
|
||||
! this list of conditions and the following disclaimer.
|
||||
!
|
||||
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
||||
! this list of conditions and the following disclaimer in the documentation
|
||||
! and/or other materials provided with the distribution.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
||||
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
||||
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
||||
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
||||
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
IN: win32-stream
|
||||
USING: alien errors generic kernel kernel-internals math namespaces
|
||||
prettyprint sequences io strings threads win32-api
|
||||
win32-io-internals io-internals ;
|
||||
|
||||
TUPLE: win32-server this ;
|
||||
TUPLE: win32-client-stream host port ;
|
||||
SYMBOL: winsock
|
||||
SYMBOL: socket
|
||||
|
||||
: maybe-init-winsock ( -- )
|
||||
winsock get [
|
||||
HEX: 0202 <wsadata> WSAStartup drop winsock on
|
||||
] unless ;
|
||||
|
||||
: handle-socket-error ( -- )
|
||||
WSAGetLastError [
|
||||
ERROR_IO_PENDING ERROR_SUCCESS
|
||||
] member? [
|
||||
WSAGetLastError win32-error-message throw
|
||||
] unless ;
|
||||
|
||||
: new-socket ( -- socket )
|
||||
AF_INET SOCK_STREAM 0 f f WSA_FLAG_OVERLAPPED WSASocket ;
|
||||
|
||||
: setup-sockaddr ( port -- sockaddr )
|
||||
"sockaddr-in" <c-object> swap
|
||||
htons over set-sockaddr-in-port
|
||||
INADDR_ANY over set-sockaddr-in-addr
|
||||
AF_INET over set-sockaddr-in-family ;
|
||||
|
||||
: bind-socket ( port socket -- )
|
||||
swap setup-sockaddr "sockaddr-in" c-size wsa-bind zero? [
|
||||
handle-socket-error
|
||||
] unless ;
|
||||
|
||||
: listen-socket ( socket -- )
|
||||
20 wsa-listen zero? [ handle-socket-error ] unless ;
|
||||
|
||||
: sockaddr> ( sockaddr -- port host )
|
||||
dup sockaddr-in-port ntohs swap sockaddr-in-addr inet-ntoa ;
|
||||
|
||||
: extract-remote-host ( buffer -- port host )
|
||||
buffer-ptr <alien> 0 32 32 0 <int>
|
||||
0 <int>
|
||||
0 <int>
|
||||
dup >r 0 <int>
|
||||
GetAcceptExSockaddrs r> *int <alien> sockaddr> ;
|
||||
|
||||
C: win32-client-stream ( buf stream -- stream )
|
||||
[ set-delegate extract-remote-host ] keep
|
||||
[ set-win32-client-stream-host ] keep
|
||||
[ set-win32-client-stream-port ] keep ;
|
||||
|
||||
M: win32-client-stream client-stream-host win32-client-stream-host ;
|
||||
M: win32-client-stream client-stream-port win32-client-stream-port ;
|
||||
|
||||
C: win32-server ( port -- server )
|
||||
swap [
|
||||
maybe-init-winsock new-socket swap over bind-socket dup listen-socket
|
||||
dup add-completion
|
||||
socket set
|
||||
dup stream set
|
||||
] make-hash over set-win32-server-this ;
|
||||
|
||||
M: win32-server stream-close ( server -- )
|
||||
win32-server-this [ socket get CloseHandle drop ] bind ;
|
||||
|
||||
M: win32-server set-timeout ( timeout server -- )
|
||||
win32-server-this [ timeout set ] bind ;
|
||||
|
||||
M: win32-server expire ( -- )
|
||||
win32-server-this [
|
||||
timeout get [ millis cutoff get > [ socket get CancelIo ] when ] when
|
||||
] bind ;
|
||||
|
||||
: client-sockaddr ( host port -- sockaddr )
|
||||
setup-sockaddr [
|
||||
>r gethostbyname handle-socket-error hostent-addr
|
||||
r> set-sockaddr-in-addr
|
||||
] keep ;
|
||||
|
||||
IN: io
|
||||
: accept ( server -- client )
|
||||
win32-server-this [
|
||||
update-timeout new-socket 64 <buffer>
|
||||
[
|
||||
stream get alloc-io-callback init-overlapped
|
||||
>r >r >r socket get r> r>
|
||||
buffer-ptr <alien> 0 32 32 f r> AcceptEx
|
||||
[ handle-socket-error ] unless stop
|
||||
] callcc1 pending-error drop
|
||||
swap dup add-completion <win32-stream> <line-reader>
|
||||
dupd <win32-client-stream> swap buffer-free
|
||||
] bind ;
|
||||
|
||||
: <client> ( host port -- stream )
|
||||
maybe-init-winsock client-sockaddr new-socket
|
||||
[ swap "sockaddr-in" c-size connect drop handle-socket-error ] keep
|
||||
dup add-completion <win32-stream> <line-reader> ;
|
||||
|
||||
|
|
@ -0,0 +1,187 @@
|
|||
! $Id: win32-stream.factor,v 1.16 2006/01/28 20:49:31 spestov Exp $
|
||||
!
|
||||
! Copyright (C) 2004, 2005 Mackenzie Straight.
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions are met:
|
||||
!
|
||||
! 1. Redistributions of source code must retain the above copyright notice,
|
||||
! this list of conditions and the following disclaimer.
|
||||
!
|
||||
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
||||
! this list of conditions and the following disclaimer in the documentation
|
||||
! and/or other materials provided with the distribution.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
||||
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
||||
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
||||
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
||||
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
IN: win32-stream
|
||||
USING: alien generic io-internals kernel
|
||||
kernel-internals math namespaces prettyprint sequences
|
||||
io strings threads win32-api win32-io-internals ;
|
||||
|
||||
TUPLE: win32-stream this ; ! FIXME: rewrite using tuples
|
||||
GENERIC: win32-stream-handle
|
||||
GENERIC: do-write
|
||||
|
||||
SYMBOL: handle
|
||||
SYMBOL: in-buffer
|
||||
SYMBOL: out-buffer
|
||||
SYMBOL: fileptr
|
||||
SYMBOL: file-size
|
||||
SYMBOL: stream
|
||||
SYMBOL: timeout
|
||||
SYMBOL: cutoff
|
||||
|
||||
: pending-error ( len/status -- len/status )
|
||||
dup [ win32-throw-error ] unless ;
|
||||
|
||||
: init-overlapped ( overlapped -- overlapped )
|
||||
0 over set-overlapped-ext-internal
|
||||
0 over set-overlapped-ext-internal-high
|
||||
fileptr get dup 0 ? over set-overlapped-ext-offset
|
||||
0 over set-overlapped-ext-offset-high
|
||||
f over set-overlapped-ext-event ;
|
||||
|
||||
: update-file-pointer ( whence -- )
|
||||
file-size get [ fileptr [ + ] change ] [ drop ] if ;
|
||||
|
||||
: update-timeout ( -- )
|
||||
timeout get [ millis + cutoff set ] when* ;
|
||||
|
||||
: flush-output ( -- )
|
||||
update-timeout [
|
||||
stream get alloc-io-callback init-overlapped >r
|
||||
handle get out-buffer get [ buffer@ ] keep buffer-length
|
||||
f r> WriteFile [ handle-io-error ] unless stop
|
||||
] callcc1 pending-error
|
||||
|
||||
dup update-file-pointer
|
||||
out-buffer get [ buffer-consume ] keep
|
||||
buffer-length 0 > [ flush-output ] when ;
|
||||
|
||||
: maybe-flush-output ( -- )
|
||||
out-buffer get buffer-length 0 > [ flush-output ] when ;
|
||||
|
||||
M: integer do-write ( int -- )
|
||||
out-buffer get [ buffer-capacity zero? [ flush-output ] when ] keep
|
||||
>r ch>string r> >buffer ;
|
||||
|
||||
M: string do-write ( str -- )
|
||||
dup length out-buffer get buffer-capacity <= [
|
||||
out-buffer get >buffer
|
||||
] [
|
||||
dup length out-buffer get buffer-size > [
|
||||
dup length out-buffer get extend-buffer do-write
|
||||
] [ flush-output do-write ] if
|
||||
] if ;
|
||||
|
||||
: fill-input ( -- )
|
||||
update-timeout [
|
||||
stream get alloc-io-callback init-overlapped >r
|
||||
handle get in-buffer get [ buffer@ ] keep
|
||||
buffer-capacity file-size get [ fileptr get - min ] when*
|
||||
f r>
|
||||
ReadFile [ handle-io-error ] unless stop
|
||||
] callcc1 pending-error
|
||||
|
||||
dup in-buffer get n>buffer update-file-pointer ;
|
||||
|
||||
: consume-input ( count -- str )
|
||||
in-buffer get buffer-length zero? [ fill-input ] when
|
||||
in-buffer get buffer-size min
|
||||
dup in-buffer get buffer-first-n
|
||||
swap in-buffer get buffer-consume ;
|
||||
|
||||
: >string-or-f ( sbuf -- str-or-? )
|
||||
dup length 0 > [ >string ] [ drop f ] if ;
|
||||
|
||||
: do-read-count ( sbuf count -- str )
|
||||
dup zero? [
|
||||
drop >string
|
||||
] [
|
||||
dup consume-input
|
||||
dup length dup zero? [
|
||||
3drop >string-or-f
|
||||
] [
|
||||
>r swap r> - >r swap [ swap nappend ] keep r> do-read-count
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: peek-input ( -- str )
|
||||
1 in-buffer get buffer-first-n ;
|
||||
|
||||
M: win32-stream stream-write ( str stream -- )
|
||||
win32-stream-this [ do-write ] bind ;
|
||||
|
||||
M: win32-stream stream-write1 ( char stream -- )
|
||||
win32-stream-this [ >fixnum do-write ] bind ;
|
||||
|
||||
M: win32-stream stream-read ( count stream -- str )
|
||||
win32-stream-this [ dup <sbuf> swap do-read-count ] bind ;
|
||||
|
||||
M: win32-stream stream-read1 ( stream -- str )
|
||||
win32-stream-this [
|
||||
1 consume-input dup length zero? [ drop f ] when first
|
||||
] bind ;
|
||||
|
||||
M: win32-stream stream-readln ( stream -- str )
|
||||
win32-stream-this [ readln ] bind ;
|
||||
|
||||
M: win32-stream stream-terpri
|
||||
win32-stream-this [ CHAR: \n do-write ] bind ;
|
||||
|
||||
M: win32-stream stream-flush ( stream -- )
|
||||
win32-stream-this [ maybe-flush-output ] bind ;
|
||||
|
||||
M: win32-stream stream-close ( stream -- )
|
||||
win32-stream-this [
|
||||
maybe-flush-output
|
||||
handle get CloseHandle drop
|
||||
in-buffer get buffer-free
|
||||
out-buffer get buffer-free
|
||||
] bind ;
|
||||
|
||||
M: win32-stream stream-format ( string style stream -- )
|
||||
win32-stream-this [ drop do-write ] bind ;
|
||||
|
||||
M: win32-stream win32-stream-handle ( stream -- handle )
|
||||
win32-stream-this [ handle get ] bind ;
|
||||
|
||||
M: win32-stream set-timeout ( timeout stream -- )
|
||||
win32-stream-this [ timeout set ] bind ;
|
||||
|
||||
M: win32-stream expire ( stream -- )
|
||||
win32-stream-this [
|
||||
timeout get [ millis cutoff get > [ handle get CancelIo ] when ] when
|
||||
] bind ;
|
||||
|
||||
M: win32-stream with-nested-stream ( quot style stream -- )
|
||||
win32-stream-this [ drop stream get swap with-stream* ] bind ;
|
||||
|
||||
C: win32-stream ( handle -- stream )
|
||||
swap [
|
||||
dup f GetFileSize dup -1 = not [
|
||||
file-size set
|
||||
] [ drop f file-size set ] if
|
||||
handle set
|
||||
4096 <buffer> in-buffer set
|
||||
4096 <buffer> out-buffer set
|
||||
0 fileptr set
|
||||
dup stream set
|
||||
] make-hash over set-win32-stream-this ;
|
||||
|
||||
: <win32-file-reader> ( path -- stream )
|
||||
t f win32-open-file <win32-stream> <line-reader> ;
|
||||
|
||||
: <win32-file-writer> ( path -- stream )
|
||||
f t win32-open-file <win32-stream> ;
|
||||
|
||||
|
|
@ -0,0 +1,367 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: alien namespaces kernel words ;
|
||||
IN: win32-api
|
||||
|
||||
! http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winprog/winprog/windows_data_types.asp
|
||||
|
||||
SYMBOL: unicode f unicode set
|
||||
: unicode-exec ( unicode-func ascii-func -- func )
|
||||
unicode get [
|
||||
drop execute
|
||||
] [
|
||||
nip execute
|
||||
] if ; inline
|
||||
|
||||
: unicode? unicode get ; inline
|
||||
|
||||
: win64? f ;
|
||||
|
||||
! win64
|
||||
! char uchar short ushort int uint long ulong longlong ulonglong
|
||||
! 1 1 2 2 * * ?
|
||||
! win32
|
||||
! char uchar short ushort int uint long ulong longlong ulonglong
|
||||
! 1 1 2 2 * * 4 4 8 8
|
||||
|
||||
|
||||
TYPEDEF: char CHAR
|
||||
TYPEDEF: uchar UCHAR
|
||||
TYPEDEF: uchar BYTE
|
||||
|
||||
TYPEDEF: short wchar_t
|
||||
TYPEDEF: wchar_t WCHAR
|
||||
|
||||
TYPEDEF: short SHORT
|
||||
TYPEDEF: ushort USHORT
|
||||
|
||||
TYPEDEF: ushort WORD
|
||||
TYPEDEF: ulong DWORD
|
||||
|
||||
TYPEDEF: int INT
|
||||
TYPEDEF: uint UINT
|
||||
|
||||
TYPEDEF: int BOOL
|
||||
|
||||
TYPEDEF: int* PINT
|
||||
TYPEDEF: int* LPINT
|
||||
TYPEDEF: int HFILE
|
||||
|
||||
TYPEDEF: long LONG
|
||||
TYPEDEF: long* LPLONG
|
||||
TYPEDEF: long LONG_PTR
|
||||
TYPEDEF: long* PLONG_PTR
|
||||
|
||||
TYPEDEF: uint ULONG
|
||||
TYPEDEF: ulong ULONG_PTR
|
||||
TYPEDEF: ulong* PULONG_PTR
|
||||
|
||||
TYPEDEF: void VOID
|
||||
TYPEDEF: void* PVOID
|
||||
TYPEDEF: void* LPVOID
|
||||
TYPEDEF: void* LPCVOID
|
||||
|
||||
TYPEDEF: float FLOAT
|
||||
! The following is commented out for two reasons.
|
||||
! 1) all of the code in both branches will be run because TYPEDEF: is a
|
||||
! parsing word
|
||||
! 2) we are waiting on gcc to be ported to win64/msys
|
||||
! 3) the TYPEDEF:s are probably wrong.
|
||||
|
||||
! win64? [
|
||||
! ! TODO: check these!
|
||||
! TYPEDEF: INT32 HALF_PTR
|
||||
! TYPEDEF: UINT32 UHALF_PTR
|
||||
! TYPEDEF: long INT_PTR
|
||||
! TYPEDEF: ulong UINT_PTR
|
||||
|
||||
! TYPEDEF: longlong LONG_PTR ! 64bit
|
||||
! TYPEDEF: ulonglong ULONG_PTR ! 64bit
|
||||
|
||||
! TYPEDEF: int INT32
|
||||
! TYPEDEF: uint UINT32
|
||||
! TYPEDEF: uint DWORD32
|
||||
! TYPEDEF: uint ULONG32
|
||||
! TYPEDEF: ulong ULONG64
|
||||
! TYPEDEF: int* POINTER_32
|
||||
! TYPEDEF: long* POINTER_64
|
||||
! TYPEDEF: longlong INT64
|
||||
! TYPEDEF: ulonglong UINT64
|
||||
! TYPEDEF: longlong LONGLONG ! 64bit
|
||||
! TYPEDEF: ulonglong ULONGLONG
|
||||
! TYPEDEF: longlong LONG64
|
||||
! TYPEDEF: ulonglong DWORD64
|
||||
! ] [
|
||||
! Correct for win32
|
||||
TYPEDEF: short HALF_PTR
|
||||
TYPEDEF: ushort UHALF_PTR
|
||||
TYPEDEF: int INT_PTR
|
||||
TYPEDEF: uint UINT_PTR
|
||||
|
||||
TYPEDEF: int LONG_PTR
|
||||
TYPEDEF: ulong ULONG_PTR
|
||||
|
||||
TYPEDEF: int INT32
|
||||
TYPEDEF: uint UINT32
|
||||
TYPEDEF: uint DWORD32
|
||||
TYPEDEF: ulong ULONG32
|
||||
TYPEDEF: ulonglong ULONG64
|
||||
TYPEDEF: long* POINTER_32
|
||||
TYPEDEF: longlong* POINTER_64
|
||||
TYPEDEF: longlong INT64
|
||||
TYPEDEF: ulonglong UINT64
|
||||
TYPEDEF: longlong LONGLONG
|
||||
TYPEDEF: ulonglong ULONGLONG
|
||||
TYPEDEF: longlong LONG64
|
||||
TYPEDEF: ulonglong DWORD64
|
||||
! ] if
|
||||
|
||||
! unicode? [
|
||||
! TYPEDEF: WCHAR TBYTE
|
||||
! TYPEDEF: WCHAR TCHAR
|
||||
! ] [
|
||||
TYPEDEF: uchar TBYTE
|
||||
TYPEDEF: char TCHAR
|
||||
! ] if
|
||||
|
||||
! Below down is based on the above definitions
|
||||
! There should be no 32/64bit issues
|
||||
|
||||
TYPEDEF: WORD ATOM
|
||||
TYPEDEF: BYTE BOOLEAN
|
||||
! TYPEDEF: __stdcall CALLBACK
|
||||
TYPEDEF: DWORD COLORREF
|
||||
TYPEDEF: ULONGLONG DWORDLONG
|
||||
TYPEDEF: ULONG_PTR DWORD_PTR
|
||||
TYPEDEF: PVOID HANDLE
|
||||
TYPEDEF: HANDLE HACCEL
|
||||
TYPEDEF: HANDLE HBITMAP
|
||||
TYPEDEF: HANDLE HBRUSH
|
||||
TYPEDEF: HANDLE HCOLORSPACE
|
||||
TYPEDEF: HANDLE HCONV
|
||||
TYPEDEF: HANDLE HCONVLIST
|
||||
TYPEDEF: HANDLE HICON
|
||||
TYPEDEF: HICON HCURSOR
|
||||
TYPEDEF: HANDLE HDC
|
||||
TYPEDEF: HANDLE HDDEDATA
|
||||
TYPEDEF: HANDLE HDESK
|
||||
TYPEDEF: HANDLE HDROP
|
||||
TYPEDEF: HANDLE HDWP
|
||||
TYPEDEF: HANDLE HENMETAFILE
|
||||
TYPEDEF: HANDLE HFONT
|
||||
TYPEDEF: HANDLE HGDIOBJ
|
||||
TYPEDEF: HANDLE HGLOBAL
|
||||
TYPEDEF: HANDLE HHOOK
|
||||
TYPEDEF: HANDLE HINSTANCE
|
||||
TYPEDEF: HANDLE HKEY
|
||||
TYPEDEF: HANDLE HKL
|
||||
TYPEDEF: HANDLE HLOCAL
|
||||
TYPEDEF: HANDLE HMENU
|
||||
TYPEDEF: HANDLE HMETAFILE
|
||||
TYPEDEF: HINSTANCE HMODULE
|
||||
TYPEDEF: HANDLE HMONITOR
|
||||
TYPEDEF: HANDLE HPALETTE
|
||||
TYPEDEF: HANDLE HPEN
|
||||
TYPEDEF: LONG HRESULT
|
||||
TYPEDEF: HANDLE HRGN
|
||||
TYPEDEF: HANDLE HRSRC
|
||||
TYPEDEF: HANDLE HSZ
|
||||
TYPEDEF: HANDLE WINSTA ! MS docs say typedef HANDLE WINSTA ;
|
||||
TYPEDEF: HANDLE HWINSTA ! typo??
|
||||
TYPEDEF: HANDLE HWND
|
||||
TYPEDEF: WORD LANGID
|
||||
TYPEDEF: DWORD LCID
|
||||
TYPEDEF: DWORD LCTYPE
|
||||
TYPEDEF: DWORD LGRPID
|
||||
TYPEDEF: LONG_PTR LPARAM
|
||||
TYPEDEF: BOOL* LPBOOL
|
||||
TYPEDEF: BYTE* LPBYTE
|
||||
TYPEDEF: DWORD* LPCOLORREF
|
||||
TYPEDEF: CHAR* LPCSTR
|
||||
TYPEDEF: WCHAR* LPCWSTR
|
||||
TYPEDEF: WCHAR* LPWSTR
|
||||
unicode? [
|
||||
TYPEDEF: LPCWSTR LPCTSTR
|
||||
TYPEDEF: LPWSTR LPTSTR
|
||||
TYPEDEF: LPCWSTR PCTSTR
|
||||
TYPEDEF: LPWSTR PTSTR
|
||||
] [
|
||||
TYPEDEF: LPCSTR LPCTSTR
|
||||
TYPEDEF: LPSTR LPTSTR
|
||||
TYPEDEF: LPCSTR PCTSTR
|
||||
TYPEDEF: LPSTR PTSTR
|
||||
] if
|
||||
TYPEDEF: DWORD* LPDWORD
|
||||
TYPEDEF: HANDLE* LPHANDLE
|
||||
TYPEDEF: CHAR* LPSTR
|
||||
TYPEDEF: WORD* LPWORD
|
||||
TYPEDEF: WCHAR* LPWSTR
|
||||
TYPEDEF: LONG_PTR LRESULT
|
||||
TYPEDEF: BOOL* PBOOL
|
||||
TYPEDEF: BOOLEAN* PBOOLEAN
|
||||
TYPEDEF: BYTE* PBYTE
|
||||
TYPEDEF: CHAR* PCHAR
|
||||
TYPEDEF: CHAR* PCSTR
|
||||
TYPEDEF: WCHAR* PCWSTR
|
||||
TYPEDEF: DWORD* PDWORD
|
||||
TYPEDEF: DWORDLONG* PDWORDLONG
|
||||
TYPEDEF: DWORD_PTR* PDWORD_PTR
|
||||
TYPEDEF: DWORD32* PDWORD32
|
||||
TYPEDEF: DWORD64* PDWORD64
|
||||
TYPEDEF: FLOAT* PFLOAT
|
||||
TYPEDEF: HALF_PTR* PHALF_PTR
|
||||
TYPEDEF: HANDLE* PHANDLE
|
||||
TYPEDEF: HKEY* PHKEY
|
||||
TYPEDEF: INT_PTR* PINT_PTR
|
||||
TYPEDEF: INT32* PINT32
|
||||
TYPEDEF: INT64* PINT64
|
||||
TYPEDEF: PDWORD PLCID
|
||||
TYPEDEF: LONG* PLONG
|
||||
TYPEDEF: LONGLONG* PLONGLONG
|
||||
TYPEDEF: LONG_PTR* PLONG_PTR
|
||||
TYPEDEF: LONG32* PLONG32
|
||||
TYPEDEF: LONG64* PLONG64
|
||||
TYPEDEF: SHORT* PSHORT
|
||||
TYPEDEF: SIZE_T* PSIZE_T
|
||||
TYPEDEF: SSIZE_T* PSSIZE_T
|
||||
TYPEDEF: CHAR* PSTR
|
||||
TYPEDEF: TBYTE* PTBYTE
|
||||
TYPEDEF: TCHAR* PTCHAR
|
||||
TYPEDEF: UCHAR* PUCHAR
|
||||
TYPEDEF: UHALF_PTR* PUHALF_PTR
|
||||
TYPEDEF: UINT* PUINT
|
||||
TYPEDEF: UINT_PTR* PUINT_PTR
|
||||
TYPEDEF: UINT32* PUINT32
|
||||
TYPEDEF: UINT64* PUINT64
|
||||
TYPEDEF: ULONG* PULONG
|
||||
TYPEDEF: ULONGLONG* PULONGLONG
|
||||
TYPEDEF: ULONG_PTR* PULONG_PTR
|
||||
TYPEDEF: ULONG32* PULONG32
|
||||
TYPEDEF: ULONG64* PULONG64
|
||||
TYPEDEF: USHORT* PUSHORT
|
||||
TYPEDEF: WCHAR* PWCHAR
|
||||
TYPEDEF: WORD* PWORD
|
||||
TYPEDEF: WCHAR* PWSTR
|
||||
TYPEDEF: HANDLE SC_HANDLE
|
||||
TYPEDEF: LPVOID SC_LOCK
|
||||
TYPEDEF: HANDLE SERVICE_STATUS_HANDLE
|
||||
TYPEDEF: ULONG_PTR SIZE_T
|
||||
TYPEDEF: LONG_PTR SSIZE_T
|
||||
TYPEDEF: LONGLONG USN
|
||||
! TYPEDEF: __stdcall WINAPI
|
||||
TYPEDEF: UINT_PTR WPARAM
|
||||
|
||||
|
||||
|
||||
|
||||
TYPEDEF: RECT* LPRECT
|
||||
TYPEDEF: void* PWNDCLASS
|
||||
TYPEDEF: void* PWNDCLASSEX
|
||||
|
||||
TYPEDEF: void* WNDPROC
|
||||
|
||||
! typedef LRESULT (CALLBACK* WNDPROC)(HWND, UINT, WPARAM, LPARAM);
|
||||
|
||||
BEGIN-STRUCT: WNDCLASS
|
||||
FIELD: UINT style
|
||||
FIELD: WNDPROC lpfnWndProc
|
||||
FIELD: int cbClsExtra
|
||||
FIELD: int cbWndExtra
|
||||
FIELD: HINSTANCE hInstance
|
||||
FIELD: HICON hIcon
|
||||
FIELD: HCURSOR hCursor
|
||||
FIELD: HBRUSH hbrBackground
|
||||
FIELD: LPCTSTR lpszMenuName
|
||||
FIELD: LPCTSTR lpszClassName
|
||||
END-STRUCT
|
||||
|
||||
BEGIN-STRUCT: WNDCLASSEX
|
||||
FIELD: UINT cbSize
|
||||
FIELD: UINT style
|
||||
FIELD: WNDPROC lpfnWndProc
|
||||
FIELD: int cbClsExtra
|
||||
FIELD: int cbWndExtra
|
||||
FIELD: HINSTANCE hInstance
|
||||
FIELD: HICON hIcon
|
||||
FIELD: HCURSOR hCursor
|
||||
FIELD: HBRUSH hbrBackground
|
||||
FIELD: LPCTSTR lpszMenuName
|
||||
FIELD: LPCTSTR lpszClassName
|
||||
FIELD: HICON hIconSm
|
||||
END-STRUCT
|
||||
|
||||
BEGIN-STRUCT: RECT
|
||||
FIELD: LONG left
|
||||
FIELD: LONG top
|
||||
FIELD: LONG right
|
||||
FIELD: LONG bottom
|
||||
END-STRUCT
|
||||
|
||||
BEGIN-STRUCT: PAINTSTRUCT
|
||||
FIELD: HDC hdc
|
||||
FIELD: BOOL fErase
|
||||
FIELD: RECT rcPaint
|
||||
FIELD: BOOL fRestore
|
||||
FIELD: BOOL fIncUpdate
|
||||
FIELD: BYTE rgbReserved[32]
|
||||
END-STRUCT
|
||||
|
||||
TYPEDEF: PAINTSTRUCT* LPPAINTSTRUCT
|
||||
|
||||
BEGIN-STRUCT: POINT
|
||||
FIELD: LONG x
|
||||
FIELD: LONG y
|
||||
END-STRUCT
|
||||
|
||||
BEGIN-STRUCT: MSG
|
||||
FIELD: HWND hWnd
|
||||
FIELD: UINT message
|
||||
FIELD: WPARAM wParam
|
||||
FIELD: LPARAM lParam
|
||||
FIELD: DWORD time
|
||||
FIELD: POINT pt
|
||||
END-STRUCT
|
||||
TYPEDEF: MSG* LPMSG
|
||||
|
||||
BEGIN-STRUCT: PIXELFORMATDESCRIPTOR
|
||||
FIELD: WORD nSize
|
||||
FIELD: WORD nVersion
|
||||
FIELD: DWORD dwFlags
|
||||
FIELD: BYTE iPixelType
|
||||
FIELD: BYTE cColorBits
|
||||
FIELD: BYTE cRedBits
|
||||
FIELD: BYTE cRedShift
|
||||
FIELD: BYTE cGreenBits
|
||||
FIELD: BYTE cGreenShift
|
||||
FIELD: BYTE cBlueBits
|
||||
FIELD: BYTE cBlueShift
|
||||
FIELD: BYTE cAlphaBits
|
||||
FIELD: BYTE cAlphaShift
|
||||
FIELD: BYTE cAccumBits
|
||||
FIELD: BYTE cAccumRedBits
|
||||
FIELD: BYTE cAccumGreenBits
|
||||
FIELD: BYTE cAccumBlueBits
|
||||
FIELD: BYTE cAccumAlphaBits
|
||||
FIELD: BYTE cDepthBits
|
||||
FIELD: BYTE cStencilBits
|
||||
FIELD: BYTE cAuxBuffers
|
||||
FIELD: BYTE iLayerType
|
||||
FIELD: BYTE bReserved
|
||||
FIELD: DWORD dwLayerMask
|
||||
FIELD: DWORD dwVisibleMask
|
||||
FIELD: DWORD dwDamageMask
|
||||
END-STRUCT
|
||||
|
||||
BEGIN-STRUCT: RECT
|
||||
FIELD: LONG left
|
||||
FIELD: LONG top
|
||||
FIELD: LONG right
|
||||
FIELD: LONG bottom
|
||||
END-STRUCT
|
||||
|
||||
TYPEDEF: RECT* PRECT
|
||||
TYPEDEF: RECT* LPRECT
|
||||
TYPEDEF: PIXELFORMATDESCRIPTOR PFD
|
||||
TYPEDEF: PFD* LPPFD
|
||||
TYPEDEF: HANDLE HGLRC
|
||||
TYPEDEF: HANDLE HRGN
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: alien parser namespaces kernel syntax words math io prettyprint ;
|
||||
IN: win32-api
|
||||
|
||||
: win32-error=0 zero? [ win32-error ] when ;
|
||||
: win32-error>0 0 > [ win32-error ] when ;
|
||||
: win32-error<0 0 < [ win32-error ] when ;
|
||||
: win32-error<>0 zero? [ win32-error ] unless ;
|
||||
|
||||
: lo-word ( wparam -- lo ) HEX: ffff bitand ;
|
||||
: hi-word ( wparam -- hi ) -16 shift ;
|
||||
|
||||
: msgbox ( str -- )
|
||||
f swap "DebugMsg" MB_OK MessageBox drop ;
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,107 @@
|
|||
! :folding=indent:collapseFolds=1:
|
||||
|
||||
! $Id: winsock.factor,v 1.8 2005/09/12 15:10:33 erg Exp $
|
||||
!
|
||||
! Copyright (C) 2004 Mackenzie Straight.
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions are met:
|
||||
!
|
||||
! 1. Redistributions of source code must retain the above copyright notice,
|
||||
! this list of conditions and the following disclaimer.
|
||||
!
|
||||
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
||||
! this list of conditions and the following disclaimer in the documentation
|
||||
! and/or other materials provided with the distribution.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
||||
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
||||
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
||||
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
||||
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
IN: win32-api
|
||||
USE: alien
|
||||
USE: kernel
|
||||
USE: kernel-internals
|
||||
USE: sequences-internals
|
||||
USE: arrays
|
||||
|
||||
: <wsadata> HEX: 190 <byte-array> ;
|
||||
|
||||
: AF_INET 2 ;
|
||||
: SOCK_STREAM 1 ;
|
||||
: WSA_FLAG_OVERLAPPED 1 ;
|
||||
: INADDR_ANY 0 ;
|
||||
|
||||
BEGIN-STRUCT: sockaddr-in
|
||||
FIELD: short family
|
||||
FIELD: short port
|
||||
FIELD: int addr
|
||||
FIELD: char pad
|
||||
FIELD: char pad
|
||||
FIELD: char pad
|
||||
FIELD: char pad
|
||||
FIELD: char pad
|
||||
FIELD: char pad
|
||||
FIELD: char pad
|
||||
FIELD: char pad
|
||||
END-STRUCT
|
||||
|
||||
: WSAStartup ( version out-data -- int )
|
||||
"int" "winsock" "WSAStartup" [ "short" "void*" ] alien-invoke ;
|
||||
|
||||
: WSASocket ( af type protocol protocol-info g flags -- socket )
|
||||
"void*" "winsock" "WSASocketA" [ "int" "int" "int" "void*" "void*" "int" ]
|
||||
alien-invoke ;
|
||||
|
||||
: htons ( short -- short )
|
||||
"ushort" "winsock" "htons" [ "ushort" ] alien-invoke ;
|
||||
|
||||
: ntohs ( short -- short )
|
||||
"ushort" "winsock" "ntohs" [ "ushort" ] alien-invoke ;
|
||||
|
||||
: wsa-bind ( socket sockaddr len -- status )
|
||||
"int" "winsock" "bind" [ "void*" "sockaddr-in*" "int" ] alien-invoke ;
|
||||
|
||||
: wsa-listen ( socket backlog -- status )
|
||||
"int" "winsock" "listen" [ "void*" "int" ] alien-invoke ;
|
||||
|
||||
: WSAGetLastError ( -- error )
|
||||
"int" "winsock" "WSAGetLastError" [ ] alien-invoke ;
|
||||
|
||||
: inet-ntoa ( in-addr -- str )
|
||||
"char*" "winsock" "inet_ntoa" [ "int" ] alien-invoke ;
|
||||
|
||||
: AcceptEx
|
||||
( listen accept out-buf recv-len addr-len remote-len out-len overlapped -- ? )
|
||||
"bool" "mswsock" "AcceptEx"
|
||||
[ "void*" "void*" "void*" "int" "int" "int" "void*" "void*" ]
|
||||
alien-invoke ;
|
||||
|
||||
: GetAcceptExSockaddrs ( stack effect is too long to put here -- )
|
||||
"void" "mswsock" "GetAcceptExSockaddrs"
|
||||
[ "void*" "int" "int" "int" "void*" "void*" "void*" "void*" ] alien-invoke ;
|
||||
|
||||
BEGIN-STRUCT: hostent
|
||||
FIELD: char* name
|
||||
FIELD: void* aliases
|
||||
FIELD: short addrtype
|
||||
FIELD: short length
|
||||
FIELD: void* addr-list
|
||||
END-STRUCT
|
||||
|
||||
: hostent-addr hostent-addr-list *void* *uint ;
|
||||
|
||||
: gethostbyname ( name -- hostent )
|
||||
"hostent*" "winsock" "gethostbyname" [ "char*" ] alien-invoke ;
|
||||
|
||||
: connect ( socket sockaddr addrlen -- int )
|
||||
"int" "winsock" "connect" [ "void*" "sockaddr-in*" "int" ]
|
||||
alien-invoke ;
|
||||
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
! Copyright (C) 2006 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel win32-api math namespaces io prettyprint errors sequences alien
|
||||
libc ;
|
||||
IN: win32
|
||||
|
||||
: (enum-clipboard) ( n -- )
|
||||
EnumClipboardFormats win32-error dup 0 > [ dup , (enum-clipboard) ] when ;
|
||||
|
||||
: enum-clipboard ( -- seq )
|
||||
[ 0 (enum-clipboard) ] { } make nip ;
|
||||
|
||||
: paste ( -- str )
|
||||
f OpenClipboard drop
|
||||
CF_TEXT IsClipboardFormatAvailable 0 = [
|
||||
"no text in clipboard" print
|
||||
] [
|
||||
! "text found" print
|
||||
CF_TEXT GetClipboardData
|
||||
dup GlobalLock swap
|
||||
GlobalUnlock drop
|
||||
] if
|
||||
CloseClipboard drop alien>char-string ;
|
||||
|
||||
: copy ( str -- )
|
||||
f OpenClipboard drop
|
||||
EmptyClipboard drop
|
||||
GMEM_MOVEABLE over length 1+ GlobalAlloc dup 0 = [
|
||||
"unable to allocate memory" throw
|
||||
] when
|
||||
|
||||
dup GlobalLock
|
||||
rot dup length memcpy
|
||||
dup GlobalUnlock drop
|
||||
CF_TEXT swap SetClipboardData 0 = [
|
||||
win32-error
|
||||
"SetClipboardData failed" throw
|
||||
] when
|
||||
|
||||
CloseClipboard drop ;
|
||||
|
||||
! TODO
|
||||
! M: win-clipboard paste-clipboard ( gadget clipboard -- )
|
||||
! >r find-world world-handle win-hWnd r> clipboard-contents paste ;
|
||||
|
||||
|
|
@ -0,0 +1,322 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays errors freetype gadgets gadgets-launchpad
|
||||
gadgets-listener hashtables io kernel math namespaces prettyprint
|
||||
sequences strings vectors words win32-api win32-api-messages ;
|
||||
USING: inspector threads memory ;
|
||||
IN: win32
|
||||
|
||||
! world-handle is a <win>
|
||||
TUPLE: win hWnd hDC hRC world ;
|
||||
|
||||
SYMBOL: msg-obj
|
||||
SYMBOL: class-name
|
||||
|
||||
: random-class-name "Factor" 100000000 random-int unparse append ;
|
||||
|
||||
: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
|
||||
: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
|
||||
|
||||
: adjust-RECT ( RECT -- )
|
||||
style 0 ex-style AdjustWindowRectEx win32-error=0 ;
|
||||
|
||||
: make-RECT ( width height -- RECT )
|
||||
"RECT" <c-object> [ set-RECT-bottom ] keep [ set-RECT-right ] keep ;
|
||||
|
||||
: make-adjusted-RECT ( width height -- RECT )
|
||||
make-RECT dup adjust-RECT ;
|
||||
|
||||
|
||||
: get-RECT-dimensions ( RECT -- width height )
|
||||
[ RECT-right ] keep [ RECT-left - ] keep
|
||||
[ RECT-bottom ] keep RECT-top - ;
|
||||
|
||||
: handle-wm-paint ( hWnd uMsg wParam lParam -- )
|
||||
#! wParam and lParam are unused
|
||||
#! only paint if width/height both > 0
|
||||
3drop window dup rect-dim first2 [ 0 > ] 2apply and [ draw-world ] when ;
|
||||
|
||||
: handle-wm-size ( hWnd uMsg wParam lParam -- )
|
||||
[ lo-word ] keep hi-word make-RECT get-RECT-dimensions 0 3array
|
||||
2nip
|
||||
dup { 0 0 0 } = [ 2drop ] [ swap window set-gadget-dim ] if ;
|
||||
|
||||
: wm-keydown-codes ( n -- key )
|
||||
H{
|
||||
{ 8 "BACKSPACE" }
|
||||
{ 9 "TAB" }
|
||||
{ 13 "RETURN" }
|
||||
{ 27 "ESCAPE" }
|
||||
{ 33 "PAGE_UP" }
|
||||
{ 34 "PAGE_DOWN" }
|
||||
{ 35 "END" }
|
||||
{ 36 "HOME" }
|
||||
{ 37 "LEFT" }
|
||||
{ 38 "UP" }
|
||||
{ 39 "RIGHT" }
|
||||
{ 40 "DOWN" }
|
||||
{ 45 "INSERT" }
|
||||
{ 46 "DELETE" }
|
||||
} ;
|
||||
|
||||
|
||||
: key-state-down?
|
||||
GetKeyState 1 16 shift bitand 0 > ;
|
||||
|
||||
: left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
|
||||
: left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
|
||||
: left-alt? ( -- ? ) VK_LMENU key-state-down? ;
|
||||
: right-shift? ( -- ? ) VK_RSHIFT key-state-down? ;
|
||||
: right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ;
|
||||
: right-alt? ( -- ? ) VK_RMENU key-state-down? ;
|
||||
: shift? ( -- ? ) left-shift? right-shift? or ;
|
||||
: ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
|
||||
: alt? ( -- ? ) left-alt? right-alt? or ;
|
||||
: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
|
||||
|
||||
: key-modifiers ( -- list )
|
||||
[
|
||||
shift? [ S+ , ] when
|
||||
ctrl? [ C+ , ] when
|
||||
alt? [ A+ , ] when
|
||||
] { } make dup empty? f swap ? ;
|
||||
|
||||
: wm-char-exclude-keys
|
||||
H{
|
||||
{ 8 "BACKSPACE" }
|
||||
{ 9 "TAB" }
|
||||
{ 13 "RETURN" }
|
||||
} ;
|
||||
|
||||
: exclude-key? ( n -- bool ) wm-char-exclude-keys hash* nip ;
|
||||
: handle-key? ( n -- bool ) wm-keydown-codes hash* nip ;
|
||||
|
||||
: keystroke>gesture ( n -- <key-down> )
|
||||
dup wm-keydown-codes hash* [ nip ] [ drop ch>string ] if
|
||||
key-modifiers swap ;
|
||||
|
||||
SYMBOL: lParam
|
||||
SYMBOL: wParam
|
||||
SYMBOL: uMsg
|
||||
SYMBOL: hWnd
|
||||
|
||||
: get-focus ( hWnd -- gadget )
|
||||
window world-focus ;
|
||||
|
||||
: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
|
||||
lParam set wParam set uMsg set hWnd set
|
||||
wParam get handle-key? [
|
||||
wParam get keystroke>gesture <key-down> hWnd get get-focus handle-gesture
|
||||
[ wParam get ch>string hWnd get get-focus user-input ] when
|
||||
] when ;
|
||||
|
||||
: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
|
||||
lParam set wParam set uMsg set hWnd set
|
||||
wParam get keystroke>gesture <key-up> hWnd get get-focus handle-gesture
|
||||
drop ;
|
||||
|
||||
: handle-wm-char ( hWnd uMsg wParam lParam -- int )
|
||||
lParam set wParam set uMsg set hWnd set
|
||||
wParam get exclude-key? [
|
||||
wParam get ch>string hWnd get window world-focus
|
||||
2dup >r unit r> handle-gesture [
|
||||
user-input
|
||||
] [
|
||||
2drop
|
||||
] if
|
||||
] unless ;
|
||||
|
||||
: cleanup-window ( handle -- )
|
||||
[ win-hRC wglDeleteContext win32-error=0 ] keep
|
||||
[ win-hWnd ] keep win-hDC ReleaseDC win32-error=0 ;
|
||||
|
||||
: handle-wm-destroy ( hWnd uMsg wParam lParam -- )
|
||||
3drop
|
||||
[
|
||||
window [ world-handle ] keep
|
||||
[ close-world ] keep
|
||||
[ drop win-hWnd unregister-window ] 2keep
|
||||
drop cleanup-window
|
||||
] keep
|
||||
0 PostQuitMessage ;
|
||||
|
||||
: handle-wm-set-focus ( hWnd uMsg wParam lParam -- )
|
||||
3drop window focus-world ;
|
||||
|
||||
: handle-wm-kill-focus ( hWnd uMsg wParam lParam -- )
|
||||
3drop window unfocus-world ;
|
||||
|
||||
: mouse-button ( uMsg -- n )
|
||||
{
|
||||
{ [ dup WM_LBUTTONDOWN = ] [ drop 1 ] }
|
||||
{ [ dup WM_LBUTTONUP = ] [ drop 1 ] }
|
||||
{ [ dup WM_MBUTTONDOWN = ] [ drop 2 ] }
|
||||
{ [ dup WM_MBUTTONUP = ] [ drop 2 ] }
|
||||
{ [ dup WM_RBUTTONDOWN = ] [ drop 3 ] }
|
||||
{ [ dup WM_RBUTTONUP = ] [ drop 3 ] }
|
||||
{ [ t ] [ "bad button" throw ] }
|
||||
} cond ;
|
||||
|
||||
: mouse-coordinate ( lParam -- seq ) [ lo-word ] keep hi-word 0 3array ;
|
||||
: mouse-wheel ( lParam -- n ) hi-word 0 > 1 -1 ? ;
|
||||
|
||||
: prepare-mouse ( hWnd uMsg wParam lParam -- world )
|
||||
nip >r mouse-button r> mouse-coordinate rot window ;
|
||||
|
||||
: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
|
||||
prepare-mouse send-button-down ;
|
||||
|
||||
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
|
||||
prepare-mouse send-button-up ;
|
||||
|
||||
: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
|
||||
2nip mouse-coordinate swap window move-hand ;
|
||||
|
||||
: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
|
||||
mouse-coordinate >r mouse-wheel nip r> rot window send-wheel ;
|
||||
|
||||
! return 0 if you handle the message, else just let DefWindowProc return its val
|
||||
: ui-wndproc ( hWnd uMsg wParam lParam -- lresult )
|
||||
"uint" { "void*" "uint" "long" "long" } [
|
||||
[
|
||||
pick
|
||||
! "Message: " write dup get-windows-message-name write
|
||||
! " " write dup unparse print
|
||||
{
|
||||
{ [ dup WM_DESTROY = ] [ drop handle-wm-destroy 0 ] }
|
||||
{ [ dup WM_PAINT = ] [ drop handle-wm-paint 0 ] }
|
||||
{ [ dup WM_SIZE = ] [ drop handle-wm-size 0 ] }
|
||||
|
||||
! Keyboard events
|
||||
{ [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ]
|
||||
[ drop handle-wm-keydown 0 ] }
|
||||
{ [ dup WM_KEYUP = over WM_SYSKEYUP = or ]
|
||||
[ drop handle-wm-keyup 0 ] }
|
||||
{ [ dup WM_CHAR = over WM_SYSCHAR = or ]
|
||||
[ drop handle-wm-char 0 ] }
|
||||
|
||||
{ [ dup WM_SETFOCUS = ] [ drop handle-wm-set-focus 0 ] }
|
||||
{ [ dup WM_KILLFOCUS = ] [ drop handle-wm-kill-focus 0 ] }
|
||||
|
||||
! Mouse events
|
||||
{ [ dup WM_LBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] }
|
||||
{ [ dup WM_MBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] }
|
||||
{ [ dup WM_RBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] }
|
||||
{ [ dup WM_LBUTTONUP = ] [ drop handle-wm-buttonup 0 ] }
|
||||
{ [ dup WM_MBUTTONUP = ] [ drop handle-wm-buttonup 0 ] }
|
||||
{ [ dup WM_RBUTTONUP = ] [ drop handle-wm-buttonup 0 ] }
|
||||
{ [ dup WM_MOUSEMOVE = ] [ drop handle-wm-mousemove 0 ] }
|
||||
{ [ dup WM_MOUSEWHEEL = ] [ drop handle-wm-mousewheel 0 ] }
|
||||
|
||||
{ [ t ] [ drop DefWindowProc ] }
|
||||
} cond
|
||||
] [ error. 0 ] recover
|
||||
] alien-callback ;
|
||||
|
||||
: event-loop ( -- )
|
||||
! "MSG'D" print flush
|
||||
msg-obj get f 0 0 PM_REMOVE PeekMessage
|
||||
zero? not [
|
||||
msg-obj get MSG-message WM_QUIT = [
|
||||
msg-obj get [ TranslateMessage drop ] keep DispatchMessage drop
|
||||
] unless
|
||||
] when
|
||||
ui-step windows get empty? [ event-loop ] unless ;
|
||||
|
||||
: register-wndclassex ( classname wndproc -- )
|
||||
"WNDCLASSEX" <c-object>
|
||||
"WNDCLASSEX" c-size over set-WNDCLASSEX-cbSize
|
||||
CS_HREDRAW CS_VREDRAW bitor CS_OWNDC bitor over set-WNDCLASSEX-style
|
||||
[ set-WNDCLASSEX-lpfnWndProc ] keep
|
||||
0 over set-WNDCLASSEX-cbClsExtra
|
||||
0 over set-WNDCLASSEX-cbWndExtra
|
||||
f GetModuleHandle over set-WNDCLASSEX-hInstance
|
||||
f IDI_APPLICATION LoadIcon over set-WNDCLASSEX-hIcon
|
||||
f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
|
||||
[ set-WNDCLASSEX-lpszClassName ] keep
|
||||
RegisterClassEx dup win32-error=0 ;
|
||||
|
||||
: create-window ( width height -- hwnd )
|
||||
make-adjusted-RECT
|
||||
>r class-name get <malloc-string>
|
||||
"The Title" <malloc-string> r>
|
||||
>r >r >r ex-style r> r>
|
||||
WS_CLIPSIBLINGS WS_CLIPCHILDREN bitor style bitor
|
||||
0 0 r>
|
||||
get-RECT-dimensions
|
||||
f f f GetModuleHandle f CreateWindowEx dup win32-error=0 ;
|
||||
|
||||
: show-window ( hWnd -- )
|
||||
dup SW_SHOW ShowWindow drop ! always succeeds
|
||||
dup SetForegroundWindow drop
|
||||
SetFocus drop ;
|
||||
|
||||
: init-win32-ui
|
||||
"MSG" <c-object> msg-obj set
|
||||
random-class-name class-name set
|
||||
class-name get <malloc-string> ui-wndproc
|
||||
register-wndclassex win32-error=0 ;
|
||||
|
||||
: cleanup-win32-ui ( -- )
|
||||
class-name get <malloc-string> f UnregisterClass drop ;
|
||||
|
||||
: setup-pixel-format ( hdc -- )
|
||||
16 make-pfd [ ChoosePixelFormat dup win32-error=0 ] 2keep
|
||||
swapd SetPixelFormat win32-error=0 ;
|
||||
|
||||
: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0 ;
|
||||
|
||||
: get-rc ( hDC -- hRC )
|
||||
dup wglCreateContext dup win32-error=0
|
||||
[ wglMakeCurrent win32-error=0 ] keep ;
|
||||
|
||||
: setup-gl ( hwnd -- hDC hRC )
|
||||
get-dc
|
||||
dup setup-pixel-format
|
||||
dup get-rc ;
|
||||
|
||||
|
||||
IN: gadgets
|
||||
|
||||
: open-window* ( world -- ) ! new
|
||||
[ rect-dim first2 create-window dup setup-gl ] keep
|
||||
[ <win> ] keep
|
||||
[ swap win-hWnd register-window ] 2keep
|
||||
[ set-world-handle ] 2keep
|
||||
start-world win-hWnd show-window ;
|
||||
|
||||
: select-gl-context ( handle -- )
|
||||
[ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0 ;
|
||||
|
||||
: flush-gl-context ( handle -- )
|
||||
win-hDC SwapBuffers win32-error=0 ;
|
||||
|
||||
! Move window to front
|
||||
: raise-window ( world -- )
|
||||
world-handle win-hWnd SetFocus drop ;
|
||||
|
||||
: set-title ( string world -- )
|
||||
world-handle win-hWnd
|
||||
swap <malloc-string> alien-address >r WM_SETTEXT 0 r> SendMessage drop ;
|
||||
|
||||
IN: shells
|
||||
: ui
|
||||
[
|
||||
[
|
||||
init-timers
|
||||
! init-clipboard
|
||||
init-win32-ui
|
||||
restore-windows? [
|
||||
restore-windows
|
||||
] [
|
||||
init-ui
|
||||
launchpad-window
|
||||
listener-window
|
||||
] if
|
||||
event-loop
|
||||
] with-freetype
|
||||
] [ cleanup-win32-ui ] cleanup ;
|
||||
|
||||
IN: kernel
|
||||
: default-shell "ui" ;
|
||||
|
||||
Loading…
Reference in New Issue