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
windows.kernel32 kernel math combinators windows.errors ;
windows.kernel32 kernel math combinators windows.errors
accessors classes.struct ;
IN: calendar.windows
M: windows gmt-offset ( -- hours minutes seconds )
"TIME_ZONE_INFORMATION" <c-object>
TIME_ZONE_INFORMATION <struct>
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_INVALID [ win32-error-string throw ] }
{ TIME_ZONE_ID_UNKNOWN [ TIME_ZONE_INFORMATION-Bias ] }
{ TIME_ZONE_ID_STANDARD [ TIME_ZONE_INFORMATION-Bias ] }
{ TIME_ZONE_ID_DAYLIGHT [
[ TIME_ZONE_INFORMATION-Bias ]
[ TIME_ZONE_INFORMATION-DaylightBias ] bi +
] }
{ TIME_ZONE_ID_UNKNOWN [ Bias>> ] }
{ TIME_ZONE_ID_STANDARD [ Bias>> ] }
{ TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] }
} 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 ;
IN: environment.winnt
<< "TCHAR" require-c-type-arrays >>
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 = [
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
windows.dinput windows.dinput.constants windows.errors
windows.kernel32 windows.messages windows.ole32
windows.user32 ;
windows.user32 classes.struct ;
IN: game-input.dinput
CONSTANT: MOUSE-BUFFER-SIZE 16
@ -162,7 +162,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
[ remove-controller ] each ;
: device-interface? ( dbt-broadcast-hdr -- ? )
DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = ;
: device-arrived ( dbt-broadcast-hdr -- )
device-interface? [ find-controllers ] when ;
@ -185,9 +185,9 @@ TUPLE: window-rect < rect window-loc ;
{ 0 0 } >>dim ;
: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
"DEV_BROADCAST_DEVICEW" <c-object>
"DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
DEV_BROADCAST_DEVICEW <struct>
DEV_BROADCAST_DEVICEW heap-size >>dbcc_size
DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ;
: create-device-change-window ( -- )
<zero-window-rect> WS_OVERLAPPEDWINDOW 0 create-window
@ -239,11 +239,13 @@ M: dinput-game-input-backend (close-game-input)
delete-dinput ;
M: dinput-game-input-backend (reset-game-input)
{
+dinput+ +keyboard-device+ +keyboard-state+
+controller-devices+ +controller-guids+
+device-change-window+ +device-change-handle+
} [ f swap set-global ] each ;
global [
{
+dinput+ +keyboard-device+ +keyboard-state+
+controller-devices+ +controller-guids+
+device-change-window+ +device-change-handle+
} [ off ] each
] bind ;
M: dinput-game-input-backend get-controllers
+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
kernel accessors calendar windows windows.errors
windows.kernel32 alien.c-types sequences splitting
fry continuations ;
fry continuations classes.struct ;
IN: io.directories.windows
M: windows touch-file ( path -- )
@ -33,12 +33,12 @@ M: windows delete-directory ( path -- )
RemoveDirectory win32-error=0/f ;
: find-first-file ( path -- WIN32_FIND_DATA handle )
"WIN32_FIND_DATA" <c-object>
WIN32_FIND_DATA <struct>
[ nip ] [ FindFirstFile ] 2bi
[ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
: find-next-file ( path -- WIN32_FIND_DATA/f )
"WIN32_FIND_DATA" <c-object>
WIN32_FIND_DATA <struct>
[ nip ] [ FindNextFile ] 2bi 0 = [
GetLastError ERROR_NO_MORE_FILES = [
win32-error
@ -48,10 +48,11 @@ M: windows delete-directory ( path -- )
TUPLE: windows-directory-entry < directory-entry attributes ;
M: windows >directory-entry ( byte-array -- directory-entry )
[ WIN32_FIND_DATA-cFileName utf16n alien>string ]
[ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
[ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
tri
[ cFileName>> utf16n alien>string ]
[
dwFileAttributes>>
[ win32-file-type ] [ win32-file-attributes ] bi
] bi
dupd remove windows-directory-entry boa ;
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
generalizations system alien.strings io.encodings.utf16n
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
:: 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 )
[ \ windows-file-info new ] dip
{
[ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
[ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ]
[
[ WIN32_FIND_DATA-nFileSizeLow ]
[ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
]
[ WIN32_FIND_DATA-dwFileAttributes >>permissions ]
[ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ]
[ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ]
[ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ]
[ dwFileAttributes>> win32-file-type >>type ]
[ dwFileAttributes>> win32-file-attributes >>attributes ]
[ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit >>size ]
[ dwFileAttributes>> >>permissions ]
[ ftCreationTime>> FILETIME>timestamp >>created ]
[ ftLastWriteTime>> FILETIME>timestamp >>modified ]
[ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
} cleave ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
"WIN32_FIND_DATA" <c-object> [
WIN32_FIND_DATA <struct> [
FindFirstFile
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
FindClose win32-error=0/f
@ -147,7 +145,7 @@ M: winnt file-system-info ( path -- file-system-info )
calculate-file-system-info ;
: volume>paths ( string -- array )
16384 "ushort" <c-array> tuck dup length
16384 <ushort-array> tuck dup length
0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
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
combinators.short-circuit ascii splitting alien strings assocs
namespaces make accessors tr windows.time windows.shell32
windows.errors ;
windows.errors specialized-arrays.ushort classes.struct ;
IN: io.files.windows.nt
M: winnt cwd
MAX_UNICODE_PATH dup "ushort" <c-array>
MAX_UNICODE_PATH dup <ushort-array>
[ GetCurrentDirectory win32-error=0/f ] keep
utf16n alien>string ;
M: winnt cd
SetCurrentDirectory win32-error=0/f ;
: unicode-prefix ( -- seq )
"\\\\?\\" ; inline
CONSTANT: unicode-prefix "\\\\?\\"
M: winnt root-directory? ( path -- ? )
{
@ -48,10 +47,9 @@ M: winnt CreateFile-flags ( DWORD -- DWORD )
<PRIVATE
: 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
[ WIN32_FILE_ATTRIBUTE_DATA-nFileSizeLow ]
[ WIN32_FILE_ATTRIBUTE_DATA-nFileSizeHigh ] bi >64bit ;
[ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ;
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.buffers io.files io.timeouts io.encodings.string
io.encodings.utf16n io windows.errors windows.kernel32 windows.types
io.pathnames ;
io.pathnames classes.struct ;
IN: io.monitors.windows.nt
: open-directory ( path -- handle )
@ -55,17 +55,14 @@ TUPLE: win32-monitor < monitor port ;
memory>byte-array utf16n decode ;
: parse-notify-record ( buffer -- path changed )
[
[ FILE_NOTIFY_INFORMATION-FileName ]
[ FILE_NOTIFY_INFORMATION-FileNameLength ]
bi memory>u16-string
]
[ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ;
[ [ FileName>> ] [ FileNameLength>> ] bi memory>u16-string ]
[ Action>> parse-action ] bi ;
: (file-notify-records) ( buffer -- buffer )
FILE_NOTIFY_INFORMATION memory>struct
dup ,
dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [
[ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien>
dup NextEntryOffset>> zero? [
[ NextEntryOffset>> ] [ >c-ptr <displaced-alien> ] bi
(file-notify-records)
] 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
io namespaces io.streams.duplex io.backend.windows
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
: malloc-int ( object -- object )
@ -14,7 +15,7 @@ M: winnt WSASocket-flags ( -- DWORD )
: get-ConnectEx-ptr ( socket -- void* )
SIO_GET_EXTENSION_FUNCTION_POINTER
WSAID_CONNECTEX
"GUID" heap-size
GUID heap-size
"void*" <c-object>
[
"void*" heap-size
@ -127,9 +128,9 @@ TUPLE: WSARecvFrom-args port
lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
: make-receive-buffer ( -- WSABUF )
"WSABUF" malloc-object &free
default-buffer-size get over set-WSABUF-len
default-buffer-size get malloc &free over set-WSABUF-buf ; inline
WSABUF malloc-struct &free
default-buffer-size get
[ >>len ] [ malloc &free >>buf ] bi ; inline
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
WSARecvFrom-args new
@ -158,7 +159,7 @@ TUPLE: WSARecvFrom-args port
} cleave WSARecvFrom socket-error* ; inline
: 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
M: winnt (receive) ( datagram -- packet addrspec )
@ -175,11 +176,9 @@ TUPLE: WSASendTo-args port
dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
: make-send-buffer ( packet -- WSABUF )
"WSABUF" malloc-object &free
[ [ malloc-byte-array &free ] dip set-WSABUF-buf ]
[ [ length ] dip set-WSABUF-len ]
[ nip ]
2tri ; inline
[ WSABUF malloc-struct &free ] dip
[ malloc-byte-array &free >>buf ]
[ length >>len ] bi ; inline
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
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 ;
: 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-top-left ] keep
[ RECT-right ] keep [ RECT-left - ] keep
[ RECT-bottom ] keep RECT-top - ;
[ get-RECT-top-left ] [ get-RECT-width/height ] bi ;
: handle-wm-paint ( hWnd uMsg wParam lParam -- )
#! wParam and lParam are unused
@ -503,14 +505,15 @@ SYMBOL: nc-buttons
] if ;
: make-TRACKMOUSEEVENT ( hWnd -- alien )
"TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
"TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
TRACKMOUSEEVENT <struct>
swap >>hwndTrack
TRACKMOUSEEVENT heap-size >>cbSize ;
: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
2nip
over make-TRACKMOUSEEVENT
TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
0 over set-TRACKMOUSEEVENT-dwHoverTime
TME_LEAVE >>dwFlags
0 >>dwHoverTime
TrackMouseEvent drop
>lo-hi swap window move-hand fire-motion ;
@ -588,19 +591,18 @@ M: windows-ui-backend do-events
] if ;
:: register-window-class ( class-name-ptr -- )
"WNDCLASSEX" <c-object> f GetModuleHandle
WNDCLASSEX <struct> f GetModuleHandle
class-name-ptr pick GetClassInfoEx 0 = [
"WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
{ CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
ui-wndproc over set-WNDCLASSEX-lpfnWndProc
0 over set-WNDCLASSEX-cbClsExtra
0 over set-WNDCLASSEX-cbWndExtra
f GetModuleHandle over set-WNDCLASSEX-hInstance
f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
over set-WNDCLASSEX-hIcon
f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
WNDCLASSEX heap-size >>cbSize
{ CS_HREDRAW CS_VREDRAW CS_OWNDC } flags >>style
ui-wndproc >>lpfnWndProc
0 >>cbClsExtra
0 >>cbWndExtra
f GetModuleHandle >>hInstance
f GetModuleHandle "fraptor" utf16n string>alien LoadIcon >>hIcon
f IDC_ARROW LoadCursor >>hCursor
class-name-ptr over set-WNDCLASSEX-lpszClassName
class-name-ptr >>lpszClassName
RegisterClassEx win32-error=0/f
] [ drop ] if ;
@ -610,12 +612,12 @@ M: windows-ui-backend do-events
: make-RECT ( world -- RECT )
[ window-loc>> ] [ dim>> ] bi <RECT> ;
: default-position-RECT ( RECT -- )
dup get-RECT-dimensions [ 2drop ] 2dip
CW_USEDEFAULT + pick set-RECT-bottom
CW_USEDEFAULT + over set-RECT-right
CW_USEDEFAULT over set-RECT-left
CW_USEDEFAULT swap set-RECT-top ;
: default-position-RECT ( RECT -- RECT' )
dup get-RECT-width/height
[ CW_USEDEFAULT + >>bottom ] dip
CW_USEDEFAULT + >>right
CW_USEDEFAULT >>left
CW_USEDEFAULT >>top ;
: 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
] 2dip adjust-RECT
swap [ dup default-position-RECT ] when ;
swap [ default-position-RECT ] when ;
: get-window-class ( -- class-name )
class-name-ptr [
@ -749,17 +751,18 @@ M: windows-ui-backend beep ( -- )
: fullscreen-RECT ( hwnd -- RECT )
MONITOR_DEFAULTTONEAREST MonitorFromWindow
"MONITORINFOEX" <c-object> dup length over set-MONITORINFOEX-cbSize
[ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ;
MONITORINFOEX <struct>
MONITORINFOEX heap-size >>cbSize
[ GetMonitorInfo win32-error=0/f ] keep rcMonitor>> ;
: client-area>RECT ( hwnd -- RECT )
"RECT" <c-object>
RECT <struct>
[ GetClientRect win32-error=0/f ]
[ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
[ nip ] 2tri ;
: 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 -- )
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
windows.ole32 parser lexer splitting grouping sequences
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
<PRIVATE
C-STRUCT: com-interface
{ "void*" "vtbl" } ;
MACRO: com-invoke ( n return parameters -- )
[ 2nip length ] 3keep
'[
_ npick com-interface-vtbl _ cell * alien-cell _ _
_ npick *void* _ cell * alien-cell _ _
"stdcall" alien-indirect
] ;
@ -31,7 +29,7 @@ unless
dup "f" = [ drop f ] [
dup +com-interface-definitions+ get-global at*
[ nip ]
[ swap " COM interface hasn't been defined" append throw ]
[ " COM interface hasn't been defined" prepend throw ]
if
] if ;
@ -100,3 +98,5 @@ SYNTAX: COM-INTERFACE:
define-words-for-com-interface ;
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 )
(query-interface-cases)
'[
swap 16 memory>byte-array
swap GUID memory>struct
_ case
[
"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 )
10 shift bitor ; inline
<< "TCHAR" require-c-type-arrays >>
ERROR: error-message-failed id ;
:: n>win32-error-string ( id -- string )
{
@ -705,7 +707,7 @@ ERROR: error-message-failed id ;
f
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
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
combinators windows.errors windows.types windows.gdi32 ;
IN: windows.fonts
: windows-font-name ( string -- string' )
H{
{ "sans-serif" "Tahoma" }
{ "serif" "Times New Roman" }
{ "monospace" "Courier New" }
} ?at drop ;
MEMO:: (cache-font) ( font -- HFONT )
font size>> neg ! nHeight
0 0 0 ! nWidth, nEscapement, nOrientation
font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight
font italic?>> TRUE FALSE ? ! fdwItalic
FALSE ! fdwUnderline
FALSE ! fdWStrikeOut
DEFAULT_CHARSET ! fdwCharSet
OUT_OUTLINE_PRECIS ! fdwOutputPrecision
CLIP_DEFAULT_PRECIS ! fdwClipPrecision
DEFAULT_QUALITY ! fdwQuality
DEFAULT_PITCH ! fdwPitchAndFamily
font name>> windows-font-name
CreateFont
dup win32-error=0/f ;
: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;
[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook
: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
[ metrics new 0 >>width ] dip {
[ TEXTMETRICW-tmHeight >>height ]
[ TEXTMETRICW-tmAscent >>ascent ]
[ TEXTMETRICW-tmDescent >>descent ]
} cleave ;
USING: assocs memoize locals kernel accessors init fonts math
combinators windows.errors windows.types windows.gdi32 ;
IN: windows.fonts
: windows-font-name ( string -- string' )
H{
{ "sans-serif" "Tahoma" }
{ "serif" "Times New Roman" }
{ "monospace" "Courier New" }
} ?at drop ;
MEMO:: (cache-font) ( font -- HFONT )
font size>> neg ! nHeight
0 0 0 ! nWidth, nEscapement, nOrientation
font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight
font italic?>> TRUE FALSE ? ! fdwItalic
FALSE ! fdwUnderline
FALSE ! fdWStrikeOut
DEFAULT_CHARSET ! fdwCharSet
OUT_OUTLINE_PRECIS ! fdwOutputPrecision
CLIP_DEFAULT_PRECIS ! fdwClipPrecision
DEFAULT_QUALITY ! fdwQuality
DEFAULT_PITCH ! fdwPitchAndFamily
font name>> windows-font-name
CreateFont
dup win32-error=0/f ;
: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;
[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook
: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
[ metrics new 0 >>width ] dip {
[ tmHeight>> >>height ]
[ tmAscent>> >>ascent ]
[ tmDescent>> >>descent ]
} 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_NEW_NAME 5
C-STRUCT: FILE_NOTIFY_INFORMATION
{ "DWORD" "NextEntryOffset" }
{ "DWORD" "Action" }
{ "DWORD" "FileNameLength" }
{ "WCHAR[1]" "FileName" } ;
STRUCT: FILE_NOTIFY_INFORMATION
{ NextEntryOffset DWORD }
{ Action DWORD }
{ FileNameLength DWORD }
{ FileName WCHAR[1] } ;
TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION
CONSTANT: STD_INPUT_HANDLE -10
@ -226,14 +227,14 @@ STRUCT: SYSTEMTIME
{ wSecond WORD }
{ wMilliseconds WORD } ;
C-STRUCT: TIME_ZONE_INFORMATION
{ "LONG" "Bias" }
{ { "WCHAR" 32 } "StandardName" }
{ "SYSTEMTIME" "StandardDate" }
{ "LONG" "StandardBias" }
{ { "WCHAR" 32 } "DaylightName" }
{ "SYSTEMTIME" "DaylightDate" }
{ "LONG" "DaylightBias" } ;
STRUCT: TIME_ZONE_INFORMATION
{ Bias LONG }
{ StandardName WCHAR[32] }
{ StandardDate SYSTEMTIME }
{ StandardBias LONG }
{ DaylightName WCHAR[32] }
{ DaylightDate SYSTEMTIME }
{ DaylightBias LONG } ;
STRUCT: FILETIME
{ dwLowDateTime DWORD }
@ -306,13 +307,13 @@ STRUCT: MEMORYSTATUSEX
TYPEDEF: void* LPMEMORYSTATUSEX
C-STRUCT: OSVERSIONINFO
{ "DWORD" "dwOSVersionInfoSize" }
{ "DWORD" "dwMajorVersion" }
{ "DWORD" "dwMinorVersion" }
{ "DWORD" "dwBuildNumber" }
{ "DWORD" "dwPlatformId" }
{ { "WCHAR" 128 } "szCSDVersion" } ;
STRUCT: OSVERSIONINFO
{ dwOSVersionInfoSize DWORD }
{ dwMajorVersion DWORD }
{ dwMinorVersion DWORD }
{ dwBuildNumber DWORD }
{ dwPlatformId DWORD }
{ szCSDVersion WCHAR[128] } ;
TYPEDEF: void* LPOSVERSIONINFO
@ -325,11 +326,11 @@ C-STRUCT: MEMORY_BASIC_INFORMATION
{ "DWORD" "protect" }
{ "DWORD" "type" } ;
C-STRUCT: GUID
{ "ULONG" "Data1" }
{ "WORD" "Data2" }
{ "WORD" "Data3" }
{ { "UCHAR" 8 } "Data4" } ;
STRUCT: GUID
{ Data1 ULONG }
{ Data2 WORD }
{ Data3 WORD }
{ Data4 UCHAR[8] } ;
/*
fBinary :1;
@ -659,13 +660,13 @@ C-STRUCT: TOKEN_PRIVILEGES
{ "LUID_AND_ATTRIBUTES*" "Privileges" } ;
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
C-STRUCT: WIN32_FILE_ATTRIBUTE_DATA
{ "DWORD" "dwFileAttributes" }
{ "FILETIME" "ftCreationTime" }
{ "FILETIME" "ftLastAccessTime" }
{ "FILETIME" "ftLastWriteTime" }
{ "DWORD" "nFileSizeHigh" }
{ "DWORD" "nFileSizeLow" } ;
STRUCT: WIN32_FILE_ATTRIBUTE_DATA
{ dwFileAttributes DWORD }
{ ftCreationTime FILETIME }
{ ftLastAccessTime FILETIME }
{ ftLastWriteTime FILETIME }
{ nFileSizeHigh DWORD }
{ nFileSizeLow DWORD } ;
TYPEDEF: WIN32_FILE_ATTRIBUTE_DATA* LPWIN32_FILE_ATTRIBUTE_DATA
C-STRUCT: BY_HANDLE_FILE_INFORMATION
@ -694,19 +695,17 @@ C-STRUCT: OFSTRUCT
TYPEDEF: OFSTRUCT* LPOFSTRUCT
! MAX_PATH = 260
C-STRUCT: WIN32_FIND_DATA
{ "DWORD" "dwFileAttributes" }
{ "FILETIME" "ftCreationTime" }
{ "FILETIME" "ftLastAccessTime" }
{ "FILETIME" "ftLastWriteTime" }
{ "DWORD" "nFileSizeHigh" }
{ "DWORD" "nFileSizeLow" }
{ "DWORD" "dwReserved0" }
{ "DWORD" "dwReserved1" }
! { { "TCHAR" MAX_PATH } "cFileName" }
{ { "TCHAR" 260 } "cFileName" }
{ { "TCHAR" 14 } "cAlternateFileName" } ;
STRUCT: WIN32_FIND_DATA
{ dwFileAttributes DWORD }
{ ftCreationTime FILETIME }
{ ftLastAccessTime FILETIME }
{ ftLastWriteTime FILETIME }
{ nFileSizeHigh DWORD }
{ nFileSizeLow DWORD }
{ dwReserved0 DWORD }
{ dwReserved1 DWORD }
{ cFileName { "TCHAR" MAX_PATH } }
{ cAlternateFileName TCHAR[14] } ;
STRUCT: BY_HANDLE_FILE_INFORMATION
{ dwFileAttributes DWORD }

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

@ -2,25 +2,26 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel combinators sequences
math windows.gdi32 windows.types images destructors
accessors fry locals ;
accessors fry locals classes.struct ;
IN: windows.offscreen
: (bitmap-info) ( dim -- BITMAPINFO )
"BITMAPINFO" <c-object> [
BITMAPINFO-bmiHeader {
[ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
[ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
[ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
[ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
[ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
[ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
[ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
[ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
[ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
[ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
[ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
} 2cleave
] keep ;
[
BITMAPINFO <struct>
dup bmiHeader>>
BITMAPINFOHEADER heap-size >>biSize
] dip
[ first >>biWidth ]
[ second >>biHeight ]
[ first2 * 4 * >>biSizeImage ] tri
1 >>biPlanes
32 >>biBitCount
BI_RGB >>biCompression
72 >>biXPelsPerMeter
72 >>biYPelsPerMeter
0 >>biClrUsed
0 >>biClrImportant
drop ;
: make-bitmap ( dim dc -- hBitmap bits )
[ 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
[ t ] [
@ -19,17 +20,9 @@ IN: windows.ole32.tests
guid=
] unit-test
little-endian?
[ B{
HEX: 67 HEX: 45 HEX: 23 HEX: 01 HEX: ab HEX: 89 HEX: ef HEX: cd
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
[
GUID: 01234567-89ab-cdef-0123-456789abcdef}
] [ "{01234567-89ab-cdef-0123-456789abcdef}" string>guid ] unit-test
[ "{01234567-89ab-cdef-0123-456789abcdef}" ]
[ "{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
kernel sequences windows.errors windows.types io
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
LIBRARY: ole32
@ -130,60 +131,34 @@ TUPLE: ole32-error code message ;
: guid= ( a b -- ? )
[ 16 memory>byte-array ] bi@ = ;
: GUID-STRING-LENGTH ( -- n )
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
:: (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
CONSTANT: GUID-STRING-LENGTH
$[ "{01234567-89ab-cdef-0123-456789abcdef}" length ]
: string>guid ( string -- guid )
"GUID" <c-object> [
{
[ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ]
[ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
[ 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
"{-}" split harvest
[ first3 [ hex> ] tri@ ]
[ 3 tail concat 2 group [ hex> ] B{ } map-as ] bi
GUID <struct-boa> ;
: guid>string ( guid -- string )
[
"{" % {
[ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
[ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
[ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
[ ]
[ "{" ] dip {
[ Data1>> >hex 8 CHAR: 0 pad-head "-" ]
[ Data2>> >hex 4 CHAR: 0 pad-head "-" ]
[ 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
GUID-Data4 {
[ 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 ;
] "" append-outputs-as ;

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

@ -3,7 +3,7 @@
USING: alien alien.c-types alien.strings alien.syntax
combinators io.encodings.utf16n io.files io.pathnames kernel
windows.errors windows.com windows.com.syntax windows.user32
windows.ole32 windows ;
windows.ole32 windows specialized-arrays.ushort classes.struct ;
IN: windows.shell32
CONSTANT: CSIDL_DESKTOP HEX: 00
@ -90,7 +90,7 @@ ALIAS: ShellExecute ShellExecuteW
: shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT
MAX_UNICODE_PATH "ushort" <c-array>
MAX_UNICODE_PATH <ushort-array>
[ SHGetFolderPath drop ] keep utf16n alien>string ;
: desktop ( -- str )
@ -167,23 +167,23 @@ CONSTANT: SFGAO_NEWCONTENT HEX: 00200000
TYPEDEF: ULONG SFGAOF
C-STRUCT: DROPFILES
{ "DWORD" "pFiles" }
{ "POINT" "pt" }
{ "BOOL" "fNC" }
{ "BOOL" "fWide" } ;
STRUCT: DROPFILES
{ pFiles DWORD }
{ pt POINT }
{ fNC BOOL }
{ fWide BOOL } ;
TYPEDEF: DROPFILES* LPDROPFILES
TYPEDEF: DROPFILES* LPCDROPFILES
TYPEDEF: HANDLE HDROP
C-STRUCT: SHITEMID
{ "USHORT" "cb" }
{ "BYTE[1]" "abID" } ;
STRUCT: SHITEMID
{ cb USHORT }
{ abID BYTE[1] } ;
TYPEDEF: SHITEMID* LPSHITEMID
TYPEDEF: SHITEMID* LPCSHITEMID
C-STRUCT: ITEMIDLIST
{ "SHITEMID" "mkid" } ;
STRUCT: ITEMIDLIST
{ mkid SHITEMID } ;
TYPEDEF: ITEMIDLIST* LPITEMIDLIST
TYPEDEF: ITEMIDLIST* LPCITEMIDLIST
TYPEDEF: ITEMIDLIST ITEMID_CHILD
@ -195,9 +195,9 @@ CONSTANT: STRRET_OFFSET 1
CONSTANT: STRRET_CSTR 2
C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
C-STRUCT: STRRET
{ "int" "uType" }
{ "STRRET-union" "union" } ;
STRUCT: STRRET
{ uType int }
{ union STRRET-union } ;
COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046}
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.
USING: alien alien.c-types alien.syntax namespaces kernel words
sequences math math.bitwise math.vectors colors
io.encodings.utf16n classes.struct ;
io.encodings.utf16n classes.struct accessors ;
IN: windows.types
TYPEDEF: char CHAR
@ -216,37 +216,37 @@ CONSTANT: TRUE 1
! typedef LRESULT (CALLBACK* WNDPROC)(HWND, UINT, WPARAM, LPARAM);
C-STRUCT: WNDCLASS
{ "UINT" "style" }
{ "WNDPROC" "lpfnWndProc" }
{ "int" "cbClsExtra" }
{ "int" "cbWndExtra" }
{ "HINSTANCE" "hInstance" }
{ "HICON" "hIcon" }
{ "HCURSOR" "hCursor" }
{ "HBRUSH" "hbrBackground" }
{ "LPCTSTR" "lpszMenuName" }
{ "LPCTSTR" "lpszClassName" } ;
STRUCT: WNDCLASS
{ style UINT }
{ lpfnWndProc WNDPROC }
{ cbClsExtra int }
{ cbWndExtra int }
{ hInstance HINSTANCE }
{ hIcon HICON }
{ hCursor HCURSOR }
{ hbrBackground HBRUSH }
{ lpszMenuName LPCTSTR }
{ lpszClassName LPCTSTR } ;
C-STRUCT: WNDCLASSEX
{ "UINT" "cbSize" }
{ "UINT" "style" }
{ "WNDPROC" "lpfnWndProc" }
{ "int" "cbClsExtra" }
{ "int" "cbWndExtra" }
{ "HINSTANCE" "hInstance" }
{ "HICON" "hIcon" }
{ "HCURSOR" "hCursor" }
{ "HBRUSH" "hbrBackground" }
{ "LPCTSTR" "lpszMenuName" }
{ "LPCTSTR" "lpszClassName" }
{ "HICON" "hIconSm" } ;
STRUCT: WNDCLASSEX
{ cbSize UINT }
{ style UINT }
{ lpfnWndProc WNDPROC }
{ cbClsExtra int }
{ cbWndExtra int }
{ hInstance HINSTANCE }
{ hIcon HICON }
{ hCursor HCURSOR }
{ hbrBackground HBRUSH }
{ lpszMenuName LPCTSTR }
{ lpszClassName LPCTSTR }
{ hIconSm HICON } ;
C-STRUCT: RECT
{ "LONG" "left" }
{ "LONG" "top" }
{ "LONG" "right" }
{ "LONG" "bottom" } ;
STRUCT: RECT
{ left LONG }
{ top LONG }
{ right LONG }
{ bottom LONG } ;
C-STRUCT: PAINTSTRUCT
{ "HDC" " hdc" }
@ -257,28 +257,28 @@ C-STRUCT: PAINTSTRUCT
{ "BYTE[32]" "rgbReserved" }
;
C-STRUCT: BITMAPINFOHEADER
{ "DWORD" "biSize" }
{ "LONG" "biWidth" }
{ "LONG" "biHeight" }
{ "WORD" "biPlanes" }
{ "WORD" "biBitCount" }
{ "DWORD" "biCompression" }
{ "DWORD" "biSizeImage" }
{ "LONG" "biXPelsPerMeter" }
{ "LONG" "biYPelsPerMeter" }
{ "DWORD" "biClrUsed" }
{ "DWORD" "biClrImportant" } ;
STRUCT: BITMAPINFOHEADER
{ biSize DWORD }
{ biWidth LONG }
{ biHeight LONG }
{ biPlanes WORD }
{ biBitCount WORD }
{ biCompression DWORD }
{ biSizeImage DWORD }
{ biXPelsPerMeter LONG }
{ biYPelsPerMeter LONG }
{ biClrUsed DWORD }
{ biClrImportant DWORD } ;
C-STRUCT: RGBQUAD
{ "BYTE" "rgbBlue" }
{ "BYTE" "rgbGreen" }
{ "BYTE" "rgbRed" }
{ "BYTE" "rgbReserved" } ;
STRUCT: RGBQUAD
{ rgbBlue BYTE }
{ rgbGreen BYTE }
{ rgbRed BYTE }
{ rgbReserved BYTE } ;
C-STRUCT: BITMAPINFO
{ "BITMAPINFOHEADER" "bmiHeader" }
{ "RGBQUAD[1]" "bmiColors" } ;
STRUCT: BITMAPINFO
{ bmiHeader BITMAPINFOHEADER }
{ bimColors RGBQUAD[1] } ;
TYPEDEF: void* LPPAINTSTRUCT
TYPEDEF: void* PAINTSTRUCT
@ -287,9 +287,9 @@ C-STRUCT: POINT
{ "LONG" "x" }
{ "LONG" "y" } ;
C-STRUCT: SIZE
{ "LONG" "cx" }
{ "LONG" "cy" } ;
STRUCT: SIZE
{ cx LONG }
{ cy LONG } ;
C-STRUCT: MSG
{ "HWND" "hWnd" }
@ -329,19 +329,10 @@ STRUCT: PIXELFORMATDESCRIPTOR
{ dwVisibleMask DWORD }
{ dwDamageMask DWORD } ;
C-STRUCT: RECT
{ "LONG" "left" }
{ "LONG" "top" }
{ "LONG" "right" }
{ "LONG" "bottom" } ;
: <RECT> ( loc dim -- RECT )
over v+
"RECT" <c-object>
over first over set-RECT-right
swap second over set-RECT-bottom
over first over set-RECT-left
swap second over set-RECT-top ;
[ RECT <struct> ] 2dip
[ drop [ first >>left ] [ second >>top ] bi ]
[ v+ [ first >>right ] [ second >>bottom ] bi ] 2bi ;
TYPEDEF: RECT* PRECT
TYPEDEF: RECT* LPRECT
@ -389,26 +380,26 @@ TYPEDEF: DWORD* LPCOLORREF
: color>RGB ( color -- COLORREF )
>rgba-components drop [ 255 * >integer ] tri@ RGB ;
C-STRUCT: TEXTMETRICW
{ "LONG" "tmHeight" }
{ "LONG" "tmAscent" }
{ "LONG" "tmDescent" }
{ "LONG" "tmInternalLeading" }
{ "LONG" "tmExternalLeading" }
{ "LONG" "tmAveCharWidth" }
{ "LONG" "tmMaxCharWidth" }
{ "LONG" "tmWeight" }
{ "LONG" "tmOverhang" }
{ "LONG" "tmDigitizedAspectX" }
{ "LONG" "tmDigitizedAspectY" }
{ "WCHAR" "tmFirstChar" }
{ "WCHAR" "tmLastChar" }
{ "WCHAR" "tmDefaultChar" }
{ "WCHAR" "tmBreakChar" }
{ "BYTE" "tmItalic" }
{ "BYTE" "tmUnderlined" }
{ "BYTE" "tmStruckOut" }
{ "BYTE" "tmPitchAndFamily" }
{ "BYTE" "tmCharSet" } ;
STRUCT: TEXTMETRICW
{ tmHeight LONG }
{ tmAscent LONG }
{ tmDescent LONG }
{ tmInternalLeading LONG }
{ tmExternalLeading LONG }
{ tmAveCharWidth LONG }
{ tmMaxCharWidth LONG }
{ tmWeight LONG }
{ tmOverhang LONG }
{ tmDigitizedAspectX LONG }
{ tmDigitizedAspectY LONG }
{ tmFirstChar WCHAR }
{ tmLastChar WCHAR }
{ tmDefaultChar WCHAR }
{ tmBreakChar WCHAR }
{ tmItalic BYTE }
{ tmUnderlined BYTE }
{ tmStruckOut BYTE }
{ tmPitchAndFamily BYTE }
{ tmCharSet BYTE } ;
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
cache namespaces init fonts alien.c-types windows.usp10
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
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 )
ssa>> ScriptString_pSize
dup win32-error=0/f
[ SIZE-cx ] [ SIZE-cy ] bi 2array ;
SIZE memory>struct
[ cx>> ] [ cy>> ] bi 2array ;
: dc-metrics ( dc -- metrics )
"TEXTMETRICW" <c-object>
TEXTMETRICW <struct>
[ GetTextMetrics drop ] keep
TEXTMETRIC>metrics ;

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

@ -1,7 +1,8 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
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
! HKL for ActivateKeyboardLayout
@ -74,8 +75,10 @@ CONSTANT: WS_EX_RIGHTSCROLLBAR HEX: 00000000
CONSTANT: WS_EX_CONTROLPARENT HEX: 00010000
CONSTANT: WS_EX_STATICEDGE HEX: 00020000
CONSTANT: WS_EX_APPWINDOW HEX: 00040000
: WS_EX_OVERLAPPEDWINDOW ( -- n )
WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable
: WS_EX_PALETTEWINDOW ( -- n )
{ 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_CANCEL HEX: 80000000
CONSTANT: HOVER_DEFAULT HEX: ffffffff
C-STRUCT: TRACKMOUSEEVENT
{ "DWORD" "cbSize" }
{ "DWORD" "dwFlags" }
{ "HWND" "hwndTrack" }
{ "DWORD" "dwHoverTime" } ;
STRUCT: TRACKMOUSEEVENT
{ cbSize DWORD }
{ dwFlags DWORD }
{ hwndTrack HWND }
{ dwHoverTime DWORD } ;
TYPEDEF: TRACKMOUSEEVENT* LPTRACKMOUSEEVENT
CONSTANT: DBT_DEVICEARRIVAL HEX: 8000
@ -538,26 +541,26 @@ CONSTANT: DEVICE_NOTIFY_SERVICE_HANDLE 1
CONSTANT: DEVICE_NOTIFY_ALL_INTERFACE_CLASSES 4
C-STRUCT: DEV_BROADCAST_HDR
{ "DWORD" "dbch_size" }
{ "DWORD" "dbch_devicetype" }
{ "DWORD" "dbch_reserved" } ;
STRUCT: DEV_BROADCAST_HDR
{ dbch_size DWORD }
{ dbch_devicetype DWORD }
{ dbch_reserved DWORD } ;
C-STRUCT: DEV_BROADCAST_DEVICEW
{ "DWORD" "dbcc_size" }
{ "DWORD" "dbcc_devicetype" }
{ "DWORD" "dbcc_reserved" }
{ "GUID" "dbcc_classguid" }
{ { "WCHAR" 1 } "dbcc_name" } ;
STRUCT: DEV_BROADCAST_DEVICEW
{ dbcc_size DWORD }
{ dbcc_devicetype DWORD }
{ dbcc_reserved DWORD }
{ dbcc_classguid GUID }
{ dbcc_name WCHAR[1] } ;
CONSTANT: CCHDEVICENAME 32
C-STRUCT: MONITORINFOEX
{ "DWORD" "cbSize" }
{ "RECT" "rcMonitor" }
{ "RECT" "rcWork" }
{ "DWORD" "dwFlags" }
{ { "TCHAR" CCHDEVICENAME } "szDevice" } ;
STRUCT: MONITORINFOEX
{ cbSize DWORD }
{ rcMonitor RECT }
{ rcWork RECT }
{ dwFlags DWORD }
{ szDevice { "TCHAR" $ CCHDEVICENAME } } ;
TYPEDEF: MONITORINFOEX* LPMONITORINFOEX
TYPEDEF: MONITORINFOEX* LPMONITORINFO

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

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
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
USE: libc
@ -121,12 +122,12 @@ C-STRUCT: sockaddr-in6
{ { "uchar" 16 } "addr" }
{ "uint" "scopeid" } ;
C-STRUCT: hostent
{ "char*" "name" }
{ "void*" "aliases" }
{ "short" "addrtype" }
{ "short" "length" }
{ "void*" "addr-list" } ;
STRUCT: hostent
{ name char* }
{ aliases void* }
{ addrtype short }
{ length short }
{ addr-list void* } ;
C-STRUCT: addrinfo
{ "int" "flags" }
@ -142,11 +143,8 @@ C-STRUCT: timeval
{ "long" "sec" }
{ "long" "usec" } ;
: hostent-addr ( hostent -- addr ) hostent-addr-list *void* ; ! *uint ;
LIBRARY: winsock
FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
FUNCTION: ushort htons ( ushort n ) ;
@ -195,9 +193,9 @@ C-STRUCT: FLOWSPEC
TYPEDEF: FLOWSPEC* PFLOWSPEC
TYPEDEF: FLOWSPEC* LPFLOWSPEC
C-STRUCT: WSABUF
{ "ulong" "len" }
{ "void*" "buf" } ;
STRUCT: WSABUF
{ len ulong }
{ buf void* } ;
TYPEDEF: WSABUF* LPWSABUF
C-STRUCT: QOS
@ -377,8 +375,6 @@ FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
BOOL fAlertable ) ;
LIBRARY: mswsock
! 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
: WSAID_CONNECTEX ( -- GUID )
"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 ;
CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
: 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 )
! #! 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 ]
tri ;
M: tuple string>alien drop underlying>> ;
HOOK: alien>native-string os ( 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.
USING: io.files.windows io.streams.duplex kernel math
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
: <serial-stream> ( path encoding -- duplex )
@ -10,7 +11,7 @@ IN: io.serial.windows
: get-comm-state ( duplex -- dcb )
in>> handle>>
"DCB" <c-object> tuck
DCB <struct> tuck
GetCommState win32-error=0/f ;
: 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 ;
: os-version ( -- os-version )
"OSVERSIONINFO" <c-object>
"OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize
OSVERSIONINFO <struct>
OSVERSIONINFO heap-size >>dwOSVersionInfoSize
dup GetVersionEx win32-error=0/f ;
: windows-major ( -- n )
os-version OSVERSIONINFO-dwMajorVersion ;
os-version dwMajorVersion>> ;
: windows-minor ( -- n )
os-version OSVERSIONINFO-dwMinorVersion ;
os-version dwMinorVersion>> ;
: windows-build# ( -- n )
os-version OSVERSIONINFO-dwBuildNumber ;
os-version dwBuildNumber>> ;
: windows-platform-id ( -- n )
os-version OSVERSIONINFO-dwPlatformId ;
os-version dwPlatformId>> ;
: windows-service-pack ( -- string )
os-version OSVERSIONINFO-szCSDVersion alien>native-string ;
os-version szCSDVersion>> alien>native-string ;
: feature-present? ( n -- ? )
IsProcessorFeaturePresent zero? not ;