Merge branch 'master' of git://factorcode.org/git/factor
commit
6ed46177e9
|
@ -1,15 +1,13 @@
|
||||||
USING: calendar namespaces alien.c-types system
|
USING: calendar namespaces alien.c-types system
|
||||||
windows.kernel32 kernel math combinators windows.errors ;
|
windows.kernel32 kernel math combinators windows.errors
|
||||||
|
accessors classes.struct ;
|
||||||
IN: calendar.windows
|
IN: calendar.windows
|
||||||
|
|
||||||
M: windows gmt-offset ( -- hours minutes seconds )
|
M: windows gmt-offset ( -- hours minutes seconds )
|
||||||
"TIME_ZONE_INFORMATION" <c-object>
|
TIME_ZONE_INFORMATION <struct>
|
||||||
dup GetTimeZoneInformation {
|
dup GetTimeZoneInformation {
|
||||||
{ TIME_ZONE_ID_INVALID [ win32-error-string throw ] }
|
{ TIME_ZONE_ID_INVALID [ win32-error-string throw ] }
|
||||||
{ TIME_ZONE_ID_UNKNOWN [ TIME_ZONE_INFORMATION-Bias ] }
|
{ TIME_ZONE_ID_UNKNOWN [ Bias>> ] }
|
||||||
{ TIME_ZONE_ID_STANDARD [ TIME_ZONE_INFORMATION-Bias ] }
|
{ TIME_ZONE_ID_STANDARD [ Bias>> ] }
|
||||||
{ TIME_ZONE_ID_DAYLIGHT [
|
{ TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] }
|
||||||
[ TIME_ZONE_INFORMATION-Bias ]
|
|
||||||
[ TIME_ZONE_INFORMATION-DaylightBias ] bi +
|
|
||||||
] }
|
|
||||||
} case neg 60 /mod 0 ;
|
} case neg 60 /mod 0 ;
|
||||||
|
|
|
@ -6,8 +6,10 @@ alien.c-types sequences windows.errors io.streams.memory
|
||||||
io.encodings io ;
|
io.encodings io ;
|
||||||
IN: environment.winnt
|
IN: environment.winnt
|
||||||
|
|
||||||
|
<< "TCHAR" require-c-type-arrays >>
|
||||||
|
|
||||||
M: winnt os-env ( key -- value )
|
M: winnt os-env ( key -- value )
|
||||||
MAX_UNICODE_PATH "TCHAR" <c-array>
|
MAX_UNICODE_PATH "TCHAR" <c-type-array>
|
||||||
[ dup length GetEnvironmentVariable ] keep over 0 = [
|
[ dup length GetEnvironmentVariable ] keep over 0 = [
|
||||||
2drop f
|
2drop f
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -6,7 +6,7 @@ math.rectangles namespaces parser sequences shuffle
|
||||||
struct-arrays ui.backend.windows vectors windows.com
|
struct-arrays ui.backend.windows vectors windows.com
|
||||||
windows.dinput windows.dinput.constants windows.errors
|
windows.dinput windows.dinput.constants windows.errors
|
||||||
windows.kernel32 windows.messages windows.ole32
|
windows.kernel32 windows.messages windows.ole32
|
||||||
windows.user32 ;
|
windows.user32 classes.struct ;
|
||||||
IN: game-input.dinput
|
IN: game-input.dinput
|
||||||
CONSTANT: MOUSE-BUFFER-SIZE 16
|
CONSTANT: MOUSE-BUFFER-SIZE 16
|
||||||
|
|
||||||
|
@ -162,7 +162,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
||||||
[ remove-controller ] each ;
|
[ remove-controller ] each ;
|
||||||
|
|
||||||
: device-interface? ( dbt-broadcast-hdr -- ? )
|
: device-interface? ( dbt-broadcast-hdr -- ? )
|
||||||
DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
|
dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = ;
|
||||||
|
|
||||||
: device-arrived ( dbt-broadcast-hdr -- )
|
: device-arrived ( dbt-broadcast-hdr -- )
|
||||||
device-interface? [ find-controllers ] when ;
|
device-interface? [ find-controllers ] when ;
|
||||||
|
@ -185,9 +185,9 @@ TUPLE: window-rect < rect window-loc ;
|
||||||
{ 0 0 } >>dim ;
|
{ 0 0 } >>dim ;
|
||||||
|
|
||||||
: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
|
: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
|
||||||
"DEV_BROADCAST_DEVICEW" <c-object>
|
DEV_BROADCAST_DEVICEW <struct>
|
||||||
"DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
|
DEV_BROADCAST_DEVICEW heap-size >>dbcc_size
|
||||||
DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
|
DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ;
|
||||||
|
|
||||||
: create-device-change-window ( -- )
|
: create-device-change-window ( -- )
|
||||||
<zero-window-rect> WS_OVERLAPPEDWINDOW 0 create-window
|
<zero-window-rect> WS_OVERLAPPEDWINDOW 0 create-window
|
||||||
|
@ -239,11 +239,13 @@ M: dinput-game-input-backend (close-game-input)
|
||||||
delete-dinput ;
|
delete-dinput ;
|
||||||
|
|
||||||
M: dinput-game-input-backend (reset-game-input)
|
M: dinput-game-input-backend (reset-game-input)
|
||||||
{
|
global [
|
||||||
+dinput+ +keyboard-device+ +keyboard-state+
|
{
|
||||||
+controller-devices+ +controller-guids+
|
+dinput+ +keyboard-device+ +keyboard-state+
|
||||||
+device-change-window+ +device-change-handle+
|
+controller-devices+ +controller-guids+
|
||||||
} [ f swap set-global ] each ;
|
+device-change-window+ +device-change-handle+
|
||||||
|
} [ off ] each
|
||||||
|
] bind ;
|
||||||
|
|
||||||
M: dinput-game-input-backend get-controllers
|
M: dinput-game-input-backend get-controllers
|
||||||
+controller-devices+ get
|
+controller-devices+ get
|
||||||
|
|
|
@ -4,7 +4,7 @@ USING: system io.directories io.encodings.utf16n alien.strings
|
||||||
io.pathnames io.backend io.files.windows destructors
|
io.pathnames io.backend io.files.windows destructors
|
||||||
kernel accessors calendar windows windows.errors
|
kernel accessors calendar windows windows.errors
|
||||||
windows.kernel32 alien.c-types sequences splitting
|
windows.kernel32 alien.c-types sequences splitting
|
||||||
fry continuations ;
|
fry continuations classes.struct ;
|
||||||
IN: io.directories.windows
|
IN: io.directories.windows
|
||||||
|
|
||||||
M: windows touch-file ( path -- )
|
M: windows touch-file ( path -- )
|
||||||
|
@ -33,12 +33,12 @@ M: windows delete-directory ( path -- )
|
||||||
RemoveDirectory win32-error=0/f ;
|
RemoveDirectory win32-error=0/f ;
|
||||||
|
|
||||||
: find-first-file ( path -- WIN32_FIND_DATA handle )
|
: find-first-file ( path -- WIN32_FIND_DATA handle )
|
||||||
"WIN32_FIND_DATA" <c-object>
|
WIN32_FIND_DATA <struct>
|
||||||
[ nip ] [ FindFirstFile ] 2bi
|
[ nip ] [ FindFirstFile ] 2bi
|
||||||
[ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
|
[ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
|
||||||
|
|
||||||
: find-next-file ( path -- WIN32_FIND_DATA/f )
|
: find-next-file ( path -- WIN32_FIND_DATA/f )
|
||||||
"WIN32_FIND_DATA" <c-object>
|
WIN32_FIND_DATA <struct>
|
||||||
[ nip ] [ FindNextFile ] 2bi 0 = [
|
[ nip ] [ FindNextFile ] 2bi 0 = [
|
||||||
GetLastError ERROR_NO_MORE_FILES = [
|
GetLastError ERROR_NO_MORE_FILES = [
|
||||||
win32-error
|
win32-error
|
||||||
|
@ -48,10 +48,11 @@ M: windows delete-directory ( path -- )
|
||||||
TUPLE: windows-directory-entry < directory-entry attributes ;
|
TUPLE: windows-directory-entry < directory-entry attributes ;
|
||||||
|
|
||||||
M: windows >directory-entry ( byte-array -- directory-entry )
|
M: windows >directory-entry ( byte-array -- directory-entry )
|
||||||
[ WIN32_FIND_DATA-cFileName utf16n alien>string ]
|
[ cFileName>> utf16n alien>string ]
|
||||||
[ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
|
[
|
||||||
[ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
|
dwFileAttributes>>
|
||||||
tri
|
[ win32-file-type ] [ win32-file-attributes ] bi
|
||||||
|
] bi
|
||||||
dupd remove windows-directory-entry boa ;
|
dupd remove windows-directory-entry boa ;
|
||||||
|
|
||||||
M: windows (directory-entries) ( path -- seq )
|
M: windows (directory-entries) ( path -- seq )
|
||||||
|
|
|
@ -5,7 +5,8 @@ io.files.windows io.files.windows.nt kernel windows.kernel32
|
||||||
windows.time windows accessors alien.c-types combinators
|
windows.time windows accessors alien.c-types combinators
|
||||||
generalizations system alien.strings io.encodings.utf16n
|
generalizations system alien.strings io.encodings.utf16n
|
||||||
sequences splitting windows.errors fry continuations destructors
|
sequences splitting windows.errors fry continuations destructors
|
||||||
calendar ascii combinators.short-circuit locals classes.struct ;
|
calendar ascii combinators.short-circuit locals classes.struct
|
||||||
|
specialized-arrays.ushort ;
|
||||||
IN: io.files.info.windows
|
IN: io.files.info.windows
|
||||||
|
|
||||||
:: round-up-to ( n multiple -- n' )
|
:: round-up-to ( n multiple -- n' )
|
||||||
|
@ -35,20 +36,17 @@ TUPLE: windows-file-info < file-info attributes ;
|
||||||
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
|
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
|
||||||
[ \ windows-file-info new ] dip
|
[ \ windows-file-info new ] dip
|
||||||
{
|
{
|
||||||
[ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
|
[ dwFileAttributes>> win32-file-type >>type ]
|
||||||
[ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ]
|
[ dwFileAttributes>> win32-file-attributes >>attributes ]
|
||||||
[
|
[ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit >>size ]
|
||||||
[ WIN32_FIND_DATA-nFileSizeLow ]
|
[ dwFileAttributes>> >>permissions ]
|
||||||
[ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
|
[ ftCreationTime>> FILETIME>timestamp >>created ]
|
||||||
]
|
[ ftLastWriteTime>> FILETIME>timestamp >>modified ]
|
||||||
[ WIN32_FIND_DATA-dwFileAttributes >>permissions ]
|
[ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
|
||||||
[ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ]
|
|
||||||
[ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ]
|
|
||||||
[ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ]
|
|
||||||
} cleave ;
|
} cleave ;
|
||||||
|
|
||||||
: find-first-file-stat ( path -- WIN32_FIND_DATA )
|
: find-first-file-stat ( path -- WIN32_FIND_DATA )
|
||||||
"WIN32_FIND_DATA" <c-object> [
|
WIN32_FIND_DATA <struct> [
|
||||||
FindFirstFile
|
FindFirstFile
|
||||||
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
|
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
|
||||||
FindClose win32-error=0/f
|
FindClose win32-error=0/f
|
||||||
|
@ -147,7 +145,7 @@ M: winnt file-system-info ( path -- file-system-info )
|
||||||
calculate-file-system-info ;
|
calculate-file-system-info ;
|
||||||
|
|
||||||
: volume>paths ( string -- array )
|
: volume>paths ( string -- array )
|
||||||
16384 "ushort" <c-array> tuck dup length
|
16384 <ushort-array> tuck dup length
|
||||||
0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
|
0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
|
||||||
win32-error-string throw
|
win32-error-string throw
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -5,19 +5,18 @@ windows.kernel32 kernel libc math threads system environment
|
||||||
alien.c-types alien.arrays alien.strings sequences combinators
|
alien.c-types alien.arrays alien.strings sequences combinators
|
||||||
combinators.short-circuit ascii splitting alien strings assocs
|
combinators.short-circuit ascii splitting alien strings assocs
|
||||||
namespaces make accessors tr windows.time windows.shell32
|
namespaces make accessors tr windows.time windows.shell32
|
||||||
windows.errors ;
|
windows.errors specialized-arrays.ushort classes.struct ;
|
||||||
IN: io.files.windows.nt
|
IN: io.files.windows.nt
|
||||||
|
|
||||||
M: winnt cwd
|
M: winnt cwd
|
||||||
MAX_UNICODE_PATH dup "ushort" <c-array>
|
MAX_UNICODE_PATH dup <ushort-array>
|
||||||
[ GetCurrentDirectory win32-error=0/f ] keep
|
[ GetCurrentDirectory win32-error=0/f ] keep
|
||||||
utf16n alien>string ;
|
utf16n alien>string ;
|
||||||
|
|
||||||
M: winnt cd
|
M: winnt cd
|
||||||
SetCurrentDirectory win32-error=0/f ;
|
SetCurrentDirectory win32-error=0/f ;
|
||||||
|
|
||||||
: unicode-prefix ( -- seq )
|
CONSTANT: unicode-prefix "\\\\?\\"
|
||||||
"\\\\?\\" ; inline
|
|
||||||
|
|
||||||
M: winnt root-directory? ( path -- ? )
|
M: winnt root-directory? ( path -- ? )
|
||||||
{
|
{
|
||||||
|
@ -48,10 +47,9 @@ M: winnt CreateFile-flags ( DWORD -- DWORD )
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: windows-file-size ( path -- size )
|
: windows-file-size ( path -- size )
|
||||||
normalize-path 0 "WIN32_FILE_ATTRIBUTE_DATA" <c-object>
|
normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
|
||||||
[ GetFileAttributesEx win32-error=0/f ] keep
|
[ GetFileAttributesEx win32-error=0/f ] keep
|
||||||
[ WIN32_FILE_ATTRIBUTE_DATA-nFileSizeLow ]
|
[ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ;
|
||||||
[ WIN32_FILE_ATTRIBUTE_DATA-nFileSizeHigh ] bi >64bit ;
|
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -7,7 +7,7 @@ system accessors threads splitting io.backend io.backend.windows
|
||||||
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
|
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
|
||||||
io.buffers io.files io.timeouts io.encodings.string
|
io.buffers io.files io.timeouts io.encodings.string
|
||||||
io.encodings.utf16n io windows.errors windows.kernel32 windows.types
|
io.encodings.utf16n io windows.errors windows.kernel32 windows.types
|
||||||
io.pathnames ;
|
io.pathnames classes.struct ;
|
||||||
IN: io.monitors.windows.nt
|
IN: io.monitors.windows.nt
|
||||||
|
|
||||||
: open-directory ( path -- handle )
|
: open-directory ( path -- handle )
|
||||||
|
@ -55,17 +55,14 @@ TUPLE: win32-monitor < monitor port ;
|
||||||
memory>byte-array utf16n decode ;
|
memory>byte-array utf16n decode ;
|
||||||
|
|
||||||
: parse-notify-record ( buffer -- path changed )
|
: parse-notify-record ( buffer -- path changed )
|
||||||
[
|
[ [ FileName>> ] [ FileNameLength>> ] bi memory>u16-string ]
|
||||||
[ FILE_NOTIFY_INFORMATION-FileName ]
|
[ Action>> parse-action ] bi ;
|
||||||
[ FILE_NOTIFY_INFORMATION-FileNameLength ]
|
|
||||||
bi memory>u16-string
|
|
||||||
]
|
|
||||||
[ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ;
|
|
||||||
|
|
||||||
: (file-notify-records) ( buffer -- buffer )
|
: (file-notify-records) ( buffer -- buffer )
|
||||||
|
FILE_NOTIFY_INFORMATION memory>struct
|
||||||
dup ,
|
dup ,
|
||||||
dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [
|
dup NextEntryOffset>> zero? [
|
||||||
[ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien>
|
[ NextEntryOffset>> ] [ >c-ptr <displaced-alien> ] bi
|
||||||
(file-notify-records)
|
(file-notify-records)
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,8 @@ USING: alien alien.accessors alien.c-types byte-arrays
|
||||||
continuations destructors io.ports io.timeouts io.sockets
|
continuations destructors io.ports io.timeouts io.sockets
|
||||||
io namespaces io.streams.duplex io.backend.windows
|
io namespaces io.streams.duplex io.backend.windows
|
||||||
io.sockets.windows io.backend.windows.nt windows.winsock kernel
|
io.sockets.windows io.backend.windows.nt windows.winsock kernel
|
||||||
libc math sequences threads system combinators accessors ;
|
libc math sequences threads system combinators accessors
|
||||||
|
classes.struct windows.kernel32 ;
|
||||||
IN: io.sockets.windows.nt
|
IN: io.sockets.windows.nt
|
||||||
|
|
||||||
: malloc-int ( object -- object )
|
: malloc-int ( object -- object )
|
||||||
|
@ -14,7 +15,7 @@ M: winnt WSASocket-flags ( -- DWORD )
|
||||||
: get-ConnectEx-ptr ( socket -- void* )
|
: get-ConnectEx-ptr ( socket -- void* )
|
||||||
SIO_GET_EXTENSION_FUNCTION_POINTER
|
SIO_GET_EXTENSION_FUNCTION_POINTER
|
||||||
WSAID_CONNECTEX
|
WSAID_CONNECTEX
|
||||||
"GUID" heap-size
|
GUID heap-size
|
||||||
"void*" <c-object>
|
"void*" <c-object>
|
||||||
[
|
[
|
||||||
"void*" heap-size
|
"void*" heap-size
|
||||||
|
@ -127,9 +128,9 @@ TUPLE: WSARecvFrom-args port
|
||||||
lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
|
lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
|
||||||
|
|
||||||
: make-receive-buffer ( -- WSABUF )
|
: make-receive-buffer ( -- WSABUF )
|
||||||
"WSABUF" malloc-object &free
|
WSABUF malloc-struct &free
|
||||||
default-buffer-size get over set-WSABUF-len
|
default-buffer-size get
|
||||||
default-buffer-size get malloc &free over set-WSABUF-buf ; inline
|
[ >>len ] [ malloc &free >>buf ] bi ; inline
|
||||||
|
|
||||||
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
|
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
|
||||||
WSARecvFrom-args new
|
WSARecvFrom-args new
|
||||||
|
@ -158,7 +159,7 @@ TUPLE: WSARecvFrom-args port
|
||||||
} cleave WSARecvFrom socket-error* ; inline
|
} cleave WSARecvFrom socket-error* ; inline
|
||||||
|
|
||||||
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
|
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
|
||||||
[ lpBuffers>> WSABUF-buf swap memory>byte-array ]
|
[ lpBuffers>> buf>> swap memory>byte-array ]
|
||||||
[ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
|
[ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
|
||||||
|
|
||||||
M: winnt (receive) ( datagram -- packet addrspec )
|
M: winnt (receive) ( datagram -- packet addrspec )
|
||||||
|
@ -175,11 +176,9 @@ TUPLE: WSASendTo-args port
|
||||||
dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
|
dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
|
||||||
|
|
||||||
: make-send-buffer ( packet -- WSABUF )
|
: make-send-buffer ( packet -- WSABUF )
|
||||||
"WSABUF" malloc-object &free
|
[ WSABUF malloc-struct &free ] dip
|
||||||
[ [ malloc-byte-array &free ] dip set-WSABUF-buf ]
|
[ malloc-byte-array &free >>buf ]
|
||||||
[ [ length ] dip set-WSABUF-len ]
|
[ length >>len ] bi ; inline
|
||||||
[ nip ]
|
|
||||||
2tri ; inline
|
|
||||||
|
|
||||||
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
|
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
|
||||||
WSASendTo-args new
|
WSASendTo-args new
|
||||||
|
|
|
@ -260,12 +260,14 @@ CONSTANT: window-control>ex-style
|
||||||
window-controls>> window-control>ex-style symbols>flags ;
|
window-controls>> window-control>ex-style symbols>flags ;
|
||||||
|
|
||||||
: get-RECT-top-left ( RECT -- x y )
|
: get-RECT-top-left ( RECT -- x y )
|
||||||
[ RECT-left ] keep RECT-top ;
|
[ left>> ] [ top>> ] bi ;
|
||||||
|
|
||||||
|
: get-RECT-width/height ( RECT -- width height )
|
||||||
|
[ [ right>> ] [ left>> ] bi - ]
|
||||||
|
[ [ bottom>> ] [ top>> ] bi - ] bi ;
|
||||||
|
|
||||||
: get-RECT-dimensions ( RECT -- x y width height )
|
: get-RECT-dimensions ( RECT -- x y width height )
|
||||||
[ get-RECT-top-left ] keep
|
[ get-RECT-top-left ] [ get-RECT-width/height ] bi ;
|
||||||
[ RECT-right ] keep [ RECT-left - ] keep
|
|
||||||
[ 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
|
||||||
|
@ -503,14 +505,15 @@ SYMBOL: nc-buttons
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: make-TRACKMOUSEEVENT ( hWnd -- alien )
|
: make-TRACKMOUSEEVENT ( hWnd -- alien )
|
||||||
"TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
|
TRACKMOUSEEVENT <struct>
|
||||||
"TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
|
swap >>hwndTrack
|
||||||
|
TRACKMOUSEEVENT heap-size >>cbSize ;
|
||||||
|
|
||||||
: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
|
: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
|
||||||
2nip
|
2nip
|
||||||
over make-TRACKMOUSEEVENT
|
over make-TRACKMOUSEEVENT
|
||||||
TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
|
TME_LEAVE >>dwFlags
|
||||||
0 over set-TRACKMOUSEEVENT-dwHoverTime
|
0 >>dwHoverTime
|
||||||
TrackMouseEvent drop
|
TrackMouseEvent drop
|
||||||
>lo-hi swap window move-hand fire-motion ;
|
>lo-hi swap window move-hand fire-motion ;
|
||||||
|
|
||||||
|
@ -588,19 +591,18 @@ M: windows-ui-backend do-events
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
:: register-window-class ( class-name-ptr -- )
|
:: register-window-class ( class-name-ptr -- )
|
||||||
"WNDCLASSEX" <c-object> f GetModuleHandle
|
WNDCLASSEX <struct> f GetModuleHandle
|
||||||
class-name-ptr pick GetClassInfoEx 0 = [
|
class-name-ptr pick GetClassInfoEx 0 = [
|
||||||
"WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
|
WNDCLASSEX heap-size >>cbSize
|
||||||
{ CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
|
{ CS_HREDRAW CS_VREDRAW CS_OWNDC } flags >>style
|
||||||
ui-wndproc over set-WNDCLASSEX-lpfnWndProc
|
ui-wndproc >>lpfnWndProc
|
||||||
0 over set-WNDCLASSEX-cbClsExtra
|
0 >>cbClsExtra
|
||||||
0 over set-WNDCLASSEX-cbWndExtra
|
0 >>cbWndExtra
|
||||||
f GetModuleHandle over set-WNDCLASSEX-hInstance
|
f GetModuleHandle >>hInstance
|
||||||
f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
|
f GetModuleHandle "fraptor" utf16n string>alien LoadIcon >>hIcon
|
||||||
over set-WNDCLASSEX-hIcon
|
f IDC_ARROW LoadCursor >>hCursor
|
||||||
f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
|
|
||||||
|
|
||||||
class-name-ptr over set-WNDCLASSEX-lpszClassName
|
class-name-ptr >>lpszClassName
|
||||||
RegisterClassEx win32-error=0/f
|
RegisterClassEx win32-error=0/f
|
||||||
] [ drop ] if ;
|
] [ drop ] if ;
|
||||||
|
|
||||||
|
@ -610,12 +612,12 @@ M: windows-ui-backend do-events
|
||||||
: make-RECT ( world -- RECT )
|
: make-RECT ( world -- RECT )
|
||||||
[ window-loc>> ] [ dim>> ] bi <RECT> ;
|
[ window-loc>> ] [ dim>> ] bi <RECT> ;
|
||||||
|
|
||||||
: default-position-RECT ( RECT -- )
|
: default-position-RECT ( RECT -- RECT' )
|
||||||
dup get-RECT-dimensions [ 2drop ] 2dip
|
dup get-RECT-width/height
|
||||||
CW_USEDEFAULT + pick set-RECT-bottom
|
[ CW_USEDEFAULT + >>bottom ] dip
|
||||||
CW_USEDEFAULT + over set-RECT-right
|
CW_USEDEFAULT + >>right
|
||||||
CW_USEDEFAULT over set-RECT-left
|
CW_USEDEFAULT >>left
|
||||||
CW_USEDEFAULT swap set-RECT-top ;
|
CW_USEDEFAULT >>top ;
|
||||||
|
|
||||||
: make-adjusted-RECT ( rect style ex-style -- RECT )
|
: make-adjusted-RECT ( rect style ex-style -- RECT )
|
||||||
[
|
[
|
||||||
|
@ -623,7 +625,7 @@ M: windows-ui-backend do-events
|
||||||
dup get-RECT-top-left [ zero? ] both? swap
|
dup get-RECT-top-left [ zero? ] both? swap
|
||||||
dup
|
dup
|
||||||
] 2dip adjust-RECT
|
] 2dip adjust-RECT
|
||||||
swap [ dup default-position-RECT ] when ;
|
swap [ default-position-RECT ] when ;
|
||||||
|
|
||||||
: get-window-class ( -- class-name )
|
: get-window-class ( -- class-name )
|
||||||
class-name-ptr [
|
class-name-ptr [
|
||||||
|
@ -749,17 +751,18 @@ M: windows-ui-backend beep ( -- )
|
||||||
|
|
||||||
: fullscreen-RECT ( hwnd -- RECT )
|
: fullscreen-RECT ( hwnd -- RECT )
|
||||||
MONITOR_DEFAULTTONEAREST MonitorFromWindow
|
MONITOR_DEFAULTTONEAREST MonitorFromWindow
|
||||||
"MONITORINFOEX" <c-object> dup length over set-MONITORINFOEX-cbSize
|
MONITORINFOEX <struct>
|
||||||
[ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ;
|
MONITORINFOEX heap-size >>cbSize
|
||||||
|
[ GetMonitorInfo win32-error=0/f ] keep rcMonitor>> ;
|
||||||
|
|
||||||
: client-area>RECT ( hwnd -- RECT )
|
: client-area>RECT ( hwnd -- RECT )
|
||||||
"RECT" <c-object>
|
RECT <struct>
|
||||||
[ GetClientRect win32-error=0/f ]
|
[ GetClientRect win32-error=0/f ]
|
||||||
[ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
|
[ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
|
||||||
[ nip ] 2tri ;
|
[ nip ] 2tri ;
|
||||||
|
|
||||||
: hwnd>RECT ( hwnd -- RECT )
|
: hwnd>RECT ( hwnd -- RECT )
|
||||||
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep ;
|
RECT <struct> [ GetWindowRect win32-error=0/f ] keep ;
|
||||||
|
|
||||||
M: windows-ui-backend (grab-input) ( handle -- )
|
M: windows-ui-backend (grab-input) ( handle -- )
|
||||||
0 ShowCursor drop
|
0 ShowCursor drop
|
||||||
|
|
|
@ -1,18 +1,16 @@
|
||||||
USING: alien alien.c-types alien.accessors effects kernel
|
USING: alien alien.c-types alien.accessors effects kernel
|
||||||
windows.ole32 parser lexer splitting grouping sequences
|
windows.ole32 parser lexer splitting grouping sequences
|
||||||
namespaces assocs quotations generalizations accessors words
|
namespaces assocs quotations generalizations accessors words
|
||||||
macros alien.syntax fry arrays layouts math ;
|
macros alien.syntax fry arrays layouts math classes.struct
|
||||||
|
windows.kernel32 prettyprint.custom prettyprint.sections ;
|
||||||
IN: windows.com.syntax
|
IN: windows.com.syntax
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
C-STRUCT: com-interface
|
|
||||||
{ "void*" "vtbl" } ;
|
|
||||||
|
|
||||||
MACRO: com-invoke ( n return parameters -- )
|
MACRO: com-invoke ( n return parameters -- )
|
||||||
[ 2nip length ] 3keep
|
[ 2nip length ] 3keep
|
||||||
'[
|
'[
|
||||||
_ npick com-interface-vtbl _ cell * alien-cell _ _
|
_ npick *void* _ cell * alien-cell _ _
|
||||||
"stdcall" alien-indirect
|
"stdcall" alien-indirect
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
|
@ -31,7 +29,7 @@ unless
|
||||||
dup "f" = [ drop f ] [
|
dup "f" = [ drop f ] [
|
||||||
dup +com-interface-definitions+ get-global at*
|
dup +com-interface-definitions+ get-global at*
|
||||||
[ nip ]
|
[ nip ]
|
||||||
[ swap " COM interface hasn't been defined" append throw ]
|
[ " COM interface hasn't been defined" prepend throw ]
|
||||||
if
|
if
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
@ -100,3 +98,5 @@ SYNTAX: COM-INTERFACE:
|
||||||
define-words-for-com-interface ;
|
define-words-for-com-interface ;
|
||||||
|
|
||||||
SYNTAX: GUID: scan string>guid parsed ;
|
SYNTAX: GUID: scan string>guid parsed ;
|
||||||
|
|
||||||
|
M: GUID pprint* guid>string "GUID: " prepend text ;
|
||||||
|
|
|
@ -48,7 +48,7 @@ unless
|
||||||
: (make-query-interface) ( interfaces -- quot )
|
: (make-query-interface) ( interfaces -- quot )
|
||||||
(query-interface-cases)
|
(query-interface-cases)
|
||||||
'[
|
'[
|
||||||
swap 16 memory>byte-array
|
swap GUID memory>struct
|
||||||
_ case
|
_ case
|
||||||
[
|
[
|
||||||
"void*" heap-size * rot <displaced-alien> com-add-ref
|
"void*" heap-size * rot <displaced-alien> com-add-ref
|
||||||
|
|
|
@ -696,6 +696,8 @@ CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF
|
||||||
: make-lang-id ( lang1 lang2 -- n )
|
: make-lang-id ( lang1 lang2 -- n )
|
||||||
10 shift bitor ; inline
|
10 shift bitor ; inline
|
||||||
|
|
||||||
|
<< "TCHAR" require-c-type-arrays >>
|
||||||
|
|
||||||
ERROR: error-message-failed id ;
|
ERROR: error-message-failed id ;
|
||||||
:: n>win32-error-string ( id -- string )
|
:: n>win32-error-string ( id -- string )
|
||||||
{
|
{
|
||||||
|
@ -705,7 +707,7 @@ ERROR: error-message-failed id ;
|
||||||
f
|
f
|
||||||
id
|
id
|
||||||
LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id
|
LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id
|
||||||
32768 [ "TCHAR" <c-array> ] keep
|
32768 [ "TCHAR" <c-type-array> ] [ ] bi
|
||||||
f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip
|
f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip
|
||||||
utf16n alien>string [ blank? ] trim ;
|
utf16n alien>string [ blank? ] trim ;
|
||||||
|
|
||||||
|
|
|
@ -1,37 +1,37 @@
|
||||||
USING: assocs memoize locals kernel accessors init fonts math
|
USING: assocs memoize locals kernel accessors init fonts math
|
||||||
combinators windows.errors windows.types windows.gdi32 ;
|
combinators windows.errors windows.types windows.gdi32 ;
|
||||||
IN: windows.fonts
|
IN: windows.fonts
|
||||||
|
|
||||||
: windows-font-name ( string -- string' )
|
: windows-font-name ( string -- string' )
|
||||||
H{
|
H{
|
||||||
{ "sans-serif" "Tahoma" }
|
{ "sans-serif" "Tahoma" }
|
||||||
{ "serif" "Times New Roman" }
|
{ "serif" "Times New Roman" }
|
||||||
{ "monospace" "Courier New" }
|
{ "monospace" "Courier New" }
|
||||||
} ?at drop ;
|
} ?at drop ;
|
||||||
|
|
||||||
MEMO:: (cache-font) ( font -- HFONT )
|
MEMO:: (cache-font) ( font -- HFONT )
|
||||||
font size>> neg ! nHeight
|
font size>> neg ! nHeight
|
||||||
0 0 0 ! nWidth, nEscapement, nOrientation
|
0 0 0 ! nWidth, nEscapement, nOrientation
|
||||||
font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight
|
font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight
|
||||||
font italic?>> TRUE FALSE ? ! fdwItalic
|
font italic?>> TRUE FALSE ? ! fdwItalic
|
||||||
FALSE ! fdwUnderline
|
FALSE ! fdwUnderline
|
||||||
FALSE ! fdWStrikeOut
|
FALSE ! fdWStrikeOut
|
||||||
DEFAULT_CHARSET ! fdwCharSet
|
DEFAULT_CHARSET ! fdwCharSet
|
||||||
OUT_OUTLINE_PRECIS ! fdwOutputPrecision
|
OUT_OUTLINE_PRECIS ! fdwOutputPrecision
|
||||||
CLIP_DEFAULT_PRECIS ! fdwClipPrecision
|
CLIP_DEFAULT_PRECIS ! fdwClipPrecision
|
||||||
DEFAULT_QUALITY ! fdwQuality
|
DEFAULT_QUALITY ! fdwQuality
|
||||||
DEFAULT_PITCH ! fdwPitchAndFamily
|
DEFAULT_PITCH ! fdwPitchAndFamily
|
||||||
font name>> windows-font-name
|
font name>> windows-font-name
|
||||||
CreateFont
|
CreateFont
|
||||||
dup win32-error=0/f ;
|
dup win32-error=0/f ;
|
||||||
|
|
||||||
: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;
|
: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;
|
||||||
|
|
||||||
[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook
|
[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook
|
||||||
|
|
||||||
: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
|
: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
|
||||||
[ metrics new 0 >>width ] dip {
|
[ metrics new 0 >>width ] dip {
|
||||||
[ TEXTMETRICW-tmHeight >>height ]
|
[ tmHeight>> >>height ]
|
||||||
[ TEXTMETRICW-tmAscent >>ascent ]
|
[ tmAscent>> >>ascent ]
|
||||||
[ TEXTMETRICW-tmDescent >>descent ]
|
[ tmDescent>> >>descent ]
|
||||||
} cleave ;
|
} cleave ;
|
||||||
|
|
|
@ -90,11 +90,12 @@ CONSTANT: FILE_ACTION_MODIFIED 3
|
||||||
CONSTANT: FILE_ACTION_RENAMED_OLD_NAME 4
|
CONSTANT: FILE_ACTION_RENAMED_OLD_NAME 4
|
||||||
CONSTANT: FILE_ACTION_RENAMED_NEW_NAME 5
|
CONSTANT: FILE_ACTION_RENAMED_NEW_NAME 5
|
||||||
|
|
||||||
C-STRUCT: FILE_NOTIFY_INFORMATION
|
STRUCT: FILE_NOTIFY_INFORMATION
|
||||||
{ "DWORD" "NextEntryOffset" }
|
{ NextEntryOffset DWORD }
|
||||||
{ "DWORD" "Action" }
|
{ Action DWORD }
|
||||||
{ "DWORD" "FileNameLength" }
|
{ FileNameLength DWORD }
|
||||||
{ "WCHAR[1]" "FileName" } ;
|
{ FileName WCHAR[1] } ;
|
||||||
|
|
||||||
TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION
|
TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION
|
||||||
|
|
||||||
CONSTANT: STD_INPUT_HANDLE -10
|
CONSTANT: STD_INPUT_HANDLE -10
|
||||||
|
@ -226,14 +227,14 @@ STRUCT: SYSTEMTIME
|
||||||
{ wSecond WORD }
|
{ wSecond WORD }
|
||||||
{ wMilliseconds WORD } ;
|
{ wMilliseconds WORD } ;
|
||||||
|
|
||||||
C-STRUCT: TIME_ZONE_INFORMATION
|
STRUCT: TIME_ZONE_INFORMATION
|
||||||
{ "LONG" "Bias" }
|
{ Bias LONG }
|
||||||
{ { "WCHAR" 32 } "StandardName" }
|
{ StandardName WCHAR[32] }
|
||||||
{ "SYSTEMTIME" "StandardDate" }
|
{ StandardDate SYSTEMTIME }
|
||||||
{ "LONG" "StandardBias" }
|
{ StandardBias LONG }
|
||||||
{ { "WCHAR" 32 } "DaylightName" }
|
{ DaylightName WCHAR[32] }
|
||||||
{ "SYSTEMTIME" "DaylightDate" }
|
{ DaylightDate SYSTEMTIME }
|
||||||
{ "LONG" "DaylightBias" } ;
|
{ DaylightBias LONG } ;
|
||||||
|
|
||||||
STRUCT: FILETIME
|
STRUCT: FILETIME
|
||||||
{ dwLowDateTime DWORD }
|
{ dwLowDateTime DWORD }
|
||||||
|
@ -306,13 +307,13 @@ STRUCT: MEMORYSTATUSEX
|
||||||
|
|
||||||
TYPEDEF: void* LPMEMORYSTATUSEX
|
TYPEDEF: void* LPMEMORYSTATUSEX
|
||||||
|
|
||||||
C-STRUCT: OSVERSIONINFO
|
STRUCT: OSVERSIONINFO
|
||||||
{ "DWORD" "dwOSVersionInfoSize" }
|
{ dwOSVersionInfoSize DWORD }
|
||||||
{ "DWORD" "dwMajorVersion" }
|
{ dwMajorVersion DWORD }
|
||||||
{ "DWORD" "dwMinorVersion" }
|
{ dwMinorVersion DWORD }
|
||||||
{ "DWORD" "dwBuildNumber" }
|
{ dwBuildNumber DWORD }
|
||||||
{ "DWORD" "dwPlatformId" }
|
{ dwPlatformId DWORD }
|
||||||
{ { "WCHAR" 128 } "szCSDVersion" } ;
|
{ szCSDVersion WCHAR[128] } ;
|
||||||
|
|
||||||
TYPEDEF: void* LPOSVERSIONINFO
|
TYPEDEF: void* LPOSVERSIONINFO
|
||||||
|
|
||||||
|
@ -325,11 +326,11 @@ C-STRUCT: MEMORY_BASIC_INFORMATION
|
||||||
{ "DWORD" "protect" }
|
{ "DWORD" "protect" }
|
||||||
{ "DWORD" "type" } ;
|
{ "DWORD" "type" } ;
|
||||||
|
|
||||||
C-STRUCT: GUID
|
STRUCT: GUID
|
||||||
{ "ULONG" "Data1" }
|
{ Data1 ULONG }
|
||||||
{ "WORD" "Data2" }
|
{ Data2 WORD }
|
||||||
{ "WORD" "Data3" }
|
{ Data3 WORD }
|
||||||
{ { "UCHAR" 8 } "Data4" } ;
|
{ Data4 UCHAR[8] } ;
|
||||||
|
|
||||||
/*
|
/*
|
||||||
fBinary :1;
|
fBinary :1;
|
||||||
|
@ -659,13 +660,13 @@ C-STRUCT: TOKEN_PRIVILEGES
|
||||||
{ "LUID_AND_ATTRIBUTES*" "Privileges" } ;
|
{ "LUID_AND_ATTRIBUTES*" "Privileges" } ;
|
||||||
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
||||||
|
|
||||||
C-STRUCT: WIN32_FILE_ATTRIBUTE_DATA
|
STRUCT: WIN32_FILE_ATTRIBUTE_DATA
|
||||||
{ "DWORD" "dwFileAttributes" }
|
{ dwFileAttributes DWORD }
|
||||||
{ "FILETIME" "ftCreationTime" }
|
{ ftCreationTime FILETIME }
|
||||||
{ "FILETIME" "ftLastAccessTime" }
|
{ ftLastAccessTime FILETIME }
|
||||||
{ "FILETIME" "ftLastWriteTime" }
|
{ ftLastWriteTime FILETIME }
|
||||||
{ "DWORD" "nFileSizeHigh" }
|
{ nFileSizeHigh DWORD }
|
||||||
{ "DWORD" "nFileSizeLow" } ;
|
{ nFileSizeLow DWORD } ;
|
||||||
TYPEDEF: WIN32_FILE_ATTRIBUTE_DATA* LPWIN32_FILE_ATTRIBUTE_DATA
|
TYPEDEF: WIN32_FILE_ATTRIBUTE_DATA* LPWIN32_FILE_ATTRIBUTE_DATA
|
||||||
|
|
||||||
C-STRUCT: BY_HANDLE_FILE_INFORMATION
|
C-STRUCT: BY_HANDLE_FILE_INFORMATION
|
||||||
|
@ -694,19 +695,17 @@ C-STRUCT: OFSTRUCT
|
||||||
|
|
||||||
TYPEDEF: OFSTRUCT* LPOFSTRUCT
|
TYPEDEF: OFSTRUCT* LPOFSTRUCT
|
||||||
|
|
||||||
! MAX_PATH = 260
|
STRUCT: WIN32_FIND_DATA
|
||||||
C-STRUCT: WIN32_FIND_DATA
|
{ dwFileAttributes DWORD }
|
||||||
{ "DWORD" "dwFileAttributes" }
|
{ ftCreationTime FILETIME }
|
||||||
{ "FILETIME" "ftCreationTime" }
|
{ ftLastAccessTime FILETIME }
|
||||||
{ "FILETIME" "ftLastAccessTime" }
|
{ ftLastWriteTime FILETIME }
|
||||||
{ "FILETIME" "ftLastWriteTime" }
|
{ nFileSizeHigh DWORD }
|
||||||
{ "DWORD" "nFileSizeHigh" }
|
{ nFileSizeLow DWORD }
|
||||||
{ "DWORD" "nFileSizeLow" }
|
{ dwReserved0 DWORD }
|
||||||
{ "DWORD" "dwReserved0" }
|
{ dwReserved1 DWORD }
|
||||||
{ "DWORD" "dwReserved1" }
|
{ cFileName { "TCHAR" MAX_PATH } }
|
||||||
! { { "TCHAR" MAX_PATH } "cFileName" }
|
{ cAlternateFileName TCHAR[14] } ;
|
||||||
{ { "TCHAR" 260 } "cFileName" }
|
|
||||||
{ { "TCHAR" 14 } "cAlternateFileName" } ;
|
|
||||||
|
|
||||||
STRUCT: BY_HANDLE_FILE_INFORMATION
|
STRUCT: BY_HANDLE_FILE_INFORMATION
|
||||||
{ dwFileAttributes DWORD }
|
{ dwFileAttributes DWORD }
|
||||||
|
|
|
@ -2,25 +2,26 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien.c-types kernel combinators sequences
|
USING: alien.c-types kernel combinators sequences
|
||||||
math windows.gdi32 windows.types images destructors
|
math windows.gdi32 windows.types images destructors
|
||||||
accessors fry locals ;
|
accessors fry locals classes.struct ;
|
||||||
IN: windows.offscreen
|
IN: windows.offscreen
|
||||||
|
|
||||||
: (bitmap-info) ( dim -- BITMAPINFO )
|
: (bitmap-info) ( dim -- BITMAPINFO )
|
||||||
"BITMAPINFO" <c-object> [
|
[
|
||||||
BITMAPINFO-bmiHeader {
|
BITMAPINFO <struct>
|
||||||
[ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
|
dup bmiHeader>>
|
||||||
[ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
|
BITMAPINFOHEADER heap-size >>biSize
|
||||||
[ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
|
] dip
|
||||||
[ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
|
[ first >>biWidth ]
|
||||||
[ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
|
[ second >>biHeight ]
|
||||||
[ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
|
[ first2 * 4 * >>biSizeImage ] tri
|
||||||
[ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
|
1 >>biPlanes
|
||||||
[ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
|
32 >>biBitCount
|
||||||
[ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
|
BI_RGB >>biCompression
|
||||||
[ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
|
72 >>biXPelsPerMeter
|
||||||
[ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
|
72 >>biYPelsPerMeter
|
||||||
} 2cleave
|
0 >>biClrUsed
|
||||||
] keep ;
|
0 >>biClrImportant
|
||||||
|
drop ;
|
||||||
|
|
||||||
: make-bitmap ( dim dc -- hBitmap bits )
|
: make-bitmap ( dim dc -- hBitmap bits )
|
||||||
[ nip ]
|
[ nip ]
|
||||||
|
|
|
@ -1,4 +1,5 @@
|
||||||
USING: kernel tools.test windows.ole32 alien.c-types ;
|
USING: kernel tools.test windows.ole32 alien.c-types
|
||||||
|
classes.struct specialized-arrays.uchar windows.kernel32 ;
|
||||||
IN: windows.ole32.tests
|
IN: windows.ole32.tests
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
|
@ -19,17 +20,9 @@ IN: windows.ole32.tests
|
||||||
guid=
|
guid=
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
little-endian?
|
[
|
||||||
[ B{
|
GUID: 01234567-89ab-cdef-0123-456789abcdef}
|
||||||
HEX: 67 HEX: 45 HEX: 23 HEX: 01 HEX: ab HEX: 89 HEX: ef HEX: cd
|
] [ "{01234567-89ab-cdef-0123-456789abcdef}" string>guid ] unit-test
|
||||||
HEX: 01 HEX: 23 HEX: 45 HEX: 67 HEX: 89 HEX: ab HEX: cd HEX: ef
|
|
||||||
} ]
|
|
||||||
[ B{
|
|
||||||
HEX: 01 HEX: 23 HEX: 45 HEX: 67 HEX: 89 HEX: ab HEX: cd HEX: ef
|
|
||||||
HEX: 01 HEX: 23 HEX: 45 HEX: 67 HEX: 89 HEX: ab HEX: cd HEX: ef
|
|
||||||
} ] ?
|
|
||||||
[ "{01234567-89ab-cdef-0123-456789abcdef}" string>guid ]
|
|
||||||
unit-test
|
|
||||||
|
|
||||||
[ "{01234567-89ab-cdef-0123-456789abcdef}" ]
|
[ "{01234567-89ab-cdef-0123-456789abcdef}" ]
|
||||||
[ "{01234567-89ab-cdef-0123-456789abcdef}" string>guid guid>string ]
|
[ "{01234567-89ab-cdef-0123-456789abcdef}" string>guid guid>string ]
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
USING: alien alien.syntax alien.c-types alien.strings math
|
USING: alien alien.syntax alien.c-types alien.strings math
|
||||||
kernel sequences windows.errors windows.types io
|
kernel sequences windows.errors windows.types io
|
||||||
accessors math.order namespaces make math.parser windows.kernel32
|
accessors math.order namespaces make math.parser windows.kernel32
|
||||||
combinators locals specialized-arrays.direct.uchar ;
|
combinators locals specialized-arrays.direct.uchar
|
||||||
|
literals splitting grouping classes.struct combinators.smart ;
|
||||||
IN: windows.ole32
|
IN: windows.ole32
|
||||||
|
|
||||||
LIBRARY: ole32
|
LIBRARY: ole32
|
||||||
|
@ -130,60 +131,34 @@ TUPLE: ole32-error code message ;
|
||||||
: guid= ( a b -- ? )
|
: guid= ( a b -- ? )
|
||||||
[ 16 memory>byte-array ] bi@ = ;
|
[ 16 memory>byte-array ] bi@ = ;
|
||||||
|
|
||||||
: GUID-STRING-LENGTH ( -- n )
|
CONSTANT: GUID-STRING-LENGTH
|
||||||
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
|
$[ "{01234567-89ab-cdef-0123-456789abcdef}" length ]
|
||||||
|
|
||||||
:: (guid-section>guid) ( string guid start end quot -- )
|
|
||||||
start end string subseq hex> guid quot call ; inline
|
|
||||||
|
|
||||||
:: (guid-byte>guid) ( string guid start end byte -- )
|
|
||||||
start end string subseq hex> byte guid set-nth ; inline
|
|
||||||
|
|
||||||
: string>guid ( string -- guid )
|
: string>guid ( string -- guid )
|
||||||
"GUID" <c-object> [
|
"{-}" split harvest
|
||||||
{
|
[ first3 [ hex> ] tri@ ]
|
||||||
[ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ]
|
[ 3 tail concat 2 group [ hex> ] B{ } map-as ] bi
|
||||||
[ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
|
GUID <struct-boa> ;
|
||||||
[ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
|
|
||||||
[ ]
|
|
||||||
} 2cleave
|
|
||||||
|
|
||||||
GUID-Data4 {
|
|
||||||
[ 20 22 0 (guid-byte>guid) ]
|
|
||||||
[ 22 24 1 (guid-byte>guid) ]
|
|
||||||
|
|
||||||
[ 25 27 2 (guid-byte>guid) ]
|
|
||||||
[ 27 29 3 (guid-byte>guid) ]
|
|
||||||
[ 29 31 4 (guid-byte>guid) ]
|
|
||||||
[ 31 33 5 (guid-byte>guid) ]
|
|
||||||
[ 33 35 6 (guid-byte>guid) ]
|
|
||||||
[ 35 37 7 (guid-byte>guid) ]
|
|
||||||
} 2cleave
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
: (guid-section%) ( guid quot len -- )
|
|
||||||
[ call >hex ] dip CHAR: 0 pad-head % ; inline
|
|
||||||
|
|
||||||
: (guid-byte%) ( guid byte -- )
|
|
||||||
swap nth >hex 2 CHAR: 0 pad-head % ; inline
|
|
||||||
|
|
||||||
: guid>string ( guid -- string )
|
: guid>string ( guid -- string )
|
||||||
[
|
[
|
||||||
"{" % {
|
[ "{" ] dip {
|
||||||
[ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
|
[ Data1>> >hex 8 CHAR: 0 pad-head "-" ]
|
||||||
[ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
|
[ Data2>> >hex 4 CHAR: 0 pad-head "-" ]
|
||||||
[ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
|
[ Data3>> >hex 4 CHAR: 0 pad-head "-" ]
|
||||||
[ ]
|
[
|
||||||
|
Data4>> [
|
||||||
|
{
|
||||||
|
[ >hex 2 CHAR: 0 pad-head ]
|
||||||
|
[ >hex 2 CHAR: 0 pad-head "-" ]
|
||||||
|
[ >hex 2 CHAR: 0 pad-head ]
|
||||||
|
[ >hex 2 CHAR: 0 pad-head ]
|
||||||
|
[ >hex 2 CHAR: 0 pad-head ]
|
||||||
|
[ >hex 2 CHAR: 0 pad-head ]
|
||||||
|
[ >hex 2 CHAR: 0 pad-head ]
|
||||||
|
[ >hex 2 CHAR: 0 pad-head ]
|
||||||
|
} spread
|
||||||
|
] input<sequence "}"
|
||||||
|
]
|
||||||
} cleave
|
} cleave
|
||||||
GUID-Data4 {
|
] "" append-outputs-as ;
|
||||||
[ 0 (guid-byte%) ]
|
|
||||||
[ 1 (guid-byte%) "-" % ]
|
|
||||||
[ 2 (guid-byte%) ]
|
|
||||||
[ 3 (guid-byte%) ]
|
|
||||||
[ 4 (guid-byte%) ]
|
|
||||||
[ 5 (guid-byte%) ]
|
|
||||||
[ 6 (guid-byte%) ]
|
|
||||||
[ 7 (guid-byte%) "}" % ]
|
|
||||||
} cleave
|
|
||||||
] "" make ;
|
|
||||||
|
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: alien alien.c-types alien.strings alien.syntax
|
USING: alien alien.c-types alien.strings alien.syntax
|
||||||
combinators io.encodings.utf16n io.files io.pathnames kernel
|
combinators io.encodings.utf16n io.files io.pathnames kernel
|
||||||
windows.errors windows.com windows.com.syntax windows.user32
|
windows.errors windows.com windows.com.syntax windows.user32
|
||||||
windows.ole32 windows ;
|
windows.ole32 windows specialized-arrays.ushort classes.struct ;
|
||||||
IN: windows.shell32
|
IN: windows.shell32
|
||||||
|
|
||||||
CONSTANT: CSIDL_DESKTOP HEX: 00
|
CONSTANT: CSIDL_DESKTOP HEX: 00
|
||||||
|
@ -90,7 +90,7 @@ ALIAS: ShellExecute ShellExecuteW
|
||||||
|
|
||||||
: shell32-directory ( n -- str )
|
: shell32-directory ( n -- str )
|
||||||
f swap f SHGFP_TYPE_DEFAULT
|
f swap f SHGFP_TYPE_DEFAULT
|
||||||
MAX_UNICODE_PATH "ushort" <c-array>
|
MAX_UNICODE_PATH <ushort-array>
|
||||||
[ SHGetFolderPath drop ] keep utf16n alien>string ;
|
[ SHGetFolderPath drop ] keep utf16n alien>string ;
|
||||||
|
|
||||||
: desktop ( -- str )
|
: desktop ( -- str )
|
||||||
|
@ -167,23 +167,23 @@ CONSTANT: SFGAO_NEWCONTENT HEX: 00200000
|
||||||
|
|
||||||
TYPEDEF: ULONG SFGAOF
|
TYPEDEF: ULONG SFGAOF
|
||||||
|
|
||||||
C-STRUCT: DROPFILES
|
STRUCT: DROPFILES
|
||||||
{ "DWORD" "pFiles" }
|
{ pFiles DWORD }
|
||||||
{ "POINT" "pt" }
|
{ pt POINT }
|
||||||
{ "BOOL" "fNC" }
|
{ fNC BOOL }
|
||||||
{ "BOOL" "fWide" } ;
|
{ fWide BOOL } ;
|
||||||
TYPEDEF: DROPFILES* LPDROPFILES
|
TYPEDEF: DROPFILES* LPDROPFILES
|
||||||
TYPEDEF: DROPFILES* LPCDROPFILES
|
TYPEDEF: DROPFILES* LPCDROPFILES
|
||||||
TYPEDEF: HANDLE HDROP
|
TYPEDEF: HANDLE HDROP
|
||||||
|
|
||||||
C-STRUCT: SHITEMID
|
STRUCT: SHITEMID
|
||||||
{ "USHORT" "cb" }
|
{ cb USHORT }
|
||||||
{ "BYTE[1]" "abID" } ;
|
{ abID BYTE[1] } ;
|
||||||
TYPEDEF: SHITEMID* LPSHITEMID
|
TYPEDEF: SHITEMID* LPSHITEMID
|
||||||
TYPEDEF: SHITEMID* LPCSHITEMID
|
TYPEDEF: SHITEMID* LPCSHITEMID
|
||||||
|
|
||||||
C-STRUCT: ITEMIDLIST
|
STRUCT: ITEMIDLIST
|
||||||
{ "SHITEMID" "mkid" } ;
|
{ mkid SHITEMID } ;
|
||||||
TYPEDEF: ITEMIDLIST* LPITEMIDLIST
|
TYPEDEF: ITEMIDLIST* LPITEMIDLIST
|
||||||
TYPEDEF: ITEMIDLIST* LPCITEMIDLIST
|
TYPEDEF: ITEMIDLIST* LPCITEMIDLIST
|
||||||
TYPEDEF: ITEMIDLIST ITEMID_CHILD
|
TYPEDEF: ITEMIDLIST ITEMID_CHILD
|
||||||
|
@ -195,9 +195,9 @@ CONSTANT: STRRET_OFFSET 1
|
||||||
CONSTANT: STRRET_CSTR 2
|
CONSTANT: STRRET_CSTR 2
|
||||||
|
|
||||||
C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
|
C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
|
||||||
C-STRUCT: STRRET
|
STRUCT: STRRET
|
||||||
{ "int" "uType" }
|
{ uType int }
|
||||||
{ "STRRET-union" "union" } ;
|
{ union STRRET-union } ;
|
||||||
|
|
||||||
COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046}
|
COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046}
|
||||||
HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched )
|
HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched )
|
||||||
|
|
|
@ -0,0 +1,10 @@
|
||||||
|
! Copyright (C) 2009 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: classes.struct tools.test windows.types ;
|
||||||
|
IN: windows.types.tests
|
||||||
|
|
||||||
|
[ S{ RECT { right 100 } { bottom 100 } } ]
|
||||||
|
[ { 0 0 } { 100 100 } <RECT> ] unit-test
|
||||||
|
|
||||||
|
[ S{ RECT { left 100 } { top 100 } { right 200 } { bottom 200 } } ]
|
||||||
|
[ { 100 100 } { 100 100 } <RECT> ] unit-test
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types alien.syntax namespaces kernel words
|
USING: alien alien.c-types alien.syntax namespaces kernel words
|
||||||
sequences math math.bitwise math.vectors colors
|
sequences math math.bitwise math.vectors colors
|
||||||
io.encodings.utf16n classes.struct ;
|
io.encodings.utf16n classes.struct accessors ;
|
||||||
IN: windows.types
|
IN: windows.types
|
||||||
|
|
||||||
TYPEDEF: char CHAR
|
TYPEDEF: char CHAR
|
||||||
|
@ -216,37 +216,37 @@ CONSTANT: TRUE 1
|
||||||
|
|
||||||
! typedef LRESULT (CALLBACK* WNDPROC)(HWND, UINT, WPARAM, LPARAM);
|
! typedef LRESULT (CALLBACK* WNDPROC)(HWND, UINT, WPARAM, LPARAM);
|
||||||
|
|
||||||
C-STRUCT: WNDCLASS
|
STRUCT: WNDCLASS
|
||||||
{ "UINT" "style" }
|
{ style UINT }
|
||||||
{ "WNDPROC" "lpfnWndProc" }
|
{ lpfnWndProc WNDPROC }
|
||||||
{ "int" "cbClsExtra" }
|
{ cbClsExtra int }
|
||||||
{ "int" "cbWndExtra" }
|
{ cbWndExtra int }
|
||||||
{ "HINSTANCE" "hInstance" }
|
{ hInstance HINSTANCE }
|
||||||
{ "HICON" "hIcon" }
|
{ hIcon HICON }
|
||||||
{ "HCURSOR" "hCursor" }
|
{ hCursor HCURSOR }
|
||||||
{ "HBRUSH" "hbrBackground" }
|
{ hbrBackground HBRUSH }
|
||||||
{ "LPCTSTR" "lpszMenuName" }
|
{ lpszMenuName LPCTSTR }
|
||||||
{ "LPCTSTR" "lpszClassName" } ;
|
{ lpszClassName LPCTSTR } ;
|
||||||
|
|
||||||
C-STRUCT: WNDCLASSEX
|
STRUCT: WNDCLASSEX
|
||||||
{ "UINT" "cbSize" }
|
{ cbSize UINT }
|
||||||
{ "UINT" "style" }
|
{ style UINT }
|
||||||
{ "WNDPROC" "lpfnWndProc" }
|
{ lpfnWndProc WNDPROC }
|
||||||
{ "int" "cbClsExtra" }
|
{ cbClsExtra int }
|
||||||
{ "int" "cbWndExtra" }
|
{ cbWndExtra int }
|
||||||
{ "HINSTANCE" "hInstance" }
|
{ hInstance HINSTANCE }
|
||||||
{ "HICON" "hIcon" }
|
{ hIcon HICON }
|
||||||
{ "HCURSOR" "hCursor" }
|
{ hCursor HCURSOR }
|
||||||
{ "HBRUSH" "hbrBackground" }
|
{ hbrBackground HBRUSH }
|
||||||
{ "LPCTSTR" "lpszMenuName" }
|
{ lpszMenuName LPCTSTR }
|
||||||
{ "LPCTSTR" "lpszClassName" }
|
{ lpszClassName LPCTSTR }
|
||||||
{ "HICON" "hIconSm" } ;
|
{ hIconSm HICON } ;
|
||||||
|
|
||||||
C-STRUCT: RECT
|
STRUCT: RECT
|
||||||
{ "LONG" "left" }
|
{ left LONG }
|
||||||
{ "LONG" "top" }
|
{ top LONG }
|
||||||
{ "LONG" "right" }
|
{ right LONG }
|
||||||
{ "LONG" "bottom" } ;
|
{ bottom LONG } ;
|
||||||
|
|
||||||
C-STRUCT: PAINTSTRUCT
|
C-STRUCT: PAINTSTRUCT
|
||||||
{ "HDC" " hdc" }
|
{ "HDC" " hdc" }
|
||||||
|
@ -257,28 +257,28 @@ C-STRUCT: PAINTSTRUCT
|
||||||
{ "BYTE[32]" "rgbReserved" }
|
{ "BYTE[32]" "rgbReserved" }
|
||||||
;
|
;
|
||||||
|
|
||||||
C-STRUCT: BITMAPINFOHEADER
|
STRUCT: BITMAPINFOHEADER
|
||||||
{ "DWORD" "biSize" }
|
{ biSize DWORD }
|
||||||
{ "LONG" "biWidth" }
|
{ biWidth LONG }
|
||||||
{ "LONG" "biHeight" }
|
{ biHeight LONG }
|
||||||
{ "WORD" "biPlanes" }
|
{ biPlanes WORD }
|
||||||
{ "WORD" "biBitCount" }
|
{ biBitCount WORD }
|
||||||
{ "DWORD" "biCompression" }
|
{ biCompression DWORD }
|
||||||
{ "DWORD" "biSizeImage" }
|
{ biSizeImage DWORD }
|
||||||
{ "LONG" "biXPelsPerMeter" }
|
{ biXPelsPerMeter LONG }
|
||||||
{ "LONG" "biYPelsPerMeter" }
|
{ biYPelsPerMeter LONG }
|
||||||
{ "DWORD" "biClrUsed" }
|
{ biClrUsed DWORD }
|
||||||
{ "DWORD" "biClrImportant" } ;
|
{ biClrImportant DWORD } ;
|
||||||
|
|
||||||
C-STRUCT: RGBQUAD
|
STRUCT: RGBQUAD
|
||||||
{ "BYTE" "rgbBlue" }
|
{ rgbBlue BYTE }
|
||||||
{ "BYTE" "rgbGreen" }
|
{ rgbGreen BYTE }
|
||||||
{ "BYTE" "rgbRed" }
|
{ rgbRed BYTE }
|
||||||
{ "BYTE" "rgbReserved" } ;
|
{ rgbReserved BYTE } ;
|
||||||
|
|
||||||
C-STRUCT: BITMAPINFO
|
STRUCT: BITMAPINFO
|
||||||
{ "BITMAPINFOHEADER" "bmiHeader" }
|
{ bmiHeader BITMAPINFOHEADER }
|
||||||
{ "RGBQUAD[1]" "bmiColors" } ;
|
{ bimColors RGBQUAD[1] } ;
|
||||||
|
|
||||||
TYPEDEF: void* LPPAINTSTRUCT
|
TYPEDEF: void* LPPAINTSTRUCT
|
||||||
TYPEDEF: void* PAINTSTRUCT
|
TYPEDEF: void* PAINTSTRUCT
|
||||||
|
@ -287,9 +287,9 @@ C-STRUCT: POINT
|
||||||
{ "LONG" "x" }
|
{ "LONG" "x" }
|
||||||
{ "LONG" "y" } ;
|
{ "LONG" "y" } ;
|
||||||
|
|
||||||
C-STRUCT: SIZE
|
STRUCT: SIZE
|
||||||
{ "LONG" "cx" }
|
{ cx LONG }
|
||||||
{ "LONG" "cy" } ;
|
{ cy LONG } ;
|
||||||
|
|
||||||
C-STRUCT: MSG
|
C-STRUCT: MSG
|
||||||
{ "HWND" "hWnd" }
|
{ "HWND" "hWnd" }
|
||||||
|
@ -329,19 +329,10 @@ STRUCT: PIXELFORMATDESCRIPTOR
|
||||||
{ dwVisibleMask DWORD }
|
{ dwVisibleMask DWORD }
|
||||||
{ dwDamageMask DWORD } ;
|
{ dwDamageMask DWORD } ;
|
||||||
|
|
||||||
C-STRUCT: RECT
|
|
||||||
{ "LONG" "left" }
|
|
||||||
{ "LONG" "top" }
|
|
||||||
{ "LONG" "right" }
|
|
||||||
{ "LONG" "bottom" } ;
|
|
||||||
|
|
||||||
: <RECT> ( loc dim -- RECT )
|
: <RECT> ( loc dim -- RECT )
|
||||||
over v+
|
[ RECT <struct> ] 2dip
|
||||||
"RECT" <c-object>
|
[ drop [ first >>left ] [ second >>top ] bi ]
|
||||||
over first over set-RECT-right
|
[ v+ [ first >>right ] [ second >>bottom ] bi ] 2bi ;
|
||||||
swap second over set-RECT-bottom
|
|
||||||
over first over set-RECT-left
|
|
||||||
swap second over set-RECT-top ;
|
|
||||||
|
|
||||||
TYPEDEF: RECT* PRECT
|
TYPEDEF: RECT* PRECT
|
||||||
TYPEDEF: RECT* LPRECT
|
TYPEDEF: RECT* LPRECT
|
||||||
|
@ -389,26 +380,26 @@ TYPEDEF: DWORD* LPCOLORREF
|
||||||
: color>RGB ( color -- COLORREF )
|
: color>RGB ( color -- COLORREF )
|
||||||
>rgba-components drop [ 255 * >integer ] tri@ RGB ;
|
>rgba-components drop [ 255 * >integer ] tri@ RGB ;
|
||||||
|
|
||||||
C-STRUCT: TEXTMETRICW
|
STRUCT: TEXTMETRICW
|
||||||
{ "LONG" "tmHeight" }
|
{ tmHeight LONG }
|
||||||
{ "LONG" "tmAscent" }
|
{ tmAscent LONG }
|
||||||
{ "LONG" "tmDescent" }
|
{ tmDescent LONG }
|
||||||
{ "LONG" "tmInternalLeading" }
|
{ tmInternalLeading LONG }
|
||||||
{ "LONG" "tmExternalLeading" }
|
{ tmExternalLeading LONG }
|
||||||
{ "LONG" "tmAveCharWidth" }
|
{ tmAveCharWidth LONG }
|
||||||
{ "LONG" "tmMaxCharWidth" }
|
{ tmMaxCharWidth LONG }
|
||||||
{ "LONG" "tmWeight" }
|
{ tmWeight LONG }
|
||||||
{ "LONG" "tmOverhang" }
|
{ tmOverhang LONG }
|
||||||
{ "LONG" "tmDigitizedAspectX" }
|
{ tmDigitizedAspectX LONG }
|
||||||
{ "LONG" "tmDigitizedAspectY" }
|
{ tmDigitizedAspectY LONG }
|
||||||
{ "WCHAR" "tmFirstChar" }
|
{ tmFirstChar WCHAR }
|
||||||
{ "WCHAR" "tmLastChar" }
|
{ tmLastChar WCHAR }
|
||||||
{ "WCHAR" "tmDefaultChar" }
|
{ tmDefaultChar WCHAR }
|
||||||
{ "WCHAR" "tmBreakChar" }
|
{ tmBreakChar WCHAR }
|
||||||
{ "BYTE" "tmItalic" }
|
{ tmItalic BYTE }
|
||||||
{ "BYTE" "tmUnderlined" }
|
{ tmUnderlined BYTE }
|
||||||
{ "BYTE" "tmStruckOut" }
|
{ tmStruckOut BYTE }
|
||||||
{ "BYTE" "tmPitchAndFamily" }
|
{ tmPitchAndFamily BYTE }
|
||||||
{ "BYTE" "tmCharSet" } ;
|
{ tmCharSet BYTE } ;
|
||||||
|
|
||||||
TYPEDEF: TEXTMETRICW* LPTEXTMETRIC
|
TYPEDEF: TEXTMETRICW* LPTEXTMETRIC
|
||||||
|
|
|
@ -4,7 +4,8 @@ USING: kernel assocs math sequences fry io.encodings.string
|
||||||
io.encodings.utf16n accessors arrays combinators destructors
|
io.encodings.utf16n accessors arrays combinators destructors
|
||||||
cache namespaces init fonts alien.c-types windows.usp10
|
cache namespaces init fonts alien.c-types windows.usp10
|
||||||
windows.offscreen windows.gdi32 windows.ole32 windows.types
|
windows.offscreen windows.gdi32 windows.ole32 windows.types
|
||||||
windows.fonts opengl.textures locals windows.errors ;
|
windows.fonts opengl.textures locals windows.errors
|
||||||
|
classes.struct ;
|
||||||
IN: windows.uniscribe
|
IN: windows.uniscribe
|
||||||
|
|
||||||
TUPLE: script-string < disposable font string metrics ssa size image ;
|
TUPLE: script-string < disposable font string metrics ssa size image ;
|
||||||
|
@ -81,10 +82,11 @@ TUPLE: script-string < disposable font string metrics ssa size image ;
|
||||||
: script-string-size ( script-string -- dim )
|
: script-string-size ( script-string -- dim )
|
||||||
ssa>> ScriptString_pSize
|
ssa>> ScriptString_pSize
|
||||||
dup win32-error=0/f
|
dup win32-error=0/f
|
||||||
[ SIZE-cx ] [ SIZE-cy ] bi 2array ;
|
SIZE memory>struct
|
||||||
|
[ cx>> ] [ cy>> ] bi 2array ;
|
||||||
|
|
||||||
: dc-metrics ( dc -- metrics )
|
: dc-metrics ( dc -- metrics )
|
||||||
"TEXTMETRICW" <c-object>
|
TEXTMETRICW <struct>
|
||||||
[ GetTextMetrics drop ] keep
|
[ GetTextMetrics drop ] keep
|
||||||
TEXTMETRIC>metrics ;
|
TEXTMETRIC>metrics ;
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
! 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 alien.syntax parser namespaces kernel math
|
USING: alien alien.syntax parser namespaces kernel math
|
||||||
windows.types generalizations math.bitwise classes.struct ;
|
windows.types generalizations math.bitwise classes.struct
|
||||||
|
literals ;
|
||||||
IN: windows.user32
|
IN: windows.user32
|
||||||
|
|
||||||
! HKL for ActivateKeyboardLayout
|
! HKL for ActivateKeyboardLayout
|
||||||
|
@ -74,8 +75,10 @@ CONSTANT: WS_EX_RIGHTSCROLLBAR HEX: 00000000
|
||||||
CONSTANT: WS_EX_CONTROLPARENT HEX: 00010000
|
CONSTANT: WS_EX_CONTROLPARENT HEX: 00010000
|
||||||
CONSTANT: WS_EX_STATICEDGE HEX: 00020000
|
CONSTANT: WS_EX_STATICEDGE HEX: 00020000
|
||||||
CONSTANT: WS_EX_APPWINDOW HEX: 00040000
|
CONSTANT: WS_EX_APPWINDOW HEX: 00040000
|
||||||
|
|
||||||
: WS_EX_OVERLAPPEDWINDOW ( -- n )
|
: WS_EX_OVERLAPPEDWINDOW ( -- n )
|
||||||
WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable
|
WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable
|
||||||
|
|
||||||
: WS_EX_PALETTEWINDOW ( -- n )
|
: WS_EX_PALETTEWINDOW ( -- n )
|
||||||
{ WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } flags ; foldable
|
{ WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } flags ; foldable
|
||||||
|
|
||||||
|
@ -521,11 +524,11 @@ CONSTANT: TME_NONCLIENT 16
|
||||||
CONSTANT: TME_QUERY HEX: 40000000
|
CONSTANT: TME_QUERY HEX: 40000000
|
||||||
CONSTANT: TME_CANCEL HEX: 80000000
|
CONSTANT: TME_CANCEL HEX: 80000000
|
||||||
CONSTANT: HOVER_DEFAULT HEX: ffffffff
|
CONSTANT: HOVER_DEFAULT HEX: ffffffff
|
||||||
C-STRUCT: TRACKMOUSEEVENT
|
STRUCT: TRACKMOUSEEVENT
|
||||||
{ "DWORD" "cbSize" }
|
{ cbSize DWORD }
|
||||||
{ "DWORD" "dwFlags" }
|
{ dwFlags DWORD }
|
||||||
{ "HWND" "hwndTrack" }
|
{ hwndTrack HWND }
|
||||||
{ "DWORD" "dwHoverTime" } ;
|
{ dwHoverTime DWORD } ;
|
||||||
TYPEDEF: TRACKMOUSEEVENT* LPTRACKMOUSEEVENT
|
TYPEDEF: TRACKMOUSEEVENT* LPTRACKMOUSEEVENT
|
||||||
|
|
||||||
CONSTANT: DBT_DEVICEARRIVAL HEX: 8000
|
CONSTANT: DBT_DEVICEARRIVAL HEX: 8000
|
||||||
|
@ -538,26 +541,26 @@ CONSTANT: DEVICE_NOTIFY_SERVICE_HANDLE 1
|
||||||
|
|
||||||
CONSTANT: DEVICE_NOTIFY_ALL_INTERFACE_CLASSES 4
|
CONSTANT: DEVICE_NOTIFY_ALL_INTERFACE_CLASSES 4
|
||||||
|
|
||||||
C-STRUCT: DEV_BROADCAST_HDR
|
STRUCT: DEV_BROADCAST_HDR
|
||||||
{ "DWORD" "dbch_size" }
|
{ dbch_size DWORD }
|
||||||
{ "DWORD" "dbch_devicetype" }
|
{ dbch_devicetype DWORD }
|
||||||
{ "DWORD" "dbch_reserved" } ;
|
{ dbch_reserved DWORD } ;
|
||||||
|
|
||||||
C-STRUCT: DEV_BROADCAST_DEVICEW
|
STRUCT: DEV_BROADCAST_DEVICEW
|
||||||
{ "DWORD" "dbcc_size" }
|
{ dbcc_size DWORD }
|
||||||
{ "DWORD" "dbcc_devicetype" }
|
{ dbcc_devicetype DWORD }
|
||||||
{ "DWORD" "dbcc_reserved" }
|
{ dbcc_reserved DWORD }
|
||||||
{ "GUID" "dbcc_classguid" }
|
{ dbcc_classguid GUID }
|
||||||
{ { "WCHAR" 1 } "dbcc_name" } ;
|
{ dbcc_name WCHAR[1] } ;
|
||||||
|
|
||||||
CONSTANT: CCHDEVICENAME 32
|
CONSTANT: CCHDEVICENAME 32
|
||||||
|
|
||||||
C-STRUCT: MONITORINFOEX
|
STRUCT: MONITORINFOEX
|
||||||
{ "DWORD" "cbSize" }
|
{ cbSize DWORD }
|
||||||
{ "RECT" "rcMonitor" }
|
{ rcMonitor RECT }
|
||||||
{ "RECT" "rcWork" }
|
{ rcWork RECT }
|
||||||
{ "DWORD" "dwFlags" }
|
{ dwFlags DWORD }
|
||||||
{ { "TCHAR" CCHDEVICENAME } "szDevice" } ;
|
{ szDevice { "TCHAR" $ CCHDEVICENAME } } ;
|
||||||
|
|
||||||
TYPEDEF: MONITORINFOEX* LPMONITORINFOEX
|
TYPEDEF: MONITORINFOEX* LPMONITORINFOEX
|
||||||
TYPEDEF: MONITORINFOEX* LPMONITORINFO
|
TYPEDEF: MONITORINFOEX* LPMONITORINFO
|
||||||
|
|
|
@ -2,7 +2,8 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types alien.strings alien.syntax arrays
|
USING: alien alien.c-types alien.strings alien.syntax arrays
|
||||||
byte-arrays kernel math sequences windows.types windows.kernel32
|
byte-arrays kernel math sequences windows.types windows.kernel32
|
||||||
windows.errors math.bitwise io.encodings.utf16n ;
|
windows.errors math.bitwise io.encodings.utf16n classes.struct
|
||||||
|
literals windows.com.syntax ;
|
||||||
IN: windows.winsock
|
IN: windows.winsock
|
||||||
|
|
||||||
USE: libc
|
USE: libc
|
||||||
|
@ -121,12 +122,12 @@ C-STRUCT: sockaddr-in6
|
||||||
{ { "uchar" 16 } "addr" }
|
{ { "uchar" 16 } "addr" }
|
||||||
{ "uint" "scopeid" } ;
|
{ "uint" "scopeid" } ;
|
||||||
|
|
||||||
C-STRUCT: hostent
|
STRUCT: hostent
|
||||||
{ "char*" "name" }
|
{ name char* }
|
||||||
{ "void*" "aliases" }
|
{ aliases void* }
|
||||||
{ "short" "addrtype" }
|
{ addrtype short }
|
||||||
{ "short" "length" }
|
{ length short }
|
||||||
{ "void*" "addr-list" } ;
|
{ addr-list void* } ;
|
||||||
|
|
||||||
C-STRUCT: addrinfo
|
C-STRUCT: addrinfo
|
||||||
{ "int" "flags" }
|
{ "int" "flags" }
|
||||||
|
@ -142,11 +143,8 @@ C-STRUCT: timeval
|
||||||
{ "long" "sec" }
|
{ "long" "sec" }
|
||||||
{ "long" "usec" } ;
|
{ "long" "usec" } ;
|
||||||
|
|
||||||
: hostent-addr ( hostent -- addr ) hostent-addr-list *void* ; ! *uint ;
|
|
||||||
|
|
||||||
LIBRARY: winsock
|
LIBRARY: winsock
|
||||||
|
|
||||||
|
|
||||||
FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
|
FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
|
||||||
|
|
||||||
FUNCTION: ushort htons ( ushort n ) ;
|
FUNCTION: ushort htons ( ushort n ) ;
|
||||||
|
@ -195,9 +193,9 @@ C-STRUCT: FLOWSPEC
|
||||||
TYPEDEF: FLOWSPEC* PFLOWSPEC
|
TYPEDEF: FLOWSPEC* PFLOWSPEC
|
||||||
TYPEDEF: FLOWSPEC* LPFLOWSPEC
|
TYPEDEF: FLOWSPEC* LPFLOWSPEC
|
||||||
|
|
||||||
C-STRUCT: WSABUF
|
STRUCT: WSABUF
|
||||||
{ "ulong" "len" }
|
{ len ulong }
|
||||||
{ "void*" "buf" } ;
|
{ buf void* } ;
|
||||||
TYPEDEF: WSABUF* LPWSABUF
|
TYPEDEF: WSABUF* LPWSABUF
|
||||||
|
|
||||||
C-STRUCT: QOS
|
C-STRUCT: QOS
|
||||||
|
@ -377,8 +375,6 @@ FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
|
||||||
BOOL fAlertable ) ;
|
BOOL fAlertable ) ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
LIBRARY: mswsock
|
LIBRARY: mswsock
|
||||||
|
|
||||||
! Not in Windows CE
|
! Not in Windows CE
|
||||||
|
@ -387,18 +383,10 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
|
||||||
|
|
||||||
CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
|
CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
|
||||||
|
|
||||||
: WSAID_CONNECTEX ( -- GUID )
|
CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
|
||||||
"GUID" <c-object>
|
|
||||||
HEX: 25a207b9 over set-GUID-Data1
|
|
||||||
HEX: ddf3 over set-GUID-Data2
|
|
||||||
HEX: 4660 over set-GUID-Data3
|
|
||||||
B{
|
|
||||||
HEX: 8e HEX: e9 HEX: 76 HEX: e5
|
|
||||||
HEX: 8c HEX: 74 HEX: 06 HEX: 3e
|
|
||||||
} over set-GUID-Data4 ;
|
|
||||||
|
|
||||||
: winsock-expected-error? ( n -- ? )
|
: winsock-expected-error? ( n -- ? )
|
||||||
ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING 3array member? ;
|
${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
|
||||||
|
|
||||||
: (winsock-error-string) ( n -- str )
|
: (winsock-error-string) ( n -- str )
|
||||||
! #! WSAStartup returns the error code 'n' directly
|
! #! WSAStartup returns the error code 'n' directly
|
||||||
|
|
|
@ -35,6 +35,8 @@ M: string string>alien
|
||||||
[ stream>> >byte-array ]
|
[ stream>> >byte-array ]
|
||||||
tri ;
|
tri ;
|
||||||
|
|
||||||
|
M: tuple string>alien drop underlying>> ;
|
||||||
|
|
||||||
HOOK: alien>native-string os ( alien -- string )
|
HOOK: alien>native-string os ( alien -- string )
|
||||||
|
|
||||||
M: windows alien>native-string utf16n alien>string ;
|
M: windows alien>native-string utf16n alien>string ;
|
||||||
|
|
|
@ -2,7 +2,8 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io.files.windows io.streams.duplex kernel math
|
USING: io.files.windows io.streams.duplex kernel math
|
||||||
math.bitwise windows.kernel32 accessors alien.c-types
|
math.bitwise windows.kernel32 accessors alien.c-types
|
||||||
windows io.files.windows fry locals continuations ;
|
windows io.files.windows fry locals continuations
|
||||||
|
classes.struct ;
|
||||||
IN: io.serial.windows
|
IN: io.serial.windows
|
||||||
|
|
||||||
: <serial-stream> ( path encoding -- duplex )
|
: <serial-stream> ( path encoding -- duplex )
|
||||||
|
@ -10,7 +11,7 @@ IN: io.serial.windows
|
||||||
|
|
||||||
: get-comm-state ( duplex -- dcb )
|
: get-comm-state ( duplex -- dcb )
|
||||||
in>> handle>>
|
in>> handle>>
|
||||||
"DCB" <c-object> tuck
|
DCB <struct> tuck
|
||||||
GetCommState win32-error=0/f ;
|
GetCommState win32-error=0/f ;
|
||||||
|
|
||||||
: set-comm-state ( duplex dcb -- )
|
: set-comm-state ( duplex dcb -- )
|
||||||
|
|
|
@ -21,24 +21,24 @@ IN: system-info.windows
|
||||||
system-info dwOemId>> HEX: ffff0000 bitand ;
|
system-info dwOemId>> HEX: ffff0000 bitand ;
|
||||||
|
|
||||||
: os-version ( -- os-version )
|
: os-version ( -- os-version )
|
||||||
"OSVERSIONINFO" <c-object>
|
OSVERSIONINFO <struct>
|
||||||
"OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize
|
OSVERSIONINFO heap-size >>dwOSVersionInfoSize
|
||||||
dup GetVersionEx win32-error=0/f ;
|
dup GetVersionEx win32-error=0/f ;
|
||||||
|
|
||||||
: windows-major ( -- n )
|
: windows-major ( -- n )
|
||||||
os-version OSVERSIONINFO-dwMajorVersion ;
|
os-version dwMajorVersion>> ;
|
||||||
|
|
||||||
: windows-minor ( -- n )
|
: windows-minor ( -- n )
|
||||||
os-version OSVERSIONINFO-dwMinorVersion ;
|
os-version dwMinorVersion>> ;
|
||||||
|
|
||||||
: windows-build# ( -- n )
|
: windows-build# ( -- n )
|
||||||
os-version OSVERSIONINFO-dwBuildNumber ;
|
os-version dwBuildNumber>> ;
|
||||||
|
|
||||||
: windows-platform-id ( -- n )
|
: windows-platform-id ( -- n )
|
||||||
os-version OSVERSIONINFO-dwPlatformId ;
|
os-version dwPlatformId>> ;
|
||||||
|
|
||||||
: windows-service-pack ( -- string )
|
: windows-service-pack ( -- string )
|
||||||
os-version OSVERSIONINFO-szCSDVersion alien>native-string ;
|
os-version szCSDVersion>> alien>native-string ;
|
||||||
|
|
||||||
: feature-present? ( n -- ? )
|
: feature-present? ( n -- ? )
|
||||||
IsProcessorFeaturePresent zero? not ;
|
IsProcessorFeaturePresent zero? not ;
|
||||||
|
|
Loading…
Reference in New Issue