From 065db0868031e3d04c3e95abefd8b5c0efe62b08 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Aug 2009 20:39:37 -0500 Subject: [PATCH 01/42] TRACKMOUSEVENT uses now --- basis/ui/backend/windows/windows.factor | 9 +++++---- basis/windows/user32/user32.factor | 10 +++++----- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 7ce9afe5e6..64e87e0a4c 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -503,14 +503,15 @@ SYMBOL: nc-buttons ] if ; : make-TRACKMOUSEEVENT ( hWnd -- alien ) - "TRACKMOUSEEVENT" [ set-TRACKMOUSEEVENT-hwndTrack ] keep - "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ; + TRACKMOUSEEVENT + 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 ; diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 58981920da..543ce6e292 100755 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -521,11 +521,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 From 7df875c7fe3353f0a252b3f1fdc4abfa2d2dce9a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Aug 2009 20:43:42 -0500 Subject: [PATCH 02/42] update WNDCLASSEX --- basis/ui/backend/windows/windows.factor | 21 ++++++++++---------- basis/windows/types/types.factor | 26 ++++++++++++------------- 2 files changed, 23 insertions(+), 24 deletions(-) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 64e87e0a4c..6ccb53e8b2 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -589,19 +589,18 @@ M: windows-ui-backend do-events ] if ; :: register-window-class ( class-name-ptr -- ) - "WNDCLASSEX" f GetModuleHandle + WNDCLASSEX 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 ; diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 36823db424..37505210b5 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -228,19 +228,19 @@ C-STRUCT: WNDCLASS { "LPCTSTR" "lpszMenuName" } { "LPCTSTR" "lpszClassName" } ; -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" } From c9268547903e432abb0909e839a5d8e382a50357 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Aug 2009 21:16:28 -0500 Subject: [PATCH 03/42] update RECT for new structs --- basis/ui/backend/windows/windows.factor | 24 +++++++++++++----------- basis/windows/types/types-tests.factor | 10 ++++++++++ basis/windows/types/types.factor | 21 +++++++++------------ 3 files changed, 32 insertions(+), 23 deletions(-) create mode 100755 basis/windows/types/types-tests.factor diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 6ccb53e8b2..5ff33c65d6 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -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 @@ -610,12 +612,12 @@ M: windows-ui-backend do-events : make-RECT ( world -- RECT ) [ window-loc>> ] [ dim>> ] bi ; -: 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 [ diff --git a/basis/windows/types/types-tests.factor b/basis/windows/types/types-tests.factor new file mode 100755 index 0000000000..04b480d4d3 --- /dev/null +++ b/basis/windows/types/types-tests.factor @@ -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 } ] unit-test + +[ S{ RECT { left 100 } { top 100 } { right 200 } { bottom 200 } } ] +[ { 100 100 } { 100 100 } ] unit-test diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 37505210b5..081e03f292 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -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 @@ -242,11 +242,11 @@ STRUCT: WNDCLASSEX { 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" } @@ -336,12 +336,9 @@ C-STRUCT: RECT { "LONG" "bottom" } ; : ( loc dim -- RECT ) - over v+ - "RECT" - 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 ] 2dip + [ drop [ first >>left ] [ second >>top ] bi ] + [ v+ [ first >>right ] [ second >>bottom ] bi ] 2bi ; TYPEDEF: RECT* PRECT TYPEDEF: RECT* LPRECT From 111c0f6b895f02cacbe56a198fea22d17f5681f8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 27 Aug 2009 21:43:29 -0500 Subject: [PATCH 04/42] more struct changes --- basis/game-input/dinput/dinput.factor | 22 ++++++++------- basis/ui/backend/windows/windows.factor | 9 +++--- basis/windows/types/types.factor | 28 ++++++++----------- basis/windows/user32/user32.factor | 37 +++++++++++++------------ 4 files changed, 48 insertions(+), 48 deletions(-) diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor index 6cd161bd28..26d57871d7 100755 --- a/basis/game-input/dinput/dinput.factor +++ b/basis/game-input/dinput/dinput.factor @@ -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" - "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 + DEV_BROADCAST_DEVICEW heap-size >>dbcc_size + DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ; : create-device-change-window ( -- ) 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 diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 5ff33c65d6..cf4966b756 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -751,17 +751,18 @@ M: windows-ui-backend beep ( -- ) : fullscreen-RECT ( hwnd -- RECT ) MONITOR_DEFAULTTONEAREST MonitorFromWindow - "MONITORINFOEX" dup length over set-MONITORINFOEX-cbSize - [ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ; + MONITORINFOEX + MONITORINFOEX heap-size >>cbSize + [ GetMonitorInfo win32-error=0/f ] keep rcMonitor>> ; : client-area>RECT ( hwnd -- RECT ) - "RECT" + RECT [ GetClientRect win32-error=0/f ] [ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ] [ nip ] 2tri ; : hwnd>RECT ( hwnd -- RECT ) - "RECT" [ GetWindowRect win32-error=0/f ] keep ; + RECT [ GetWindowRect win32-error=0/f ] keep ; M: windows-ui-backend (grab-input) ( handle -- ) 0 ShowCursor drop diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 081e03f292..59192bb3b6 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -216,17 +216,17 @@ 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 } ; STRUCT: WNDCLASSEX { cbSize UINT } @@ -329,12 +329,6 @@ STRUCT: PIXELFORMATDESCRIPTOR { dwVisibleMask DWORD } { dwDamageMask DWORD } ; -C-STRUCT: RECT - { "LONG" "left" } - { "LONG" "top" } - { "LONG" "right" } - { "LONG" "bottom" } ; - : ( loc dim -- RECT ) [ RECT ] 2dip [ drop [ first >>left ] [ second >>top ] bi ] diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 543ce6e292..4c39385ce5 100755 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -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 @@ -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 From f517e22e911fba522184ba2aa1ca8e0aefe0f269 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 13:39:48 -0500 Subject: [PATCH 05/42] structs in calendar.windows --- basis/calendar/windows/windows.factor | 14 ++++++-------- basis/windows/kernel32/kernel32.factor | 16 ++++++++-------- 2 files changed, 14 insertions(+), 16 deletions(-) diff --git a/basis/calendar/windows/windows.factor b/basis/calendar/windows/windows.factor index caab530a23..65c922f119 100644 --- a/basis/calendar/windows/windows.factor +++ b/basis/calendar/windows/windows.factor @@ -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 +classes.struct accessors ; IN: calendar.windows M: windows gmt-offset ( -- hours minutes seconds ) - "TIME_ZONE_INFORMATION" + TIME_ZONE_INFORMATION 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 ; diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 50a03945f3..30007bb5a0 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -226,14 +226,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 } From d2accedf8d9c4786b7a1531264d6fa8cec125b57 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 13:45:25 -0500 Subject: [PATCH 06/42] more structs --- basis/io/files/info/windows/windows.factor | 19 +++++------- basis/io/monitors/windows/nt/nt.factor | 12 +++----- basis/windows/kernel32/kernel32.factor | 35 +++++++++++----------- 3 files changed, 29 insertions(+), 37 deletions(-) diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 587747ac34..684df6191e 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -35,20 +35,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" [ + WIN32_FIND_DATA [ FindFirstFile [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep FindClose win32-error=0/f diff --git a/basis/io/monitors/windows/nt/nt.factor b/basis/io/monitors/windows/nt/nt.factor index bec249c04c..cd497b1c87 100755 --- a/basis/io/monitors/windows/nt/nt.factor +++ b/basis/io/monitors/windows/nt/nt.factor @@ -55,17 +55,13 @@ 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 ) dup , - dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [ - [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep + dup NextEntryOffset>> zero? [ + [ NextEntryOffset>> ] [ ] bi (file-notify-records) ] unless ; diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 30007bb5a0..1adb07cf1e 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -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 @@ -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 } From 56be96429ab2877ff76ce9549be64e27cbaccfcc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 14:28:00 -0500 Subject: [PATCH 07/42] fix io monitors --- basis/io/monitors/windows/nt/nt.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/io/monitors/windows/nt/nt.factor b/basis/io/monitors/windows/nt/nt.factor index cd497b1c87..3d837d79d8 100755 --- a/basis/io/monitors/windows/nt/nt.factor +++ b/basis/io/monitors/windows/nt/nt.factor @@ -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 ) @@ -59,9 +59,10 @@ TUPLE: win32-monitor < monitor port ; [ Action>> parse-action ] bi ; : (file-notify-records) ( buffer -- buffer ) + FILE_NOTIFY_INFORMATION memory>struct dup , dup NextEntryOffset>> zero? [ - [ NextEntryOffset>> ] [ ] bi + [ NextEntryOffset>> ] [ >c-ptr ] bi (file-notify-records) ] unless ; From 6aeb3614ff808a9fd18937b2e5d1503e88d3df4c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 14:29:46 -0500 Subject: [PATCH 08/42] new structs in font rendering --- basis/windows/fonts/fonts.factor | 74 ++++++++++++------------ basis/windows/types/types.factor | 42 +++++++------- basis/windows/uniscribe/uniscribe.factor | 5 +- 3 files changed, 61 insertions(+), 60 deletions(-) diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor index 269e8f8f48..b8acf5d8d1 100755 --- a/basis/windows/fonts/fonts.factor +++ b/basis/windows/fonts/fonts.factor @@ -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 ; diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 59192bb3b6..c62de58bcd 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -380,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 diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index 457f4bc9f0..7dd630ca5b 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -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 ; @@ -84,7 +85,7 @@ TUPLE: script-string < disposable font string metrics ssa size image ; [ SIZE-cx ] [ SIZE-cy ] bi 2array ; : dc-metrics ( dc -- metrics ) - "TEXTMETRICW" + TEXTMETRICW [ GetTextMetrics drop ] keep TEXTMETRIC>metrics ; From b8164120f5813756cb9c727d142c6eb8c0210083 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 14:37:09 -0500 Subject: [PATCH 09/42] oops, forgot to update a struct --- basis/io/directories/windows/windows.factor | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/basis/io/directories/windows/windows.factor b/basis/io/directories/windows/windows.factor index 7554baa944..d1931526bd 100755 --- a/basis/io/directories/windows/windows.factor +++ b/basis/io/directories/windows/windows.factor @@ -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 ) From 3ecb3a85db9bf15b21b56c61e220004257b04bbc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 17:08:25 -0500 Subject: [PATCH 10/42] SIZE struct --- basis/windows/types/types.factor | 6 +++--- basis/windows/uniscribe/uniscribe.factor | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index c62de58bcd..fb3ba7f0f5 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -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" } diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index 7dd630ca5b..1c1830fa02 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -82,7 +82,7 @@ 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 ; + [ cx>> ] [ cy>> ] bi 2array ; : dc-metrics ( dc -- metrics ) TEXTMETRICW From eb21a7b0dd93f4c41dbdfbf1474aff1ea4d47cd3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 17:18:30 -0500 Subject: [PATCH 11/42] fix uniscribe --- basis/windows/uniscribe/uniscribe.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index 1c1830fa02..9555927ab1 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -82,6 +82,7 @@ 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 memory>struct [ cx>> ] [ cy>> ] bi 2array ; : dc-metrics ( dc -- metrics ) From 0c37990f53ae7c8f5d851dbe2b597cfadd2bc7ae Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 17:35:11 -0500 Subject: [PATCH 12/42] windows.offscreen structs --- basis/windows/offscreen/offscreen.factor | 33 +++++++++---------- basis/windows/types/types.factor | 40 ++++++++++++------------ 2 files changed, 37 insertions(+), 36 deletions(-) diff --git a/basis/windows/offscreen/offscreen.factor b/basis/windows/offscreen/offscreen.factor index fea7240bf6..63cfd92ba1 100755 --- a/basis/windows/offscreen/offscreen.factor +++ b/basis/windows/offscreen/offscreen.factor @@ -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" [ - 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 + 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 ] diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index fb3ba7f0f5..8a5c963de0 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -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 From 50a99dcce6305904dcf92adae78b575c8b4e9132 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 17:41:08 -0500 Subject: [PATCH 13/42] guid, system-info --- basis/calendar/windows/windows.factor | 2 +- basis/windows/kernel32/kernel32.factor | 24 +++---- basis/windows/ole32/ole32.factor | 79 ++++++++---------------- basis/windows/winsock/winsock.factor | 11 ++-- extra/system-info/windows/windows.factor | 14 ++--- 5 files changed, 51 insertions(+), 79 deletions(-) diff --git a/basis/calendar/windows/windows.factor b/basis/calendar/windows/windows.factor index 65c922f119..265a58507c 100644 --- a/basis/calendar/windows/windows.factor +++ b/basis/calendar/windows/windows.factor @@ -1,6 +1,6 @@ USING: calendar namespaces alien.c-types system windows.kernel32 kernel math combinators windows.errors -classes.struct accessors ; +accessors classes.struct ; IN: calendar.windows M: windows gmt-offset ( -- hours minutes seconds ) diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 1adb07cf1e..2182088efe 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -307,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 @@ -326,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; diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor index 639a9ba637..37a3a90d3b 100755 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -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" [ - { - [ 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 ; : guid>string ( guid -- string ) [ - "{" % { - [ [ GUID-Data1 ] 8 (guid-section%) "-" % ] - [ [ GUID-Data2 ] 4 (guid-section%) "-" % ] - [ [ GUID-Data3 ] 4 (guid-section%) "-" % ] - [ ] + [ "{" ] dip { + [ Data1>> >hex "-" ] + [ Data2>> >hex "-" ] + [ Data3>> >hex "-" ] + [ + 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 - HEX: 25a207b9 over set-GUID-Data1 - HEX: ddf3 over set-GUID-Data2 - HEX: 4660 over set-GUID-Data3 + HEX: 25a207b9 + HEX: ddf3 + HEX: 4660 B{ HEX: 8e HEX: e9 HEX: 76 HEX: e5 HEX: 8c HEX: 74 HEX: 06 HEX: 3e - } over set-GUID-Data4 ; + } GUID ; : winsock-expected-error? ( n -- ? ) ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING 3array member? ; diff --git a/extra/system-info/windows/windows.factor b/extra/system-info/windows/windows.factor index e68f6ce62f..8e0dc60e25 100755 --- a/extra/system-info/windows/windows.factor +++ b/extra/system-info/windows/windows.factor @@ -21,24 +21,24 @@ IN: system-info.windows system-info dwOemId>> HEX: ffff0000 bitand ; : os-version ( -- os-version ) - "OSVERSIONINFO" - "OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize + OSVERSIONINFO + 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 ; From ec579dcfc1f8f2f52c22e94b020e11c341f0b6a7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 17:42:14 -0500 Subject: [PATCH 14/42] fix using --- basis/windows/winsock/winsock.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index 7e6b2bd803..bd7304cde1 100755 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -2,7 +2,7 @@ ! 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 ; IN: windows.winsock USE: libc From 135d56fcd232ea78bfa2e48c654c417f55c90c37 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 19:18:39 -0500 Subject: [PATCH 15/42] fix com, prettyprinting of GUIDs --- basis/windows/com/syntax/syntax.factor | 5 ++++- basis/windows/com/wrapper/wrapper.factor | 2 +- basis/windows/ole32/ole32-tests.factor | 17 +++++------------ basis/windows/ole32/ole32.factor | 6 +++--- 4 files changed, 13 insertions(+), 17 deletions(-) diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor index 59a76bf4d7..56ae0aa71c 100755 --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -1,7 +1,8 @@ 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 guid parsed ; + +M: GUID pprint* guid>string "GUID: " prepend text ; diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index afa3abf287..3d78ccc849 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -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 com-add-ref diff --git a/basis/windows/ole32/ole32-tests.factor b/basis/windows/ole32/ole32-tests.factor index ecd25738b1..aa02211ef3 100644 --- a/basis/windows/ole32/ole32-tests.factor +++ b/basis/windows/ole32/ole32-tests.factor @@ -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 ] diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor index 37a3a90d3b..0942123504 100755 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -143,9 +143,9 @@ CONSTANT: GUID-STRING-LENGTH : guid>string ( guid -- string ) [ [ "{" ] dip { - [ Data1>> >hex "-" ] - [ Data2>> >hex "-" ] - [ Data3>> >hex "-" ] + [ Data1>> >hex 8 CHAR: 0 pad-head "-" ] + [ Data2>> >hex 4 CHAR: 0 pad-head "-" ] + [ Data3>> >hex 4 CHAR: 0 pad-head "-" ] [ Data4>> [ { From a81c78e4851cc3a7f5028e952b7c46ec2801e525 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 19:25:18 -0500 Subject: [PATCH 16/42] WSABUF struct --- basis/io/sockets/windows/nt/nt.factor | 19 +++++++++---------- basis/windows/winsock/winsock.factor | 6 +++--- 2 files changed, 12 insertions(+), 13 deletions(-) diff --git a/basis/io/sockets/windows/nt/nt.factor b/basis/io/sockets/windows/nt/nt.factor index 6d082f953c..6780fdcdd6 100755 --- a/basis/io/sockets/windows/nt/nt.factor +++ b/basis/io/sockets/windows/nt/nt.factor @@ -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 ; IN: io.sockets.windows.nt : malloc-int ( object -- object ) @@ -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 : ( 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 : ( packet addrspec datagram -- WSASendTo ) WSASendTo-args new diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index bd7304cde1..d19e4aca09 100755 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -195,9 +195,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 From 57673db7caf46f91e87b00e17912bcc6bcb8b6ed Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 19:33:04 -0500 Subject: [PATCH 17/42] remove com-interface c-struct --- basis/windows/com/syntax/syntax.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor index 56ae0aa71c..d380b1ba83 100755 --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -7,13 +7,10 @@ IN: windows.com.syntax Date: Sat, 29 Aug 2009 19:43:56 -0500 Subject: [PATCH 18/42] more WIN32_FIND_DATA structs --- basis/io/directories/windows/windows.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/io/directories/windows/windows.factor b/basis/io/directories/windows/windows.factor index d1931526bd..3a69dbfedb 100755 --- a/basis/io/directories/windows/windows.factor +++ b/basis/io/directories/windows/windows.factor @@ -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" + WIN32_FIND_DATA [ nip ] [ FindFirstFile ] 2bi [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ; : find-next-file ( path -- WIN32_FIND_DATA/f ) - "WIN32_FIND_DATA" + WIN32_FIND_DATA [ nip ] [ FindNextFile ] 2bi 0 = [ GetLastError ERROR_NO_MORE_FILES = [ win32-error From 0be2e172467a637adbccc63a6e548a3c893e767f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 19:55:27 -0500 Subject: [PATCH 19/42] put a method on M\ tuple string>alien that calls underlying>> --- core/alien/strings/strings.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index ff20b8b033..e96b13478e 100644 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -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 ; From e5b72af4037f1072f3c75f0fb29ebf6018dc94dc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 20:01:01 -0500 Subject: [PATCH 20/42] fix environment on winnt --- basis/environment/winnt/winnt.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/environment/winnt/winnt.factor b/basis/environment/winnt/winnt.factor index eb90a36ee7..d4ce25397c 100644 --- a/basis/environment/winnt/winnt.factor +++ b/basis/environment/winnt/winnt.factor @@ -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" + MAX_UNICODE_PATH "TCHAR" [ dup length GetEnvironmentVariable ] keep over 0 = [ 2drop f ] [ From 6e4ec190dfc5bd3689c23362e8e70d513e54dd17 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 20:34:29 -0500 Subject: [PATCH 21/42] remove c-array usage --- basis/io/files/info/windows/windows.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 684df6191e..052f5058d2 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -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' ) @@ -144,7 +145,7 @@ M: winnt file-system-info ( path -- file-system-info ) calculate-file-system-info ; : volume>paths ( string -- array ) - 16384 "ushort" tuck dup length + 16384 tuck dup length 0 dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [ win32-error-string throw ] [ From a5c078213a87d9ffe8fee83341f4b98afc1d52bb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 20:39:06 -0500 Subject: [PATCH 22/42] more struct work --- basis/io/files/windows/nt/nt.factor | 12 +++++------- basis/windows/kernel32/kernel32.factor | 14 +++++++------- 2 files changed, 12 insertions(+), 14 deletions(-) diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor index 32424a37a3..17cfa0977e 100755 --- a/basis/io/files/windows/nt/nt.factor +++ b/basis/io/files/windows/nt/nt.factor @@ -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" + MAX_UNICODE_PATH dup [ 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 ) + normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA [ GetFileAttributesEx win32-error=0/f ] keep - [ WIN32_FILE_ATTRIBUTE_DATA-nFileSizeLow ] - [ WIN32_FILE_ATTRIBUTE_DATA-nFileSizeHigh ] bi >64bit ; + [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ; PRIVATE> diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 2182088efe..f4d6038954 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -660,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 From d2dd2066380f39de31cfd8de9053e63e270fed6b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 20:43:07 -0500 Subject: [PATCH 23/42] remove c-array usage --- basis/windows/errors/errors.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index 8bdbb9f1e9..ea9c297c44 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -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" ] keep + 32768 [ "TCHAR" ] [ ] bi f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip utf16n alien>string [ blank? ] trim ; From fb3fa1f7971e90ee4dafd230f08ba6e63f55277f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 20:52:14 -0500 Subject: [PATCH 24/42] remove dead code, use ${ and GUID:, structs --- basis/io/sockets/windows/nt/nt.factor | 4 ++-- basis/windows/shell32/shell32.factor | 4 ++-- basis/windows/winsock/winsock.factor | 29 +++++++++------------------ 3 files changed, 14 insertions(+), 23 deletions(-) diff --git a/basis/io/sockets/windows/nt/nt.factor b/basis/io/sockets/windows/nt/nt.factor index 6780fdcdd6..1bb5e0d102 100755 --- a/basis/io/sockets/windows/nt/nt.factor +++ b/basis/io/sockets/windows/nt/nt.factor @@ -3,7 +3,7 @@ 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 -classes.struct ; +classes.struct windows.kernel32 ; IN: io.sockets.windows.nt : malloc-int ( object -- object ) @@ -15,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*" [ "void*" heap-size diff --git a/basis/windows/shell32/shell32.factor b/basis/windows/shell32/shell32.factor index 016f5ab149..635c59a692 100644 --- a/basis/windows/shell32/shell32.factor +++ b/basis/windows/shell32/shell32.factor @@ -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 ; 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" + MAX_UNICODE_PATH [ SHGetFolderPath drop ] keep utf16n alien>string ; : desktop ( -- str ) diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index d19e4aca09..74f67a4924 100755 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -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 classes.struct ; +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 ) ; @@ -385,17 +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 ) - HEX: 25a207b9 - HEX: ddf3 - HEX: 4660 - B{ - HEX: 8e HEX: e9 HEX: 76 HEX: e5 - HEX: 8c HEX: 74 HEX: 06 HEX: 3e - } GUID ; +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 From e837a5cea8db17cdb6601466d1e858b62d051171 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 20:56:39 -0500 Subject: [PATCH 25/42] structs in windows.shell32 --- basis/windows/shell32/shell32.factor | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/basis/windows/shell32/shell32.factor b/basis/windows/shell32/shell32.factor index 635c59a692..15ddc1a5df 100644 --- a/basis/windows/shell32/shell32.factor +++ b/basis/windows/shell32/shell32.factor @@ -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 specialized-arrays.ushort ; +windows.ole32 windows specialized-arrays.ushort classes.struct ; IN: windows.shell32 CONSTANT: CSIDL_DESKTOP HEX: 00 @@ -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 ) From fb9d7d67d0c34cc4a3ffe60bbaf43579775adad0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 29 Aug 2009 23:25:17 -0500 Subject: [PATCH 26/42] use struct in windows serial code --- extra/io/serial/windows/windows.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/io/serial/windows/windows.factor b/extra/io/serial/windows/windows.factor index 2d27a489ef..551fd16b33 100755 --- a/extra/io/serial/windows/windows.factor +++ b/extra/io/serial/windows/windows.factor @@ -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 : ( path encoding -- duplex ) @@ -10,7 +11,7 @@ IN: io.serial.windows : get-comm-state ( duplex -- dcb ) in>> handle>> - "DCB" tuck + DCB tuck GetCommState win32-error=0/f ; : set-comm-state ( duplex dcb -- ) From bd629c12622303d543c0ab338d7e9e0d1c5e967b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Aug 2009 18:57:45 -0500 Subject: [PATCH 27/42] compiler/tests/codegen.factor: don't do exact float comparison --- basis/compiler/tests/codegen.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 5155d13e99..0fb2dca5b9 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -3,7 +3,7 @@ math hashtables.private math.private namespaces sequences tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io combinators vectors grouping make alien.c-types combinators.short-circuit -math.order math.libm ; +math.order math.libm math.parser ; QUALIFIED: namespaces.private IN: compiler.tests.codegen @@ -409,7 +409,7 @@ cell 4 = [ [ ] [ missing-gc-check-2 ] unit-test -[ 1 0.169967142900241 ] [ 1.4 [ 1 swap fcos ] compile-call ] unit-test -[ 1 0.169967142900241 ] [ 1.4 1 [ swap fcos ] compile-call ] unit-test -[ 0.169967142900241 0.9854497299884601 ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call ] unit-test -[ 1 0.169967142900241 0.9854497299884601 ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call ] unit-test \ No newline at end of file +[ 1 "0.169967142900241" ] [ 1.4 [ 1 swap fcos ] compile-call number>string ] unit-test +[ 1 "0.169967142900241" ] [ 1.4 1 [ swap fcos ] compile-call number>string ] unit-test +[ "0.169967142900241" "0.9854497299884601" ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test +[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test \ No newline at end of file From 8be06f0e5e1af9f5a8c51ff76d555ec843ec6c0a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 30 Aug 2009 19:05:49 -0500 Subject: [PATCH 28/42] typo in stat --- basis/unix/stat/freebsd/freebsd.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/stat/freebsd/freebsd.factor b/basis/unix/stat/freebsd/freebsd.factor index 02f31f3682..aeec5ef7a3 100644 --- a/basis/unix/stat/freebsd/freebsd.factor +++ b/basis/unix/stat/freebsd/freebsd.factor @@ -9,7 +9,7 @@ STRUCT: stat { st_mode mode_t } { st_nlink nlink_t } { st_uid uid_t } - { st_gid git_t } + { st_gid gid_t } { st_rdev __dev_t } { st_atimespec timespec } { st_mtimespec timespec } From de94e49f069c9f5f362278b6c1a64e6e0c077541 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 30 Aug 2009 20:10:41 -0500 Subject: [PATCH 29/42] escape the class name in io.files.info --- basis/io/files/info/unix/openbsd/openbsd.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/files/info/unix/openbsd/openbsd.factor b/basis/io/files/info/unix/openbsd/openbsd.factor index 7f23324fec..6c334b8d62 100644 --- a/basis/io/files/info/unix/openbsd/openbsd.factor +++ b/basis/io/files/info/unix/openbsd/openbsd.factor @@ -47,6 +47,6 @@ M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-in M: openbsd file-systems ( -- seq ) f 0 0 getfsstat dup io-error - statfs dup dup length 0 getfsstat io-error - statfs heap-size group + \ statfs dup dup length 0 getfsstat io-error + \ statfs heap-size group [ f_mntonname>> alien>native-string file-system-info ] map ; From 2dd3f5690dc408dc93d133d92d90afb7d3d4c337 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Aug 2009 20:13:54 -0500 Subject: [PATCH 30/42] classes.struct: make , malloc-struct, and clone work in deployed images where C type info has been stripped out --- basis/classes/struct/struct.factor | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 99150e9bb6..6954c0680b 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -46,9 +46,6 @@ M: struct equal? dup struct-class? [ '[ _ boa ] ] [ drop f ] if ] 1 define-partial-eval -M: struct clone - [ >c-ptr ] [ byte-length memory>byte-array ] [ class memory>struct ] tri ; - struct ; inline @@ -58,13 +55,13 @@ PRIVATE> [ heap-size malloc ] keep memory>struct ; inline : malloc-struct ( class -- struct ) - [ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ; + [ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ; inline : (struct) ( class -- struct ) [ heap-size (byte-array) ] keep memory>struct ; inline : ( class -- struct ) - [ >c-ptr clone ] [ heap-size ] (init-struct) ; + [ >c-ptr clone ] [ heap-size ] (init-struct) ; inline MACRO: ( class -- quot: ( ... -- struct ) ) [ @@ -119,13 +116,23 @@ M: struct-class writer-quot \ cleave [ ] 2sequence \ output>array [ ] 2sequence ; +: define-inline-method ( class generic quot -- ) + [ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ; + : (define-struct-slot-values-method) ( class -- ) - [ \ struct-slot-values create-method-in ] - [ struct-slot-values-quot ] bi define ; + [ \ struct-slot-values ] [ struct-slot-values-quot ] bi + define-inline-method ; : (define-byte-length-method) ( class -- ) - [ \ byte-length create-method-in ] - [ heap-size \ drop swap [ ] 2sequence ] bi define ; + [ \ byte-length ] [ heap-size \ drop swap [ ] 2sequence ] bi + define-inline-method ; + +: clone-underlying ( struct -- byte-array ) + [ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline + +: (define-clone-method) ( class -- ) + [ \ clone ] [ \ clone-underlying swap \ memory>struct [ ] 3sequence ] bi + define-inline-method ; : slot>field ( slot -- field ) field-spec new swap { @@ -207,7 +214,9 @@ M: struct-class heap-size : (struct-methods) ( class -- ) [ (define-struct-slot-values-method) ] - [ (define-byte-length-method) ] bi ; + [ (define-byte-length-method) ] + [ (define-clone-method) ] + tri ; : (struct-word-props) ( class slots size align -- ) [ From 6867f2a806bb204fba585461201b74d64c84bc7c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 30 Aug 2009 20:25:57 -0500 Subject: [PATCH 31/42] fix stat struct on freebsd --- basis/unix/stat/freebsd/freebsd.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/stat/freebsd/freebsd.factor b/basis/unix/stat/freebsd/freebsd.factor index aeec5ef7a3..40492faefd 100644 --- a/basis/unix/stat/freebsd/freebsd.factor +++ b/basis/unix/stat/freebsd/freebsd.factor @@ -18,7 +18,7 @@ STRUCT: stat { st_blocks blkcnt_t } { st_blksize blksize_t } { st_flags fflags_t } - { st_gen _uint32_t } + { st_gen __uint32_t } { st_lspare __int32_t } { st_birthtimespec timespec } { pad0 __int32_t[2] } From 05cc8babb6496595619642b1e9fa0bf11d30553f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 30 Aug 2009 20:26:25 -0500 Subject: [PATCH 32/42] update kqueue for structs --- .../unix/multiplexers/kqueue/kqueue.factor | 25 ++++++++++--------- basis/unix/kqueue/freebsd/freebsd.factor | 17 ++++++------- basis/unix/kqueue/macosx/macosx.factor | 17 ++++++------- basis/unix/kqueue/netbsd/netbsd.factor | 17 ++++++------- basis/unix/kqueue/openbsd/openbsd.factor | 17 ++++++------- 5 files changed, 45 insertions(+), 48 deletions(-) diff --git a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor index f7b15beb54..e01f33bbd8 100644 --- a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor +++ b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor @@ -2,28 +2,28 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types combinators destructors io.backend.unix kernel math.bitwise sequences struct-arrays unix -unix.kqueue unix.time assocs io.backend.unix.multiplexers ; +unix.kqueue unix.time assocs io.backend.unix.multiplexers +classes.struct ; IN: io.backend.unix.multiplexers.kqueue TUPLE: kqueue-mx < mx events ; -: max-events ( -- n ) - #! We read up to 256 events at a time. This is an arbitrary - #! constant... - 256 ; inline +! We read up to 256 events at a time. This is an arbitrary +! constant... +CONSTANT: max-events 256 : ( -- mx ) kqueue-mx new-mx kqueue dup io-error >>fd - max-events "kevent" >>events ; + max-events \ kevent >>events ; M: kqueue-mx dispose* fd>> close-file ; : make-kevent ( fd filter flags -- event ) - "kevent" - [ set-kevent-flags ] keep - [ set-kevent-filter ] keep - [ set-kevent-ident ] keep ; + \ kevent + swap >>flags + swap >>filter + swap >>ident ; : register-kevent ( kevent mx -- ) fd>> swap 1 f 0 f kevent io-error ; @@ -63,13 +63,14 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) ] dip kevent multiplexer-error ; : handle-kevent ( mx kevent -- ) - [ kevent-ident swap ] [ kevent-filter ] bi { + [ ident>> swap ] [ filter>> ] bi { { EVFILT_READ [ input-available ] } { EVFILT_WRITE [ output-available ] } } case ; : handle-kevents ( mx n -- ) - [ dup events>> ] dip head-slice [ handle-kevent ] with each ; + [ dup events>> ] dip head-slice + [ \ kevent memory>struct handle-kevent ] with each ; M: kqueue-mx wait-for-events ( us mx -- ) swap dup [ make-timespec ] when diff --git a/basis/unix/kqueue/freebsd/freebsd.factor b/basis/unix/kqueue/freebsd/freebsd.factor index 1153b997c2..4bf5af8482 100644 --- a/basis/unix/kqueue/freebsd/freebsd.factor +++ b/basis/unix/kqueue/freebsd/freebsd.factor @@ -1,14 +1,13 @@ -USING: alien.syntax ; +USING: alien.syntax classes.struct ; IN: unix.kqueue -C-STRUCT: kevent - { "ulong" "ident" } ! identifier for this event - { "short" "filter" } ! filter for event - { "ushort" "flags" } ! action flags for kqueue - { "uint" "fflags" } ! filter flag value - { "long" "data" } ! filter data value - { "void*" "udata" } ! opaque user data identifier -; +STRUCT: kevent + { ident ulong } + { filter short } + { flags ushort } + { fflags uint } + { data long } + { udata void* } ; FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ; diff --git a/basis/unix/kqueue/macosx/macosx.factor b/basis/unix/kqueue/macosx/macosx.factor index 843a0afad9..c30584efab 100644 --- a/basis/unix/kqueue/macosx/macosx.factor +++ b/basis/unix/kqueue/macosx/macosx.factor @@ -1,14 +1,13 @@ -USING: alien.syntax ; +USING: alien.syntax classes.struct ; IN: unix.kqueue -C-STRUCT: kevent - { "ulong" "ident" } ! identifier for this event - { "short" "filter" } ! filter for event - { "ushort" "flags" } ! action flags for kqueue - { "uint" "fflags" } ! filter flag value - { "long" "data" } ! filter data value - { "void*" "udata" } ! opaque user data identifier -; +STRUCT: kevent + { ident ulong } + { filter short } + { flags ushort } + { fflags uint } + { data long } + { udata void* } ; FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ; diff --git a/basis/unix/kqueue/netbsd/netbsd.factor b/basis/unix/kqueue/netbsd/netbsd.factor index 7ba942d712..d9a9116930 100644 --- a/basis/unix/kqueue/netbsd/netbsd.factor +++ b/basis/unix/kqueue/netbsd/netbsd.factor @@ -1,14 +1,13 @@ -USING: alien.syntax ; +USING: alien.syntax classes.struct ; IN: unix.kqueue -C-STRUCT: kevent - { "ulong" "ident" } ! identifier for this event - { "uint" "filter" } ! filter for event - { "uint" "flags" } ! action flags for kqueue - { "uint" "fflags" } ! filter flag value - { "longlong" "data" } ! filter data value - { "void*" "udata" } ! opaque user data identifier -; +STRUCT: kevent + { ident ulong } + { filter uint } + { flags uint } + { fflags uint } + { data longlong } + { udata void* } ; FUNCTION: int kevent ( int kq, kevent* changelist, size_t nchanges, kevent* eventlist, size_t nevents, timespec* timeout ) ; diff --git a/basis/unix/kqueue/openbsd/openbsd.factor b/basis/unix/kqueue/openbsd/openbsd.factor index c62ba05a4c..1d851c8d68 100644 --- a/basis/unix/kqueue/openbsd/openbsd.factor +++ b/basis/unix/kqueue/openbsd/openbsd.factor @@ -1,14 +1,13 @@ -USING: alien.syntax ; +USING: alien.syntax classes.struct ; IN: unix.kqueue -C-STRUCT: kevent - { "uint" "ident" } ! identifier for this event - { "short" "filter" } ! filter for event - { "ushort" "flags" } ! action flags for kqueue - { "uint" "fflags" } ! filter flag value - { "int" "data" } ! filter data value - { "void*" "udata" } ! opaque user data identifier -; +STRUCT: kevent + { ident uint } + { filter short } + { flags ushort } + { fflags uint } + { data int } + { udata void* } ; FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ; From 867d87998c54c70a34f39ba53dc0b94765f956d4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 30 Aug 2009 20:46:49 -0500 Subject: [PATCH 33/42] fix typo in stat struct --- basis/unix/stat/freebsd/freebsd.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/stat/freebsd/freebsd.factor b/basis/unix/stat/freebsd/freebsd.factor index 40492faefd..0acf2512e8 100644 --- a/basis/unix/stat/freebsd/freebsd.factor +++ b/basis/unix/stat/freebsd/freebsd.factor @@ -21,7 +21,7 @@ STRUCT: stat { st_gen __uint32_t } { st_lspare __int32_t } { st_birthtimespec timespec } - { pad0 __int32_t[2] } + { pad0 __int32_t[2] } ; FUNCTION: int stat ( char* pathname, stat* buf ) ; FUNCTION: int lstat ( char* pathname, stat* buf ) ; From e918e9cddcfc9af483fa92dfcc160d92e2f8b073 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Aug 2009 21:01:44 -0500 Subject: [PATCH 34/42] classes.struct: add more unit tests for clone method, and fix clone breakage when the struct class word is not a symbol --- basis/classes/struct/struct-tests.factor | 27 ++++++++++++++++++++++-- basis/classes/struct/struct.factor | 3 ++- 2 files changed, 27 insertions(+), 3 deletions(-) diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 0cd91da370..f015556bec 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -6,7 +6,7 @@ kernel libc literals math multiline namespaces prettyprint prettyprint.config see sequences specialized-arrays.ushort system tools.test compiler.tree.debugger struct-arrays classes.tuple.private specialized-arrays.direct.int -compiler.units ; +compiler.units byte-arrays specialized-arrays.char ; IN: classes.struct.tests << @@ -204,4 +204,27 @@ STRUCT: struct-test-optimization [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test -[ f ] [ struct-test-foo dup clone [ >c-ptr ] bi@ eq? ] unit-test +! Test cloning structs +STRUCT: clone-test-struct { x int } { y char[3] } ; + +[ 1 char-array{ 9 1 1 } ] [ + clone-test-struct + 1 >>x char-array{ 9 1 1 } >>y + clone + [ x>> ] [ y>> >char-array ] bi +] unit-test + +[ t 1 char-array{ 9 1 1 } ] [ + [ + clone-test-struct malloc-struct &free + 1 >>x char-array{ 9 1 1 } >>y + clone + [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri + ] with-destructors +] unit-test + +STRUCT: struct-that's-a-word { x int } ; + +: struct-that's-a-word ( -- ) "OOPS" throw ; + +[ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 6954c0680b..09c1d23c4e 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -131,7 +131,8 @@ M: struct-class writer-quot [ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline : (define-clone-method) ( class -- ) - [ \ clone ] [ \ clone-underlying swap \ memory>struct [ ] 3sequence ] bi + [ \ clone ] + [ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi define-inline-method ; : slot>field ( slot -- field ) From 348311ea9007f75eb5b647ed228434348c929c83 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Aug 2009 21:01:49 -0500 Subject: [PATCH 35/42] io.backend.unix: tweak test --- basis/io/backend/unix/unix-tests.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/io/backend/unix/unix-tests.factor b/basis/io/backend/unix/unix-tests.factor index ed054d7958..6eb4227855 100644 --- a/basis/io/backend/unix/unix-tests.factor +++ b/basis/io/backend/unix/unix-tests.factor @@ -74,8 +74,7 @@ yield [ datagram-client delete-file ] ignore-errors -datagram-client -"d" set +[ ] [ datagram-client "d" set ] unit-test [ ] [ "hello" >byte-array From d5a7dde7ee138507bc564c6f224e25b6ff26be8f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 30 Aug 2009 21:57:33 -0500 Subject: [PATCH 36/42] fix kqueue --- basis/io/backend/unix/multiplexers/kqueue/kqueue.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor index e01f33bbd8..ab3308916d 100644 --- a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor +++ b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor @@ -70,7 +70,7 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) : handle-kevents ( mx n -- ) [ dup events>> ] dip head-slice - [ \ kevent memory>struct handle-kevent ] with each ; + [ handle-kevent ] with each ; M: kqueue-mx wait-for-events ( us mx -- ) swap dup [ make-timespec ] when From 14973eacb5a1a4342b09cea7e34322f548212649 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 30 Aug 2009 22:11:42 -0500 Subject: [PATCH 37/42] update dirent for structs --- basis/io/directories/unix/unix.factor | 8 ++++---- basis/unix/bsd/freebsd/freebsd.factor | 14 +++++++------- basis/unix/bsd/macosx/macosx.factor | 14 +++++++------- basis/unix/bsd/netbsd/netbsd.factor | 18 +++++++++--------- basis/unix/bsd/openbsd/openbsd.factor | 14 +++++++------- basis/unix/linux/linux.factor | 14 +++++++------- 6 files changed, 41 insertions(+), 41 deletions(-) diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index a107a46275..06ba73bb46 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings combinators continuations destructors fry io io.backend io.backend.unix io.directories io.encodings.binary io.encodings.utf8 io.files io.pathnames io.files.types kernel math.bitwise sequences system -unix unix.stat vocabs.loader ; +unix unix.stat vocabs.loader classes.struct ; IN: io.directories.unix : touch-mode ( -- n ) @@ -37,7 +37,7 @@ M: unix copy-file ( from to -- ) HOOK: find-next-file os ( DIR* -- byte-array ) M: unix find-next-file ( DIR* -- byte-array ) - "dirent" + dirent f [ readdir_r 0 = [ (io-error) ] unless ] 2keep *void* [ drop f ] unless ; @@ -57,8 +57,8 @@ M: unix find-next-file ( DIR* -- byte-array ) M: unix >directory-entry ( byte-array -- directory-entry ) { - [ dirent-d_name underlying>> utf8 alien>string ] - [ dirent-d_type dirent-type>file-type ] + [ d_name>> underlying>> utf8 alien>string ] + [ d_type>> dirent-type>file-type ] } cleave directory-entry boa ; M: unix (directory-entries) ( path -- seq ) diff --git a/basis/unix/bsd/freebsd/freebsd.factor b/basis/unix/bsd/freebsd/freebsd.factor index 05642b5065..58af91271d 100644 --- a/basis/unix/bsd/freebsd/freebsd.factor +++ b/basis/unix/bsd/freebsd/freebsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax ; +USING: alien.syntax classes.struct ; IN: unix CONSTANT: FD_SETSIZE 1024 @@ -13,12 +13,12 @@ C-STRUCT: addrinfo { "void*" "addr" } { "addrinfo*" "next" } ; -C-STRUCT: dirent - { "u_int32_t" "d_fileno" } - { "u_int16_t" "d_reclen" } - { "u_int8_t" "d_type" } - { "u_int8_t" "d_namlen" } - { { "char" 256 } "d_name" } ; +STRUCT: dirent + { d_fileno u_int32_t } + { d_reclen u_int16_t } + { d_type u_int8_t } + { d_namlen u_int8_t } + { d_name char[256] } ; CONSTANT: EPERM 1 CONSTANT: ENOENT 2 diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index 32dd4d80d8..d4a57f47c2 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -1,4 +1,4 @@ -USING: alien.syntax unix.time ; +USING: alien.syntax unix.time classes.struct ; IN: unix CONSTANT: FD_SETSIZE 1024 @@ -32,12 +32,12 @@ CONSTANT: __DARWIN_MAXPATHLEN 1024 CONSTANT: __DARWIN_MAXNAMELEN 255 CONSTANT: __DARWIN_MAXNAMELEN+1 255 -C-STRUCT: dirent - { "ino_t" "d_ino" } - { "__uint16_t" "d_reclen" } - { "__uint8_t" "d_type" } - { "__uint8_t" "d_namlen" } - { { "char" __DARWIN_MAXNAMELEN+1 } "d_name" } ; +STRUCT: dirent + { d_ino ino_t } + { d_reclen __uint16_t } + { d_type __uint8_t } + { d_namlen __uint8_t } + { d_name { "char" __DARWIN_MAXNAMELEN+1 } } ; CONSTANT: EPERM 1 CONSTANT: ENOENT 2 diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/bsd/netbsd/netbsd.factor index f124e7f998..8cd4d4f484 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/bsd/netbsd/netbsd.factor @@ -1,4 +1,5 @@ -USING: alien.syntax alien.c-types math vocabs.loader ; +USING: alien.syntax alien.c-types math vocabs.loader +classes.struct ; IN: unix CONSTANT: FD_SETSIZE 256 @@ -13,12 +14,12 @@ C-STRUCT: addrinfo { "void*" "addr" } { "addrinfo*" "next" } ; -C-STRUCT: dirent - { "__uint32_t" "d_fileno" } - { "__uint16_t" "d_reclen" } - { "__uint8_t" "d_type" } - { "__uint8_t" "d_namlen" } - { { "char" 256 } "d_name" } ; +STRUCT: dirent + { d_fileno __uint32_t } + { d_reclen __uint16_t } + { d_type __uint8_t } + { d_namlen __uint8_t } + { d_name char[256] } ; CONSTANT: EPERM 1 CONSTANT: ENOENT 2 @@ -126,8 +127,7 @@ CONSTANT: _UTX_LINESIZE 32 CONSTANT: _UTX_IDSIZE 4 CONSTANT: _UTX_HOSTSIZE 256 -: _SS_MAXSIZE ( -- n ) - 128 ; inline +CONSTANT: _SS_MAXSIZE 128 : _SS_ALIGNSIZE ( -- n ) "__int64_t" heap-size ; inline diff --git a/basis/unix/bsd/openbsd/openbsd.factor b/basis/unix/bsd/openbsd/openbsd.factor index e915b6ffcd..c77b043723 100644 --- a/basis/unix/bsd/openbsd/openbsd.factor +++ b/basis/unix/bsd/openbsd/openbsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax ; +USING: alien.syntax classes.struct ; IN: unix CONSTANT: FD_SETSIZE 1024 @@ -13,12 +13,12 @@ C-STRUCT: addrinfo { "char*" "canonname" } { "addrinfo*" "next" } ; -C-STRUCT: dirent - { "__uint32_t" "d_fileno" } - { "__uint16_t" "d_reclen" } - { "__uint8_t" "d_type" } - { "__uint8_t" "d_namlen" } - { { "char" 256 } "d_name" } ; +STRUCT: dirent + { d_fileno __uint32_t } + { d_reclen __uint16_t } + { d_type __uint8_t } + { d_namlen __uint8_t } + { d_name char[256] } ; CONSTANT: EPERM 1 CONSTANT: ENOENT 2 diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor index 43a66f2dbe..31789baf1c 100644 --- a/basis/unix/linux/linux.factor +++ b/basis/unix/linux/linux.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax alien system ; +USING: alien.syntax alien system classes.struct ; IN: unix ! Linux. @@ -94,12 +94,12 @@ C-STRUCT: passwd { "char*" "pw_shell" } ; ! dirent64 -C-STRUCT: dirent - { "ulonglong" "d_ino" } - { "longlong" "d_off" } - { "ushort" "d_reclen" } - { "uchar" "d_type" } - { { "char" 256 } "d_name" } ; +STRUCT: dirent + { d_ino ulonglong } + { d_off longlong } + { d_reclen ushort } + { d_type uchar } + { d_name char[256] } ; FUNCTION: int open64 ( char* path, int flags, int prot ) ; FUNCTION: dirent64* readdir64 ( DIR* dirp ) ; From 868009aaeef0f3ab3c975413facbce842993b23c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Aug 2009 22:20:49 -0500 Subject: [PATCH 38/42] compiler.cfg.intrinsics: cleanup: the "intrinsic" word property is now a quotation, not a boolean, making this mechanism more extensible --- .../compiler/cfg/intrinsics/intrinsics.factor | 257 ++++++------------ 1 file changed, 88 insertions(+), 169 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 28d3243ba9..9766c658c9 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: words sequences kernel combinators cpu.architecture +USING: words sequences kernel combinators cpu.architecture assocs compiler.cfg.hats compiler.cfg.instructions compiler.cfg.intrinsics.alien @@ -25,201 +25,120 @@ QUALIFIED: math.floats.private QUALIFIED: math.libm IN: compiler.cfg.intrinsics -: enable-intrinsics ( words -- ) - [ t "intrinsic" set-word-prop ] each ; +: enable-intrinsics ( alist -- ) + [ "intrinsic" set-word-prop ] assoc-each ; { - kernel.private:tag - kernel.private:getenv - math.private:both-fixnums? - math.private:fixnum+ - math.private:fixnum- - math.private:fixnum* - math.private:fixnum+fast - math.private:fixnum-fast - math.private:fixnum-bitand - math.private:fixnum-bitor - math.private:fixnum-bitxor - math.private:fixnum-shift-fast - math.private:fixnum-bitnot - math.private:fixnum*fast - math.private:fixnum< - math.private:fixnum<= - math.private:fixnum>= - math.private:fixnum> - ! math.private:bignum>fixnum - ! math.private:fixnum>bignum - kernel:eq? - slots.private:slot - slots.private:set-slot - strings.private:string-nth - strings.private:set-string-nth-fast - classes.tuple.private: - arrays: - byte-arrays: - byte-arrays:(byte-array) - kernel: - alien: - alien.accessors:alien-unsigned-1 - alien.accessors:set-alien-unsigned-1 - alien.accessors:alien-signed-1 - alien.accessors:set-alien-signed-1 - alien.accessors:alien-unsigned-2 - alien.accessors:set-alien-unsigned-2 - alien.accessors:alien-signed-2 - alien.accessors:set-alien-signed-2 - alien.accessors:alien-cell - alien.accessors:set-alien-cell + { kernel.private:tag [ drop emit-tag ] } + { kernel.private:getenv [ emit-getenv ] } + { math.private:both-fixnums? [ drop emit-both-fixnums? ] } + { math.private:fixnum+ [ drop emit-fixnum+ ] } + { math.private:fixnum- [ drop emit-fixnum- ] } + { math.private:fixnum* [ drop emit-fixnum* ] } + { math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] } + { math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] } + { math.private:fixnum*fast [ drop emit-fixnum*fast ] } + { math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] } + { math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] } + { math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] } + { math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] } + { math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] } + { math.private:fixnum< [ drop cc< emit-fixnum-comparison ] } + { math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] } + { math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] } + { math.private:fixnum> [ drop cc> emit-fixnum-comparison ] } + { kernel:eq? [ drop cc= emit-fixnum-comparison ] } + { slots.private:slot [ emit-slot ] } + { slots.private:set-slot [ emit-set-slot ] } + { strings.private:string-nth [ drop emit-string-nth ] } + { strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] } + { classes.tuple.private: [ emit- ] } + { arrays: [ emit- ] } + { byte-arrays: [ emit- ] } + { byte-arrays:(byte-array) [ emit-(byte-array) ] } + { kernel: [ emit-simple-allot ] } + { alien: [ emit- ] } + { alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] } + { alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] } + { alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] } + { alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] } + { alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] } + { alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] } + { alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] } + { alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] } + { alien.accessors:alien-cell [ emit-alien-cell-getter ] } + { alien.accessors:set-alien-cell [ emit-alien-cell-setter ] } } enable-intrinsics : enable-alien-4-intrinsics ( -- ) { - alien.accessors:alien-unsigned-4 - alien.accessors:set-alien-unsigned-4 - alien.accessors:alien-signed-4 - alien.accessors:set-alien-signed-4 + { alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] } + { alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] } + { alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] } + { alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] } } enable-intrinsics ; : enable-float-intrinsics ( -- ) { - math.private:float+ - math.private:float- - math.private:float* - math.private:float/f - math.private:fixnum>float - math.private:float>fixnum - math.private:float< - math.private:float<= - math.private:float> - math.private:float>= - math.private:float= - alien.accessors:alien-float - alien.accessors:set-alien-float - alien.accessors:alien-double - alien.accessors:set-alien-double + { math.private:float+ [ drop [ ^^add-float ] emit-float-op ] } + { math.private:float- [ drop [ ^^sub-float ] emit-float-op ] } + { math.private:float* [ drop [ ^^mul-float ] emit-float-op ] } + { math.private:float/f [ drop [ ^^div-float ] emit-float-op ] } + { math.private:float< [ drop cc< emit-float-comparison ] } + { math.private:float<= [ drop cc<= emit-float-comparison ] } + { math.private:float>= [ drop cc>= emit-float-comparison ] } + { math.private:float> [ drop cc> emit-float-comparison ] } + { math.private:float= [ drop cc= emit-float-comparison ] } + { math.private:float>fixnum [ drop emit-float>fixnum ] } + { math.private:fixnum>float [ drop emit-fixnum>float ] } + { alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] } + { alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] } + { alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] } + { alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] } } enable-intrinsics ; : enable-fsqrt ( -- ) - \ math.libm:fsqrt t "intrinsic" set-word-prop ; + { + { math.libm:fsqrt [ drop emit-fsqrt ] } + } enable-intrinsics ; : enable-float-min/max ( -- ) { - math.floats.private:float-min - math.floats.private:float-max + { math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] } + { math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] } } enable-intrinsics ; : enable-float-functions ( -- ) ! Everything except for fsqrt { - math.libm:facos - math.libm:fasin - math.libm:fatan - math.libm:fatan2 - math.libm:fcos - math.libm:fsin - math.libm:ftan - math.libm:fcosh - math.libm:fsinh - math.libm:ftanh - math.libm:fexp - math.libm:flog - math.libm:fpow - math.libm:facosh - math.libm:fasinh - math.libm:fatanh + { math.libm:facos [ drop "acos" emit-unary-float-function ] } + { math.libm:fasin [ drop "asin" emit-unary-float-function ] } + { math.libm:fatan [ drop "atan" emit-unary-float-function ] } + { math.libm:fatan2 [ drop "atan2" emit-binary-float-function ] } + { math.libm:fcos [ drop "cos" emit-unary-float-function ] } + { math.libm:fsin [ drop "sin" emit-unary-float-function ] } + { math.libm:ftan [ drop "tan" emit-unary-float-function ] } + { math.libm:fcosh [ drop "cosh" emit-unary-float-function ] } + { math.libm:fsinh [ drop "sinh" emit-unary-float-function ] } + { math.libm:ftanh [ drop "tanh" emit-unary-float-function ] } + { math.libm:fexp [ drop "exp" emit-unary-float-function ] } + { math.libm:flog [ drop "log" emit-unary-float-function ] } + { math.libm:fpow [ drop "pow" emit-binary-float-function ] } + { math.libm:facosh [ drop "acosh" emit-unary-float-function ] } + { math.libm:fasinh [ drop "asinh" emit-unary-float-function ] } + { math.libm:fatanh [ drop "atanh" emit-unary-float-function ] } } enable-intrinsics ; : enable-min/max ( -- ) { - math.integers.private:fixnum-min - math.integers.private:fixnum-max + { math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] } + { math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] } } enable-intrinsics ; : enable-fixnum-log2 ( -- ) - { math.integers.private:fixnum-log2 } enable-intrinsics ; + { + { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] } + } enable-intrinsics ; : emit-intrinsic ( node word -- ) - { - { \ kernel.private:tag [ drop emit-tag ] } - { \ kernel.private:getenv [ emit-getenv ] } - { \ math.private:both-fixnums? [ drop emit-both-fixnums? ] } - { \ math.private:fixnum+ [ drop emit-fixnum+ ] } - { \ math.private:fixnum- [ drop emit-fixnum- ] } - { \ math.private:fixnum* [ drop emit-fixnum* ] } - { \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] } - { \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] } - { \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] } - { \ math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] } - { \ math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] } - { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] } - { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] } - { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] } - { \ math.private:fixnum*fast [ drop emit-fixnum*fast ] } - { \ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] } - { \ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] } - { \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] } - { \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] } - { \ kernel:eq? [ drop cc= emit-fixnum-comparison ] } - { \ math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] } - { \ math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] } - { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] } - { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] } - { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] } - { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] } - { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] } - { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] } - { \ math.private:float< [ drop cc< emit-float-comparison ] } - { \ math.private:float<= [ drop cc<= emit-float-comparison ] } - { \ math.private:float>= [ drop cc>= emit-float-comparison ] } - { \ math.private:float> [ drop cc> emit-float-comparison ] } - { \ math.private:float= [ drop cc= emit-float-comparison ] } - { \ math.private:float>fixnum [ drop emit-float>fixnum ] } - { \ math.private:fixnum>float [ drop emit-fixnum>float ] } - { \ math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] } - { \ math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] } - { \ math.libm:fsqrt [ drop emit-fsqrt ] } - { \ math.libm:facos [ drop "acos" emit-unary-float-function ] } - { \ math.libm:fasin [ drop "asin" emit-unary-float-function ] } - { \ math.libm:fatan [ drop "atan" emit-unary-float-function ] } - { \ math.libm:fatan2 [ drop "atan2" emit-binary-float-function ] } - { \ math.libm:fcos [ drop "cos" emit-unary-float-function ] } - { \ math.libm:fsin [ drop "sin" emit-unary-float-function ] } - { \ math.libm:ftan [ drop "tan" emit-unary-float-function ] } - { \ math.libm:fcosh [ drop "cosh" emit-unary-float-function ] } - { \ math.libm:fsinh [ drop "sinh" emit-unary-float-function ] } - { \ math.libm:ftanh [ drop "tanh" emit-unary-float-function ] } - { \ math.libm:fexp [ drop "exp" emit-unary-float-function ] } - { \ math.libm:flog [ drop "log" emit-unary-float-function ] } - { \ math.libm:fpow [ drop "pow" emit-binary-float-function ] } - { \ math.libm:facosh [ drop "acosh" emit-unary-float-function ] } - { \ math.libm:fasinh [ drop "asinh" emit-unary-float-function ] } - { \ math.libm:fatanh [ drop "atanh" emit-unary-float-function ] } - { \ slots.private:slot [ emit-slot ] } - { \ slots.private:set-slot [ emit-set-slot ] } - { \ strings.private:string-nth [ drop emit-string-nth ] } - { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] } - { \ classes.tuple.private: [ emit- ] } - { \ arrays: [ emit- ] } - { \ byte-arrays: [ emit- ] } - { \ byte-arrays:(byte-array) [ emit-(byte-array) ] } - { \ kernel: [ emit-simple-allot ] } - { \ alien: [ emit- ] } - { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] } - { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] } - { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] } - { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] } - { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] } - { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] } - { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] } - { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] } - { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] } - { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] } - { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] } - { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] } - { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] } - { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] } - { \ alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] } - { \ alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] } - { \ alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] } - { \ alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] } - } case ; + "intrinsic" word-prop call( node -- ) ; From 1f40ea64f0286582cbe3644e6f02f08dfebbd20d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Aug 2009 22:21:14 -0500 Subject: [PATCH 39/42] io.sockets.unix: cleanup two usages of 'rot' and use struct setter instead of memcpy --- basis/io/sockets/unix/unix.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index ec8b4206e3..9803ec8e69 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -61,8 +61,8 @@ M: object ((client)) ( addrspec -- fd ) : server-socket-fd ( addrspec type -- fd ) [ dup protocol-family ] dip socket-fd - dup init-server-socket - dup handle-fd rot make-sockaddr/size bind io-error ; + [ init-server-socket ] keep + [ handle-fd swap make-sockaddr/size bind io-error ] keep ; M: object (server) ( addrspec -- handle ) [ @@ -148,7 +148,7 @@ M: local make-sockaddr dup length 1 + max-un-path > [ "Path too long" throw ] when "sockaddr-un" AF_UNIX over set-sockaddr-un-family - dup sockaddr-un-path rot utf8 string>alien dup length memcpy ; + [ [ utf8 string>alien ] dip set-sockaddr-un-path ] keep ; M: local parse-sockaddr drop From d8be0561fba812e6296ad7d0eb2e17bd7f25cf12 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 30 Aug 2009 22:49:35 -0500 Subject: [PATCH 40/42] make a struct for dirents on linux, not a --- basis/io/directories/unix/linux/linux.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/io/directories/unix/linux/linux.factor b/basis/io/directories/unix/linux/linux.factor index ba5b27dacd..3af4c09f28 100644 --- a/basis/io/directories/unix/linux/linux.factor +++ b/basis/io/directories/unix/linux/linux.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types io.directories.unix kernel system unix ; +USING: alien.c-types io.directories.unix kernel system unix +classes.struct ; IN: io.directories.unix.linux -M: unix find-next-file ( DIR* -- byte-array ) - "dirent" +M: unix find-next-file ( DIR* -- dirent ) + dirent f [ readdir64_r 0 = [ (io-error) ] unless ] 2keep *void* [ drop f ] unless ; From e36029b376795f28dd4c4365122fba0fcdcd5b73 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Aug 2009 22:55:19 -0500 Subject: [PATCH 41/42] x11 and ui.backend.x11: update to use new structs --- basis/ui/backend/x11/x11.factor | 82 +- basis/x11/clipboard/clipboard.factor | 47 +- basis/x11/events/events.factor | 56 +- basis/x11/windows/windows.factor | 26 +- basis/x11/xlib/xlib.factor | 1082 +++++++++++++------------- 5 files changed, 629 insertions(+), 664 deletions(-) diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index aca80cbc96..fcaf0e2a70 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -1,14 +1,13 @@ ! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets -ui.gadgets.private ui.gestures ui.backend ui.clipboards -ui.gadgets.worlds ui.render ui.event-loop assocs kernel math -namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim -x11.glx x11.clipboard x11.constants x11.windows x11.io -io.encodings.string io.encodings.ascii io.encodings.utf8 combinators -command-line math.vectors classes.tuple opengl.gl threads -math.rectangles environment ascii literals -ui.pixel-formats ui.pixel-formats.private ; +USING: accessors alien.c-types arrays ascii assocs +classes.struct combinators io.encodings.ascii +io.encodings.string io.encodings.utf8 kernel literals math +namespaces sequences strings ui ui.backend ui.clipboards +ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds +ui.gestures ui.pixel-formats ui.pixel-formats.private +ui.private x11 x11.clipboard x11.constants x11.events x11.glx +x11.io x11.windows x11.xim x11.xlib environment command-line ; IN: ui.backend.x11 SINGLETON: x11-ui-backend @@ -25,8 +24,7 @@ C: x11-pixmap-handle M: world expose-event nip relayout ; M: world configure-event - over configured-loc >>window-loc - swap configured-dim >>dim + swap [ event-loc >>window-loc ] [ event-dim >>dim ] bi ! In case dimensions didn't change relayout-1 ; @@ -103,7 +101,7 @@ CONSTANT: key-codes dup key-codes at [ t ] [ 1string f ] ?if ; : event-modifiers ( event -- seq ) - XKeyEvent-state modifiers modifier ; + state>> modifiers modifier ; : valid-input? ( string gesture -- ? ) over empty? [ 2drop f ] [ @@ -132,10 +130,7 @@ M: world key-up-event [ key-up-event>gesture ] dip propagate-key-gesture ; : mouse-event>gesture ( event -- modifiers button loc ) - [ event-modifiers ] - [ XButtonEvent-button ] - [ mouse-event-loc ] - tri ; + [ event-modifiers ] [ button>> ] [ event-loc ] tri ; M: world button-down-event [ mouse-event>gesture [ ] dip ] dip @@ -146,7 +141,7 @@ M: world button-up-event send-button-up ; : mouse-event>scroll-direction ( event -- pair ) - XButtonEvent-button { + button>> { { 4 { 0 -1 } } { 5 { 0 1 } } { 6 { -1 0 } } @@ -154,7 +149,7 @@ M: world button-up-event } at ; M: world wheel-event - [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip + [ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip send-wheel ; M: world enter-event motion-event ; @@ -162,16 +157,13 @@ M: world enter-event motion-event ; M: world leave-event 2drop forget-rollover ; M: world motion-event - [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip - move-hand fire-motion ; + [ event-loc ] dip move-hand fire-motion ; M: world focus-in-event - nip - [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ; + nip [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ; M: world focus-out-event - nip - [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ; + nip [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ; M: world selection-notify-event [ handle>> window>> selection-from-event ] keep @@ -189,22 +181,18 @@ M: world selection-notify-event } case ; : encode-clipboard ( string type -- bytes ) - XSelectionRequestEvent-target - XA_UTF8_STRING = utf8 ascii ? encode ; + target>> XA_UTF8_STRING = utf8 ascii ? encode ; : set-selection-prop ( evt -- ) dpy get swap - [ XSelectionRequestEvent-requestor ] keep - [ XSelectionRequestEvent-property ] keep - [ XSelectionRequestEvent-target ] keep - [ 8 PropModeReplace ] dip - [ - XSelectionRequestEvent-selection - clipboard-for-atom contents>> - ] keep encode-clipboard dup length XChangeProperty drop ; + [ requestor>> ] keep + [ property>> ] keep + [ target>> 8 PropModeReplace ] keep + [ selection>> clipboard-for-atom contents>> ] keep + encode-clipboard dup length XChangeProperty drop ; M: world selection-request-event - drop dup XSelectionRequestEvent-target { + drop dup target>> { { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] } { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] } { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] } @@ -235,7 +223,7 @@ M: world client-event ] [ wait-for-display wait-event ] if ; M: x11-ui-backend do-events - wait-event dup XAnyEvent-window window dup + wait-event dup window>> window dup [ handle-event ] [ 2drop ] if ; : x-clipboard@ ( gadget clipboard -- prop win ) @@ -269,17 +257,13 @@ M: x11-ui-backend set-title ( string world -- ) [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ; M: x11-ui-backend (set-fullscreen) ( world ? -- ) - [ - handle>> window>> "XClientMessageEvent" - [ set-XClientMessageEvent-window ] keep - ] dip - _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? - over set-XClientMessageEvent-data0 - ClientMessage over set-XClientMessageEvent-type - dpy get over set-XClientMessageEvent-display - "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type - 32 over set-XClientMessageEvent-format - "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1 + XClientMessageEvent + swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0 + swap handle>> window>> >>window + dpy get >>display + "_NET_WM_STATE" x-atom >>message_type + 32 >>format + "_NET_WM_STATE_FULLSCREEN" x-atom >>data1 [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ; M: x11-ui-backend (open-window) ( world -- ) @@ -312,9 +296,9 @@ M: x11-pixmap-handle flush-gl-context ( handle -- ) drop ; M: x11-ui-backend (open-offscreen-buffer) ( world -- ) - dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ] - with-world-pixel-format + dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ] with-world-pixel-format >>handle drop ; + M: x11-ui-backend (close-offscreen-buffer) ( handle -- ) dpy get swap [ glx-pixmap>> glXDestroyGLXPixmap ] diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index 20bf66c704..5cf6453443 100644 --- a/basis/x11/clipboard/clipboard.factor +++ b/basis/x11/clipboard/clipboard.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings alien.syntax arrays -kernel math namespaces sequences io.encodings.string -io.encodings.utf8 io.encodings.ascii x11 x11.xlib x11.constants -specialized-arrays.int accessors ; +USING: accessors alien.c-types alien.strings classes.struct +io.encodings.utf8 kernel namespaces sequences +specialized-arrays.int x11 x11.constants x11.xlib ; IN: x11.clipboard ! This code was based on by McCLIM's Backends/CLX/port.lisp @@ -34,20 +33,15 @@ TUPLE: x-clipboard atom contents ; [ XGetWindowProperty drop ] keep snarf-property ; : selection-from-event ( event window -- string ) - swap XSelectionEvent-property zero? [ - drop f - ] [ - selection-property 1 window-property - ] if ; + swap property>> 0 = + [ drop f ] [ selection-property 1 window-property ] if ; : own-selection ( prop win -- ) [ dpy get ] 2dip CurrentTime XSetSelectionOwner drop flush-dpy ; : set-targets-prop ( evt -- ) - dpy get swap - [ XSelectionRequestEvent-requestor ] keep - XSelectionRequestEvent-property + [ dpy get ] dip [ requestor>> ] [ property>> ] bi "TARGETS" x-atom 32 PropModeReplace { "UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP" @@ -55,28 +49,27 @@ TUPLE: x-clipboard atom contents ; 4 XChangeProperty drop ; : set-timestamp-prop ( evt -- ) - dpy get swap - [ XSelectionRequestEvent-requestor ] keep - [ XSelectionRequestEvent-property ] keep - [ "TIMESTAMP" x-atom 32 PropModeReplace ] dip - XSelectionRequestEvent-time + [ dpy get ] dip + [ requestor>> ] + [ property>> "TIMESTAMP" x-atom 32 PropModeReplace ] + [ time>> ] tri 1 XChangeProperty drop ; : send-notify ( evt prop -- ) - "XSelectionEvent" - SelectionNotify over set-XSelectionEvent-type - [ set-XSelectionEvent-property ] keep - over XSelectionRequestEvent-display over set-XSelectionEvent-display - over XSelectionRequestEvent-requestor over set-XSelectionEvent-requestor - over XSelectionRequestEvent-selection over set-XSelectionEvent-selection - over XSelectionRequestEvent-target over set-XSelectionEvent-target - over XSelectionRequestEvent-time over set-XSelectionEvent-time - [ dpy get swap XSelectionRequestEvent-requestor 0 0 ] dip + XSelectionEvent + SelectionNotify >>type + swap >>property + over display>> >>display + over requestor>> >>requestor + over selection>> >>selection + over target>> >>target + over time>> >>time + [ [ dpy get ] dip requestor>> 0 0 ] dip XSendEvent drop flush-dpy ; : send-notify-success ( evt -- ) - dup XSelectionRequestEvent-property send-notify ; + dup property>> send-notify ; : send-notify-failure ( evt -- ) 0 send-notify ; diff --git a/basis/x11/events/events.factor b/basis/x11/events/events.factor index 5673dd7f76..a24f6a45aa 100644 --- a/basis/x11/events/events.factor +++ b/basis/x11/events/events.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays hashtables io kernel math -math.order namespaces prettyprint sequences strings combinators -x11 x11.xlib ; +USING: accessors arrays classes.struct combinators kernel +math.order namespaces x11 x11.xlib ; IN: x11.events GENERIC: expose-event ( event window -- ) @@ -36,14 +35,14 @@ GENERIC: selection-request-event ( event window -- ) GENERIC: client-event ( event window -- ) : next-event ( -- event ) - dpy get "XEvent" [ XNextEvent drop ] keep ; + dpy get XEvent [ XNextEvent drop ] keep ; : mask-event ( mask -- event ) - [ dpy get ] dip "XEvent" [ XMaskEvent drop ] keep ; + [ dpy get ] dip XEvent [ XMaskEvent drop ] keep ; : events-queued ( mode -- n ) [ dpy get ] dip XEventsQueued ; -: wheel? ( event -- ? ) XButtonEvent-button 4 7 between? ; +: wheel? ( event -- ? ) button>> 4 7 between? ; : button-down-event$ ( event window -- ) over wheel? [ wheel-event ] [ button-down-event ] if ; @@ -52,34 +51,31 @@ GENERIC: client-event ( event window -- ) over wheel? [ 2drop ] [ button-up-event ] if ; : handle-event ( event window -- ) - over XAnyEvent-type { - { Expose [ expose-event ] } - { ConfigureNotify [ configure-event ] } - { ButtonPress [ button-down-event$ ] } - { ButtonRelease [ button-up-event$ ] } - { EnterNotify [ enter-event ] } - { LeaveNotify [ leave-event ] } - { MotionNotify [ motion-event ] } - { KeyPress [ key-down-event ] } - { KeyRelease [ key-up-event ] } - { FocusIn [ focus-in-event ] } - { FocusOut [ focus-out-event ] } - { SelectionNotify [ selection-notify-event ] } - { SelectionRequest [ selection-request-event ] } - { ClientMessage [ client-event ] } + over type>> { + { Expose [ XExposeEvent>> expose-event ] } + { ConfigureNotify [ XConfigureEvent>> configure-event ] } + { ButtonPress [ XButtonEvent>> button-down-event$ ] } + { ButtonRelease [ XButtonEvent>> button-up-event$ ] } + { EnterNotify [ XCrossingEvent>> enter-event ] } + { LeaveNotify [ XCrossingEvent>> leave-event ] } + { MotionNotify [ XMotionEvent>> motion-event ] } + { KeyPress [ XKeyEvent>> key-down-event ] } + { KeyRelease [ XKeyEvent>> key-up-event ] } + { FocusIn [ XFocusChangeEvent>> focus-in-event ] } + { FocusOut [ XFocusChangeEvent>> focus-out-event ] } + { SelectionNotify [ XSelectionEvent>> selection-notify-event ] } + { SelectionRequest [ XSelectionRequestEvent>> selection-request-event ] } + { ClientMessage [ XClientMessageEvent>> client-event ] } [ 3drop ] } case ; -: configured-loc ( event -- dim ) - [ XConfigureEvent-x ] [ XConfigureEvent-y ] bi 2array ; +: event-loc ( event -- loc ) + [ x>> ] [ y>> ] bi 2array ; -: configured-dim ( event -- dim ) - [ XConfigureEvent-width ] [ XConfigureEvent-height ] bi 2array ; - -: mouse-event-loc ( event -- loc ) - [ XButtonEvent-x ] [ XButtonEvent-y ] bi 2array ; +: event-dim ( event -- dim ) + [ width>> ] [ height>> ] bi 2array ; : close-box? ( event -- ? ) - [ XClientMessageEvent-message_type "WM_PROTOCOLS" x-atom = ] - [ XClientMessageEvent-data0 "WM_DELETE_WINDOW" x-atom = ] + [ message_type>> "WM_PROTOCOLS" x-atom = ] + [ data0>> "WM_DELETE_WINDOW" x-atom = ] bi and ; diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 54cf205c14..ad0a8b11a6 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types hashtables kernel math math.vectors -math.bitwise namespaces sequences x11 x11.xlib x11.constants x11.glx -arrays fry ; +USING: accessors kernel math math.bitwise math.vectors +namespaces sequences x11 x11.xlib x11.constants x11.glx arrays +fry classes.struct ; IN: x11.windows : create-window-mask ( -- n ) { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ; : create-colormap ( visinfo -- colormap ) - [ dpy get root get ] dip XVisualInfo-visual AllocNone + [ dpy get root get ] dip visual>> AllocNone XCreateColormap ; : event-mask ( -- n ) @@ -28,15 +28,15 @@ IN: x11.windows } flags ; : window-attributes ( visinfo -- attributes ) - "XSetWindowAttributes" - 0 over set-XSetWindowAttributes-background_pixel - 0 over set-XSetWindowAttributes-border_pixel - [ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep - event-mask over set-XSetWindowAttributes-event_mask ; + XSetWindowAttributes + 0 >>background_pixel + 0 >>border_pixel + event-mask >>event_mask + swap create-colormap >>colormap ; : set-size-hints ( window -- ) - "XSizeHints" - USPosition over set-XSizeHints-flags + XSizeHints + USPosition >>flags [ dpy get ] 2dip XSetWMNormalHints ; : auto-position ( window loc -- ) @@ -47,8 +47,8 @@ IN: x11.windows : create-window ( loc dim visinfo -- window ) pick [ [ [ [ dpy get root get ] dip >xy ] dip { 1 1 } vmax >xy 0 ] dip - [ XVisualInfo-depth InputOutput ] keep - [ XVisualInfo-visual create-window-mask ] keep + [ depth>> InputOutput ] keep + [ visual>> create-window-mask ] keep window-attributes XCreateWindow dup ] dip auto-position ; diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index c8a4bfa0dc..48d556de1d 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -10,10 +10,9 @@ ! add to this library and are wondering what part of the file to ! modify, just find the function or data structure in the manual ! and note the section. - -USING: kernel arrays alien alien.c-types alien.strings -alien.syntax math math.bitwise words sequences namespaces -continuations io io.encodings.ascii x11.syntax ; +USING: accessors kernel arrays alien alien.c-types alien.strings +alien.syntax classes.struct math math.bitwise words sequences +namespaces continuations io io.encodings.ascii x11.syntax ; IN: x11.xlib LIBRARY: xlib @@ -66,10 +65,10 @@ ALIAS: *Atom *ulong ! ! This struct is incomplete -C-STRUCT: Display -{ "void*" "ext_data" } -{ "void*" "free_funcs" } -{ "int" "fd" } ; +STRUCT: Display +{ ext_data void* } +{ free_funcs void* } +{ fd int } ; X-FUNCTION: Display* XOpenDisplay ( void* display_name ) ; @@ -114,22 +113,22 @@ X-FUNCTION: int XCloseDisplay ( Display* display ) ; : CWColormap ( -- n ) 13 2^ ; inline : CWCursor ( -- n ) 14 2^ ; inline -C-STRUCT: XSetWindowAttributes - { "Pixmap" "background_pixmap" } - { "ulong" "background_pixel" } - { "Pixmap" "border_pixmap" } - { "ulong" "border_pixel" } - { "int" "bit_gravity" } - { "int" "win_gravity" } - { "int" "backing_store" } - { "ulong" "backing_planes" } - { "ulong" "backing_pixel" } - { "Bool" "save_under" } - { "long" "event_mask" } - { "long" "do_not_propagate_mask" } - { "Bool" "override_redirect" } - { "Colormap" "colormap" } - { "Cursor" "cursor" } ; +STRUCT: XSetWindowAttributes +{ background_pixmap Pixmap } +{ background_pixel ulong } +{ border_pixmap Pixmap } +{ border_pixel ulong } +{ bit_gravity int } +{ win_gravity int } +{ backing_store int } +{ backing_planes ulong } +{ backing_pixel ulong } +{ save_under Bool } +{ event_mask long } +{ do_not_propagate_mask long } +{ override_redirect Bool } +{ colormap Colormap } +{ cursor Cursor } ; CONSTANT: UnmapGravity 0 @@ -169,14 +168,14 @@ X-FUNCTION: int XMapRaised ( Display* display, Window w ) ; : CWSibling ( -- n ) 5 2^ ; inline : CWStackMode ( -- n ) 6 2^ ; inline -C-STRUCT: XWindowChanges - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } - { "int" "border_width" } - { "Window" "sibling" } - { "int" "stack_mode" } ; +STRUCT: XWindowChanges +{ x int } +{ y int } +{ width int } +{ height int } +{ border_width int } +{ sibling Window } +{ stack_mode int } ; X-FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ; X-FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ; @@ -211,30 +210,30 @@ X-FUNCTION: Status XQueryTree ( Window* parent_return, Window** children_return, uint* nchildren_return ) ; -C-STRUCT: XWindowAttributes - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" " height" } - { "int" "border_width" } - { "int" "depth" } - { "Visual*" "visual" } - { "Window" "root" } - { "int" "class" } - { "int" "bit_gravity" } - { "int" "win_gravity" } - { "int" "backing_store" } - { "ulong" "backing_planes" } - { "ulong" "backing_pixel" } - { "Bool" "save_under" } - { "Colormap" "colormap" } - { "Bool" "map_installed" } - { "int" "map_state" } - { "long" "all_event_masks" } - { "long" "your_event_mask" } - { "long" "do_not_propagate_mask" } - { "Bool" "override_redirect" } - { "Screen*" "screen" } ; +STRUCT: XWindowAttributes +{ x int } +{ y int } +{ width int } +{ height int } +{ border_width int } +{ depth int } +{ visual Visual* } +{ root Window } +{ class int } +{ bit_gravity int } +{ win_gravity int } +{ backing_store int } +{ backing_planes ulong } +{ backing_pixel ulong } +{ save_under Bool } +{ colormap Colormap } +{ map_installed Bool } +{ map_state int } +{ all_event_masks long } +{ your_event_mask long } +{ do_not_propagate_mask long } +{ override_redirect Bool } +{ screen Screen* } ; X-FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ; @@ -292,13 +291,13 @@ X-FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ; ! 6 - Color Management Functions ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XColor - { "ulong" "pixel" } - { "ushort" "red" } - { "ushort" "green" } - { "ushort" "blue" } - { "char" "flags" } - { "char" "pad" } ; +STRUCT: XColor +{ pixel ulong } +{ red ushort } +{ green ushort } +{ blue ushort } +{ flags char } +{ pad char } ; X-FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ; X-FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ; @@ -353,30 +352,30 @@ CONSTANT: GXorInverted HEX: d CONSTANT: GXnand HEX: e CONSTANT: GXset HEX: f -C-STRUCT: XGCValues - { "int" "function" } - { "ulong" "plane_mask" } - { "ulong" "foreground" } - { "ulong" "background" } - { "int" "line_width" } - { "int" "line_style" } - { "int" "cap_style" } - { "int" "join_style" } - { "int" "fill_style" } - { "int" "fill_rule" } - { "int" "arc_mode" } - { "Pixmap" "tile" } - { "Pixmap" "stipple" } - { "int" "ts_x_origin" } - { "int" "ts_y_origin" } - { "Font" "font" } - { "int" "subwindow_mode" } - { "Bool" "graphics_exposures" } - { "int" "clip_x_origin" } - { "int" "clip_y_origin" } - { "Pixmap" "clip_mask" } - { "int" "dash_offset" } - { "char" "dashes" } ; +STRUCT: XGCValues +{ function int } +{ plane_mask ulong } +{ foreground ulong } +{ background ulong } +{ line_width int } +{ line_style int } +{ cap_style int } +{ join_style int } +{ fill_style int } +{ fill_rule int } +{ arc_mode int } +{ tile Pixmap } +{ stipple Pixmap } +{ ts_x_origin int } +{ ts_y_origin int } +{ font Font } +{ subwindow_mode int } +{ graphics_exposures Bool } +{ clip_x_origin int } +{ clip_y_origin int } +{ clip_mask Pixmap } +{ dash_offset int } +{ dashes char } ; X-FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ; X-FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ; @@ -402,35 +401,35 @@ X-FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, ! 8.5 - Font Metrics -C-STRUCT: XCharStruct - { "short" "lbearing" } - { "short" "rbearing" } - { "short" "width" } - { "short" "ascent" } - { "short" "descent" } - { "ushort" "attributes" } ; +STRUCT: XCharStruct +{ lbearing short } +{ rbearing short } +{ width short } +{ ascent short } +{ descent short } +{ attributes ushort } ; X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ; X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ; X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ; -C-STRUCT: XFontStruct - { "XExtData*" "ext_data" } - { "Font" "fid" } - { "uint" "direction" } - { "uint" "min_char_or_byte2" } - { "uint" "max_char_or_byte2" } - { "uint" "min_byte1" } - { "uint" "max_byte1" } - { "Bool" "all_chars_exist" } - { "uint" "default_char" } - { "int" "n_properties" } - { "XFontProp*" "properties" } - { "XCharStruct" "min_bounds" } - { "XCharStruct" "max_bounds" } - { "XCharStruct*" "per_char" } - { "int" "ascent" } - { "int" "descent" } ; +STRUCT: XFontStruct +{ ext_data XExtData* } +{ fid Font } +{ direction uint } +{ min_char_or_byte2 uint } +{ max_char_or_byte2 uint } +{ min_byte1 uint } +{ max_byte1 uint } +{ all_chars_exist Bool } +{ default_char uint } +{ n_properties int } +{ properties XFontProp* } +{ min_bounds XCharStruct } +{ max_bounds XCharStruct } +{ per_char XCharStruct* } +{ ascent int } +{ descent int } ; X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ; @@ -449,41 +448,41 @@ X-FUNCTION: Status XDrawString ( CONSTANT: AllPlanes -1 -C-STRUCT: XImage-funcs - { "void*" "create_image" } - { "void*" "destroy_image" } - { "void*" "get_pixel" } - { "void*" "put_pixel" } - { "void*" "sub_image" } - { "void*" "add_pixel" } ; +STRUCT: XImage-funcs +{ create_image void* } +{ destroy_image void* } +{ get_pixel void* } +{ put_pixel void* } +{ sub_image void* } +{ add_pixel void* } ; -C-STRUCT: XImage - { "int" "width" } - { "int" "height" } - { "int" "xoffset" } - { "int" "format" } - { "char*" "data" } - { "int" "byte_order" } - { "int" "bitmap_unit" } - { "int" "bitmap_bit_order" } - { "int" "bitmap_pad" } - { "int" "depth" } - { "int" "bytes_per_line" } - { "int" "bits_per_pixel" } - { "ulong" "red_mask" } - { "ulong" "green_mask" } - { "ulong" "blue_mask" } - { "XPointer" "obdata" } - { "XImage-funcs" "f" } ; +STRUCT: XImage +{ width int } +{ height int } +{ xoffset int } +{ format int } +{ data char* } +{ byte_order int } +{ bitmap_unit int } +{ bitmap_bit_order int } +{ bitmap_pad int } +{ depth int } +{ bytes_per_line int } +{ bits_per_pixel int } +{ red_mask ulong } +{ green_mask ulong } +{ blue_mask ulong } +{ obdata XPointer } +{ f XImage-funcs } ; X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ; X-FUNCTION: int XDestroyImage ( XImage* ximage ) ; : XImage-size ( ximage -- size ) - [ XImage-height ] [ XImage-bytes_per_line ] bi * ; + [ height>> ] [ bytes_per_line>> ] bi * ; : XImage-pixels ( ximage -- byte-array ) - [ XImage-data ] [ XImage-size ] bi memory>byte-array ; + [ data>> ] [ XImage-size ] bi memory>byte-array ; ! ! 9 - Window and Session Manager Functions @@ -536,11 +535,11 @@ CONSTANT: ButtonRelease 5 CONSTANT: MotionNotify 6 CONSTANT: EnterNotify 7 CONSTANT: LeaveNotify 8 -CONSTANT: FocusIn 9 +CONSTANT: FocusIn 9 CONSTANT: FocusOut 10 CONSTANT: KeymapNotify 11 -CONSTANT: Expose 12 -CONSTANT: GraphicsExpose 13 +CONSTANT: Expose 12 +CONSTANT: GraphicsExpose 13 CONSTANT: NoExpose 14 CONSTANT: VisibilityNotify 15 CONSTANT: CreateNotify 16 @@ -548,28 +547,28 @@ CONSTANT: DestroyNotify 17 CONSTANT: UnmapNotify 18 CONSTANT: MapNotify 19 CONSTANT: MapRequest 20 -CONSTANT: ReparentNotify 21 -CONSTANT: ConfigureNotify 22 +CONSTANT: ReparentNotify 21 +CONSTANT: ConfigureNotify 22 CONSTANT: ConfigureRequest 23 CONSTANT: GravityNotify 24 CONSTANT: ResizeRequest 25 -CONSTANT: CirculateNotify 26 +CONSTANT: CirculateNotify 26 CONSTANT: CirculateRequest 27 -CONSTANT: PropertyNotify 28 -CONSTANT: SelectionClear 29 +CONSTANT: PropertyNotify 28 +CONSTANT: SelectionClear 29 CONSTANT: SelectionRequest 30 -CONSTANT: SelectionNotify 31 -CONSTANT: ColormapNotify 32 +CONSTANT: SelectionNotify 31 +CONSTANT: ColormapNotify 32 CONSTANT: ClientMessage 33 CONSTANT: MappingNotify 34 CONSTANT: LASTEvent 35 -C-STRUCT: XAnyEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } ; +STRUCT: XAnyEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -596,22 +595,22 @@ CONSTANT: Button5 5 : Mod4Mask ( -- n ) 1 6 shift ; inline : Mod5Mask ( -- n ) 1 7 shift ; inline -C-STRUCT: XButtonEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Window" "root" } - { "Window" "subwindow" } - { "Time" "time" } - { "int" "x" } - { "int" "y" } - { "int" "x_root" } - { "int" "y_root" } - { "uint" "state" } - { "uint" "button" } - { "Bool" "same_screen" } ; +STRUCT: XButtonEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ root Window } +{ subwindow Window } +{ time Time } +{ x int } +{ y int } +{ x_root int } +{ y_root int } +{ state uint } +{ button uint } +{ same_screen Bool } ; TYPEDEF: XButtonEvent XButtonPressedEvent TYPEDEF: XButtonEvent XButtonReleasedEvent @@ -619,445 +618,438 @@ TYPEDEF: XButtonEvent XButtonReleasedEvent ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XKeyEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Window" "root" } - { "Window" "subwindow" } - { "Time" "time" } - { "int" "x" } - { "int" "y" } - { "int" "x_root" } - { "int" "y_root" } - { "uint" "state" } - { "uint" "keycode" } - { "Bool" "same_screen" } ; +STRUCT: XKeyEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ root Window } +{ subwindow Window } +{ time Time } +{ x int } +{ y int } +{ x_root int } +{ y_root int } +{ state uint } +{ keycode uint } +{ same_screen Bool } ; TYPEDEF: XKeyEvent XKeyPressedEvent TYPEDEF: XKeyEvent XKeyReleasedEvent ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XMotionEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Window" "root" } - { "Window" "subwindow" } - { "Time" "time" } - { "int" "x" } - { "int" "y" } - { "int" "x_root" } - { "int" "y_root" } - { "uint" "state" } - { "char" "is_hint" } - { "Bool" "same_screen" } ; +STRUCT: XMotionEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ root Window } +{ subwindow Window } +{ time Time } +{ x int } +{ y int } +{ x_root int } +{ y_root int } +{ state uint } +{ is_hint char } +{ same_screen Bool } ; TYPEDEF: XMotionEvent XPointerMovedEvent ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XCrossingEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Window" "root" } - { "Window" "subwindow" } - { "Time" "time" } - { "int" "x" } - { "int" "y" } - { "int" "x_root" } - { "int" "y_root" } - { "int" "mode" } - { "int" "detail" } - { "Bool" "same_screen" } - { "Bool" "focus" } - { "uint" "state" } ; +STRUCT: XCrossingEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ root Window } +{ subwindow Window } +{ time Time } +{ x int } +{ y int } +{ x_root int } +{ y_root int } +{ mode int } +{ detail int } +{ same_screen Bool } +{ focus Bool } +{ state uint } ; TYPEDEF: XCrossingEvent XEnterWindowEvent TYPEDEF: XCrossingEvent XLeaveWindowEvent ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XFocusChangeEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "int" "mode" } - { "int" "detail" } ; +STRUCT: XFocusChangeEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ mode int } +{ detail int } ; TYPEDEF: XFocusChangeEvent XFocusInEvent TYPEDEF: XFocusChangeEvent XFocusOutEvent ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XExposeEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } - { "int" "count" } ; +STRUCT: XExposeEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ x int } +{ y int } +{ width int } +{ height int } +{ count int } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XGraphicsExposeEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Drawable" "drawable" } - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } - { "int" "count" } - { "int" "major_code" } - { "int" "minor_code" } ; +STRUCT: XGraphicsExposeEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ drawable Drawable } +{ x int } +{ y int } +{ width int } +{ height int } +{ count int } +{ major_code int } +{ minor_code int } ; -C-STRUCT: XNoExposeEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Drawable" "drawable" } - { "int" "major_code" } - { "int" "minor_code" } ; +STRUCT: XNoExposeEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ drawable Drawable } +{ major_code int } +{ minor_code int } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XVisibilityEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "int" "state" } ; +STRUCT: XVisibilityEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ state int } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XCreateWindowEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "parent" } - { "Window" "window" } - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } - { "int" "border_width" } - { "Bool" "override_redirect" } ; +STRUCT: XCreateWindowEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ parent Window } +{ window Window } +{ x int } +{ y int } +{ width int } +{ height int } +{ border_width int } +{ override_redirect Bool } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XDestroyWindowEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } ; +STRUCT: XDestroyWindowEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ event Window } +{ window Window } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XUnmapEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } - { "Bool" "from_configure" } ; +STRUCT: XUnmapEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ event Window } +{ window Window } +{ from_configure Bool } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XMapEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } - { "Bool" "override_redirect" } ; +STRUCT: XMapEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ event Window } +{ window Window } +{ override_redirect Bool } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XMapRequestEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "parent" } - { "Window" "window" } ; +STRUCT: XMapRequestEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ parent Window } +{ window Window } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XReparentEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } - { "Window" "parent" } - { "int" "x" } - { "int" "y" } - { "Bool" "override_redirect" } ; +STRUCT: XReparentEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ event Window } +{ window Window } +{ parent Window } +{ x int } +{ y int } +{ override_redirect Bool } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XConfigureEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } - { "int" "border_width" } - { "Window" "above" } - { "Bool" "override_redirect" } ; +STRUCT: XConfigureEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ event Window } +{ window Window } +{ x int } +{ y int } +{ width int } +{ height int } +{ border_width int } +{ above Window } +{ override_redirect Bool } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XGravityEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } - { "int" "x" } - { "int" "y" } ; +STRUCT: XGravityEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ event Window } +{ window Window } +{ x int } +{ y int } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XResizeRequestEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "int" "width" } - { "int" "height" } ; +STRUCT: XResizeRequestEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ width int } +{ height int } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XConfigureRequestEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "parent" } - { "Window" "window" } - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } - { "int" "border_width" } - { "Window" "above" } - { "int" "detail" } - { "ulong" "value_mask" } ; +STRUCT: XConfigureRequestEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ parent Window } +{ window Window } +{ x int } +{ y int } +{ width int } +{ height int } +{ border_width int } +{ above Window } +{ detail int } +{ value_mask ulong } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XCirculateEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } - { "int" "place" } ; +STRUCT: XCirculateEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ event Window } +{ window Window } +{ place int } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XCirculateRequestEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "parent" } - { "Window" "window" } - { "int" "place" } ; +STRUCT: XCirculateRequestEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ parent Window } +{ window Window } +{ place int } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XPropertyEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Atom" "atom" } - { "Time" "time" } - { "int" "state" } ; +STRUCT: XPropertyEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ atom Atom } +{ time Time } +{ state int } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XSelectionClearEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Atom" "selection" } - { "Time" "time" } ; +STRUCT: XSelectionClearEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ selection Atom } +{ time Time } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XSelectionRequestEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "owner" } - { "Window" "requestor" } - { "Atom" "selection" } - { "Atom" "target" } - { "Atom" "property" } - { "Time" "time" } ; +STRUCT: XSelectionRequestEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ owner Window } +{ requestor Window } +{ selection Atom } +{ target Atom } +{ property Atom } +{ time Time } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XSelectionEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "requestor" } - { "Atom" "selection" } - { "Atom" "target" } - { "Atom" "property" } - { "Time" "time" } ; +STRUCT: XSelectionEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ requestor Window } +{ selection Atom } +{ target Atom } +{ property Atom } +{ time Time } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XColormapEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Colormap" "colormap" } - { "Bool" "new" } - { "int" "state" } ; +STRUCT: XColormapEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ colormap Colormap } +{ new Bool } +{ state int } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XClientMessageEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Atom" "message_type" } - { "int" "format" } - { "long" "data0" } - { "long" "data1" } - { "long" "data2" } - { "long" "data3" } - { "long" "data4" } -! union { -! char b[20]; -! short s[10]; -! long l[5]; -! } data; -; +STRUCT: XClientMessageEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ message_type Atom } +{ format int } +{ data0 long } +{ data1 long } +{ data2 long } +{ data3 long } +{ data4 long } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XMappingEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "int" "request" } - { "int" "first_keycode" } - { "int" "count" } ; +STRUCT: XMappingEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ request int } +{ first_keycode int } +{ count int } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XErrorEvent - { "int" "type" } - { "Display*" "display" } - { "XID" "resourceid" } - { "ulong" "serial" } - { "uchar" "error_code" } - { "uchar" "request_code" } - { "uchar" "minor_code" } ; +STRUCT: XErrorEvent +{ type int } +{ display Display* } +{ resourceid XID } +{ serial ulong } +{ error_code uchar } +{ request_code uchar } +{ minor_code uchar } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -C-STRUCT: XKeymapEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - ! char key_vector[32]; - { "int" "pad" } - { "int" "pad" } - { "int" "pad" } - { "int" "pad" } - { "int" "pad" } - { "int" "pad" } - { "int" "pad" } - { "int" "pad" } ; +STRUCT: XKeymapEvent +{ type int } +{ serial ulong } +{ send_event Bool } +{ display Display* } +{ window Window } +{ pad int } +{ pad int } +{ pad int } +{ pad int } +{ pad int } +{ pad int } +{ pad int } +{ pad int } ; -C-UNION: XEvent - "int" - "XAnyEvent" - "XKeyEvent" - "XButtonEvent" - "XMotionEvent" - "XCrossingEvent" - "XFocusChangeEvent" - "XExposeEvent" - "XGraphicsExposeEvent" - "XNoExposeEvent" - "XVisibilityEvent" - "XCreateWindowEvent" - "XDestroyWindowEvent" - "XUnmapEvent" - "XMapEvent" - "XMapRequestEvent" - "XReparentEvent" - "XConfigureEvent" - "XGravityEvent" - "XResizeRequestEvent" - "XConfigureRequestEvent" - "XCirculateEvent" - "XCirculateRequestEvent" - "XPropertyEvent" - "XSelectionClearEvent" - "XSelectionRequestEvent" - "XSelectionEvent" - "XColormapEvent" - "XClientMessageEvent" - "XMappingEvent" - "XErrorEvent" - "XKeymapEvent" - { "long" 24 } ; +UNION-STRUCT: XEvent +{ int int } +{ XAnyEvent XAnyEvent } +{ XKeyEvent XKeyEvent } +{ XButtonEvent XButtonEvent } +{ XMotionEvent XMotionEvent } +{ XCrossingEvent XCrossingEvent } +{ XFocusChangeEvent XFocusChangeEvent } +{ XExposeEvent XExposeEvent } +{ XGraphicsExposeEvent XGraphicsExposeEvent } +{ XNoExposeEvent XNoExposeEvent } +{ XVisibilityEvent XVisibilityEvent } +{ XCreateWindowEvent XCreateWindowEvent } +{ XDestroyWindowEvent XDestroyWindowEvent } +{ XUnmapEvent XUnmapEvent } +{ XMapEvent XMapEvent } +{ XMapRequestEvent XMapRequestEvent } +{ XReparentEvent XReparentEvent } +{ XConfigureEvent XConfigureEvent } +{ XGravityEvent XGravityEvent } +{ XResizeRequestEvent XResizeRequestEvent } +{ XConfigureRequestEvent XConfigureRequestEvent } +{ XCirculateEvent XCirculateEvent } +{ XCirculateRequestEvent XCirculateRequestEvent } +{ XPropertyEvent XPropertyEvent } +{ XSelectionClearEvent XSelectionClearEvent } +{ XSelectionRequestEvent XSelectionRequestEvent } +{ XSelectionEvent XSelectionEvent } +{ XColormapEvent XColormapEvent } +{ XClientMessageEvent XClientMessageEvent } +{ XMappingEvent XMappingEvent } +{ XErrorEvent XErrorEvent } +{ XKeymapEvent XKeymapEvent } +{ padding long[24] } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 11 - Event Handling Functions @@ -1148,25 +1140,25 @@ X-FUNCTION: Status XWithdrawWindow ( : PAllHints ( -- n ) { PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable -C-STRUCT: XSizeHints - { "long" "flags" } - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } - { "int" "min_width" } - { "int" "min_height" } - { "int" "max_width" } - { "int" "max_height" } - { "int" "width_inc" } - { "int" "height_inc" } - { "int" "min_aspect_x" } - { "int" "min_aspect_y" } - { "int" "max_aspect_x" } - { "int" "max_aspect_y" } - { "int" "base_width" } - { "int" "base_height" } - { "int" "win_gravity" } ; +STRUCT: XSizeHints + { flags long } + { x int } + { y int } + { width int } + { height int } + { min_width int } + { min_height int } + { max_width int } + { max_height int } + { width_inc int } + { height_inc int } + { min_aspect_x int } + { min_aspect_y int } + { max_aspect_x int } + { max_aspect_y int } + { base_width int } + { base_height int } + { win_gravity int } ; ! 14.1.10. Setting and Reading the WM_PROTOCOLS Property @@ -1208,17 +1200,17 @@ CONSTANT: VisualColormapSizeMask HEX: 80 CONSTANT: VisualBitsPerRGBMask HEX: 100 CONSTANT: VisualAllMask HEX: 1FF -C-STRUCT: XVisualInfo - { "Visual*" "visual" } - { "VisualID" "visualid" } - { "int" "screen" } - { "uint" "depth" } - { "int" "class" } - { "ulong" "red_mask" } - { "ulong" "green_mask" } - { "ulong" "blue_mask" } - { "int" "colormap_size" } - { "int" "bits_per_rgb" } ; +STRUCT: XVisualInfo + { visual Visual* } + { visualid VisualID } + { screen int } + { depth uint } + { class int } + { red_mask ulong } + { green_mask ulong } + { blue_mask ulong } + { colormap_size int } + { bits_per_rgb int } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Appendix D - Compatibility Functions From 861a3f563b80301eb2ffe604e624f823478ae0c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Aug 2009 00:24:25 -0400 Subject: [PATCH 42/42] x11.events, ui.backend.x11: actually make it work --- basis/ui/backend/x11/x11.factor | 5 +++-- basis/x11/events/events.factor | 30 +++++++++++++++--------------- 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index fcaf0e2a70..978fed6bf8 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -49,7 +49,8 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{ M: x11-ui-backend (make-pixel-format) [ drop dpy get scr get ] dip - >glx-visual-int-array glXChooseVisual ; + >glx-visual-int-array glXChooseVisual + XVisualInfo memory>struct ; M: x11-ui-backend (free-pixel-format) handle>> XFree ; @@ -223,7 +224,7 @@ M: world client-event ] [ wait-for-display wait-event ] if ; M: x11-ui-backend do-events - wait-event dup window>> window dup + wait-event dup XAnyEvent>> window>> window dup [ handle-event ] [ 2drop ] if ; : x-clipboard@ ( gadget clipboard -- prop win ) diff --git a/basis/x11/events/events.factor b/basis/x11/events/events.factor index a24f6a45aa..febbbfa135 100644 --- a/basis/x11/events/events.factor +++ b/basis/x11/events/events.factor @@ -51,21 +51,21 @@ GENERIC: client-event ( event window -- ) over wheel? [ 2drop ] [ button-up-event ] if ; : handle-event ( event window -- ) - over type>> { - { Expose [ XExposeEvent>> expose-event ] } - { ConfigureNotify [ XConfigureEvent>> configure-event ] } - { ButtonPress [ XButtonEvent>> button-down-event$ ] } - { ButtonRelease [ XButtonEvent>> button-up-event$ ] } - { EnterNotify [ XCrossingEvent>> enter-event ] } - { LeaveNotify [ XCrossingEvent>> leave-event ] } - { MotionNotify [ XMotionEvent>> motion-event ] } - { KeyPress [ XKeyEvent>> key-down-event ] } - { KeyRelease [ XKeyEvent>> key-up-event ] } - { FocusIn [ XFocusChangeEvent>> focus-in-event ] } - { FocusOut [ XFocusChangeEvent>> focus-out-event ] } - { SelectionNotify [ XSelectionEvent>> selection-notify-event ] } - { SelectionRequest [ XSelectionRequestEvent>> selection-request-event ] } - { ClientMessage [ XClientMessageEvent>> client-event ] } + swap dup XAnyEvent>> type>> { + { Expose [ XExposeEvent>> swap expose-event ] } + { ConfigureNotify [ XConfigureEvent>> swap configure-event ] } + { ButtonPress [ XButtonEvent>> swap button-down-event$ ] } + { ButtonRelease [ XButtonEvent>> swap button-up-event$ ] } + { EnterNotify [ XCrossingEvent>> swap enter-event ] } + { LeaveNotify [ XCrossingEvent>> swap leave-event ] } + { MotionNotify [ XMotionEvent>> swap motion-event ] } + { KeyPress [ XKeyEvent>> swap key-down-event ] } + { KeyRelease [ XKeyEvent>> swap key-up-event ] } + { FocusIn [ XFocusChangeEvent>> swap focus-in-event ] } + { FocusOut [ XFocusChangeEvent>> swap focus-out-event ] } + { SelectionNotify [ XSelectionEvent>> swap selection-notify-event ] } + { SelectionRequest [ XSelectionRequestEvent>> swap selection-request-event ] } + { ClientMessage [ XClientMessageEvent>> swap client-event ] } [ 3drop ] } case ;