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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-08-31 00:24:46 -04:00
parent 861a3f563b d88cdffa47
commit 6ed46177e9
26 changed files with 391 additions and 426 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
basis/calendar/windows/windows.factor
View File

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

4
basis/environment/winnt/winnt.factor
View File

@ -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
] [ ] [

22
basis/game-input/dinput/dinput.factor
View File

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

15
basis/io/directories/windows/windows.factor
View File

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

24
basis/io/files/info/windows/windows.factor
View File

@ -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
] [ ] [

12
basis/io/files/windows/nt/nt.factor
View File

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

15
basis/io/monitors/windows/nt/nt.factor
View File

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

21
basis/io/sockets/windows/nt/nt.factor
View File

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

63
basis/ui/backend/windows/windows.factor
View File

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

12
basis/windows/com/syntax/syntax.factor
View File

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

2
basis/windows/com/wrapper/wrapper.factor
View File

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

4
basis/windows/errors/errors.factor
View File

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

74
basis/windows/fonts/fonts.factor
View File

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

89
basis/windows/kernel32/kernel32.factor
View File

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

33
basis/windows/offscreen/offscreen.factor
View File

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

17
basis/windows/ole32/ole32-tests.factor
View File

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

79
basis/windows/ole32/ole32.factor
View File

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

30
basis/windows/shell32/shell32.factor
View File

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

10
basis/windows/types/types-tests.factor Executable file
View File

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

163
basis/windows/types/types.factor
View File

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

8
basis/windows/uniscribe/uniscribe.factor
View File

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

47
basis/windows/user32/user32.factor
View File

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

38
basis/windows/winsock/winsock.factor
View File

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

2
core/alien/strings/strings.factor
View File

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

5
extra/io/serial/windows/windows.factor
View File

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

14
extra/system-info/windows/windows.factor
View File

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