Updating code to use with-out-parameters

[factor.git] / basis / ui / backend / windows / windows.factor

diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
old mode 100644 (file)
new mode 100755 (executable)
index a6d73ca..42b5651
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@@ -1,5 +1,5 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
-! Portions copyright (C) 2007, 2009 Slava Pestov.
+! Portions copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings arrays assocs ui
 ui.private ui.gadgets ui.gadgets.private ui.backend
@@ -14,6 +14,7 @@ math.order calendar ascii sets io.encodings.utf16n
 windows.errors literals ui.pixel-formats
 ui.pixel-formats.private memoize classes colors
 specialized-arrays classes.struct alien.data ;
+FROM: namespaces => set ;
 SPECIALIZED-ARRAY: POINT
 IN: ui.backend.windows
 
@@ -58,16 +59,16 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{
     drop f ;
 
 : arb-make-pixel-format ( world attributes -- pf )
-    [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 0 <int> 0 <int>
-    [ wglChoosePixelFormatARB win32-error=0/f ] 2keep drop *int ;
+    [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 { int int }
+    [ wglChoosePixelFormatARB win32-error=0/f ] with-out-parameters drop ;
 
 : arb-pixel-format-attribute ( pixel-format attribute -- value )
     >WGL_ARB
     [ drop f ] [
         [ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
-        first <int> 0 <int>
+        first <int> { int }
         [ wglGetPixelFormatAttribivARB win32-error=0/f ]
-        keep *int
+        with-out-parameters
     ] if-empty ;
 
 CONSTANT: pfd-flag-map H{
@@ -170,6 +171,8 @@ PRIVATE>
 : lo-word ( wparam -- lo ) <short> *short ; inline
 : hi-word ( wparam -- hi ) -16 shift lo-word ; inline
 : >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
+: GET_APPCOMMAND_LPARAM ( lParam -- appCommand )
+    hi-word FAPPCOMMAND_MASK lo-word bitnot bitand ; inline
 
 : crlf>lf ( str -- str' )
     CHAR: \r swap remove ;
@@ -210,7 +213,7 @@ PRIVATE>
             dup win32-error=0/f
     
         dup GlobalLock dup win32-error=0/f
-        swapd byte-array>memory
+        rot binary-object memcpy
         dup GlobalUnlock win32-error=0/f
         CF_UNICODETEXT swap SetClipboardData win32-error=0/f
     ] with-clipboard ;
@@ -282,12 +285,12 @@ CONSTANT: window-control>ex-style
 : handle-wm-size ( hWnd uMsg wParam lParam -- )
     2nip
     [ lo-word ] keep hi-word 2array
-    dup { 0 0 } = [ 2drop ] [ swap window [ (>>dim) ] [ drop ] if* ] if ;
+    dup { 0 0 } = [ 2drop ] [ swap window [ dim<< ] [ drop ] if* ] if ;
 
 : handle-wm-move ( hWnd uMsg wParam lParam -- )
     2nip
     [ lo-word ] keep hi-word 2array
-    swap window [ (>>window-loc) ] [ drop ] if* ;
+    swap window [ window-loc<< ] [ drop ] if* ;
 
 CONSTANT: wm-keydown-codes
     H{
@@ -412,7 +415,7 @@ CONSTANT: exclude-keys-wm-char
     ] unless ;
 
 :: set-window-active ( hwnd uMsg wParam lParam ? -- n )
-    ? hwnd window (>>active?)
+    ? hwnd window active?<<
     hwnd uMsg wParam lParam DefWindowProc ;
 
 : handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
@@ -472,7 +475,8 @@ SYMBOL: nc-buttons
     message>button nc-buttons get
     swap [ push ] [ remove! drop ] if ;
 
-: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
+: mouse-scroll ( wParam -- array )
+    >lo-hi [ -80 /f ] map ;
 
 : mouse-event>gesture ( uMsg -- button )
     key-modifiers swap message>button
@@ -495,6 +499,14 @@ SYMBOL: nc-buttons
     ReleaseCapture win32-error=0/f
     mouse-captured off ;
 
+: handle-app-command ( hWnd uMsg wParam lParam -- )
+    GET_APPCOMMAND_LPARAM
+    {
+        { APPCOMMAND_BROWSER_BACKWARD [ pick window left-action send-action ] }
+        { APPCOMMAND_BROWSER_FORWARD [ pick window right-action send-action ] }
+        [ drop ]
+    } case 3drop ;
+    
 : handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
     [
         over set-capture
@@ -523,7 +535,7 @@ SYMBOL: nc-buttons
     >lo-hi swap window move-hand fire-motion ;
 
 :: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
-    wParam mouse-wheel hand-loc get hWnd window send-wheel ;
+    wParam mouse-scroll hand-loc get hWnd window send-scroll ;
 
 : handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
     #! message sent if windows needs application to stop dragging
@@ -571,6 +583,8 @@ H{ } clone wm-handlers set-global
 [ handle-wm-set-focus 0  ] WM_SETFOCUS add-wm-handler
 [ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler
 
+[ handle-app-command 0 ] WM_APPCOMMAND add-wm-handler
+
 [ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler
 [ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler
 [ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler
@@ -596,7 +610,7 @@ SYMBOL: trace-messages?
 
 ! return 0 if you handle the message, else just let DefWindowProc return its val
 : ui-wndproc ( -- object )
-    uint { void* uint long long } "stdcall" [
+    uint { void* uint long long } stdcall [
         pick
         trace-messages? get-global [ dup windows-message-name name>> print flush ] when
         wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
@@ -615,12 +629,12 @@ M: windows-ui-backend do-events
     WNDCLASSEX <struct> f GetModuleHandle
     class-name-ptr pick GetClassInfoEx 0 = [
         WNDCLASSEX heap-size >>cbSize
-        { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags >>style
+        flags{ CS_HREDRAW CS_VREDRAW CS_OWNDC } >>style
         ui-wndproc >>lpfnWndProc
         0 >>cbClsExtra
         0 >>cbWndExtra
         f GetModuleHandle >>hInstance
-        f GetModuleHandle "fraptor" utf16n string>alien LoadIcon >>hIcon
+        f GetModuleHandle "APPICON" utf16n string>alien LoadIcon >>hIcon
         f IDC_ARROW LoadCursor >>hCursor
 
         class-name-ptr >>lpszClassName
@@ -771,6 +785,9 @@ M: windows-ui-backend (with-ui)
 M: windows-ui-backend beep ( -- )
     0 MessageBeep drop ;
 
+M: windows-ui-backend system-alert
+    [ f ] 2dip swap MB_OK MessageBox drop ;
+
 : fullscreen-RECT ( hwnd -- RECT )
     MONITOR_DEFAULTTONEAREST MonitorFromWindow
     MONITORINFOEX <struct>
@@ -780,7 +797,7 @@ M: windows-ui-backend beep ( -- )
 : client-area>RECT ( hwnd -- RECT )
     RECT <struct>
     [ GetClientRect win32-error=0/f ]
-    [ >c-ptr byte-array>POINT-array [ ClientToScreen drop ] with each ]
+    [ >c-ptr POINT-array-cast [ ClientToScreen drop ] with each ]
     [ nip ] 2tri ;
 
 : hwnd>RECT ( hwnd -- RECT )
@@ -795,8 +812,7 @@ M: windows-ui-backend (ungrab-input) ( handle -- )
     f ClipCursor drop
     1 ShowCursor drop ;
 
-: fullscreen-flags ( -- n )
-    { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline
+CONSTANT: fullscreen-flags flags{ WS_CAPTION WS_BORDER WS_THICKFRAME }
 
 : enter-fullscreen ( world -- )
     handle>> hWnd>>
@@ -822,7 +838,7 @@ M: windows-ui-backend (ungrab-input) ( handle -- )
         [
             f
             over hwnd>RECT get-RECT-dimensions
-            { SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED } flags
+            flags{ SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED }
             SetWindowPos win32-error=0/f
         ]
         [ SW_RESTORE ShowWindow win32-error=0/f ]