From b444555b6b0da63fb166bf82ac5ba38593b771de Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 11 Oct 2010 09:30:48 -0600 Subject: [PATCH] win32: fix collecting blit --- collects/mred/private/wx/win32/canvas.rkt | 10 ++--- collects/mred/private/wx/win32/gcwin.rkt | 50 ++++++--------------- collects/mred/private/wx/win32/wndclass.rkt | 25 ++++------- 3 files changed, 27 insertions(+), 58 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index cd561b59c5..f3b6c0c3a9 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -442,11 +442,11 @@ (define/private (register-one-blit x y w h on-hbitmap off-hbitmap) (atomically - (let ([hwnd (create-gc-window canvas-hwnd x y w h)]) + (let ([hdc (create-gc-dc canvas-hwnd)]) (let ([r (scheme_add_gc_callback - (make-gc-show-desc hwnd on-hbitmap w h) - (make-gc-hide-desc hwnd off-hbitmap w h))]) - (cons hwnd r))))) + (make-gc-show-desc hdc on-hbitmap x y w h) + (make-gc-hide-desc hdc off-hbitmap x y w h))]) + (cons hdc r))))) (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) (let ([on (fix-bitmap-size on w h on-x on-y)] @@ -459,7 +459,7 @@ (define/public (unregister-collecting-blits) (atomically (for ([r (in-list reg-blits)]) - (DestroyWindow (car r)) + (ReleaseDC canvas-hwnd (car r)) (scheme_remove_gc_callback (cdr r))) (set! reg-blits null)))))) diff --git a/collects/mred/private/wx/win32/gcwin.rkt b/collects/mred/private/wx/win32/gcwin.rkt index 324170cb4c..e43a2a32d6 100644 --- a/collects/mred/private/wx/win32/gcwin.rkt +++ b/collects/mred/private/wx/win32/gcwin.rkt @@ -7,15 +7,13 @@ (provide scheme_add_gc_callback scheme_remove_gc_callback - create-gc-window + create-gc-dc make-gc-show-desc make-gc-hide-desc) (define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket)) (define-mz scheme_remove_gc_callback (_fun _racket -> _void)) -(define-user32 ShowWindow/raw _fpointer - #:c-id ShowWindow) (define-gdi32 BitBlt/raw _fpointer #; (_wfun _HDC _int _int _int _int _HDC _int _int _DWORD -> _BOOL) @@ -29,40 +27,18 @@ (define blit-hdc (CreateCompatibleDC #f)) -(define (create-gc-window parent-hwnd x y w h) - (CreateWindowExW 0 - "PLTBlitTarget" - "" - (bitwise-ior WS_CHILD) - x y w h - parent-hwnd - #f - hInstance - #f)) +(define (create-gc-dc hwnd) + (GetDC hwnd)) -(define (make-draw hwnd hbitmap w h) - (let ([hdc (GetDC hwnd)]) - null - (list - (vector 'osapi_ptr_ptr->void SelectObject/raw blit-hdc hbitmap) - (vector 'osapi_ptr_int_int_int_int_ptr_int_int_long->void - BitBlt/raw hdc 0 0 w h blit-hdc 0 0 SRCCOPY) - (vector 'ptr_ptr->void SelectObject/raw blit-hdc #f)))) +(define (make-draw hdc hbitmap x y w h) + (vector + (vector 'osapi_ptr_ptr->void SelectObject/raw blit-hdc hbitmap) + (vector 'osapi_ptr_int_int_int_int_ptr_int_int_long->void + BitBlt/raw hdc x y w h blit-hdc 0 0 SRCCOPY) + (vector 'ptr_ptr->void SelectObject/raw blit-hdc #f))) -(define (make-gc-show-desc hwnd hbitmap w h) - (list->vector - (append - (list - (vector 'osapi_ptr_int->void ShowWindow/raw hwnd SW_SHOW)) - (make-draw hwnd hbitmap w h)))) - -(define (make-gc-hide-desc hwnd hbitmap w h) - (list->vector - (append - ;; draw the ``off'' bitmap so it changes immediately: - (make-draw hwnd hbitmap w h) - ;; hide the window; it may take a while for the underlying canvas - ;; to refresh: - (list - (vector 'osapi_ptr_int->void ShowWindow/raw hwnd SW_HIDE))))) +(define (make-gc-show-desc hdc hbitmap x y w h) + (make-draw hdc hbitmap x y w h)) +(define (make-gc-hide-desc hdc hbitmap x y w h) + (make-draw hdc hbitmap x y w h)) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index a3ea24faca..2033e2ac05 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -58,7 +58,7 @@ _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) (define-cstruct _WNDCLASS ([style _UINT] - [lpfnWndProc _WndProc] + [lpfnWndProc _fpointer] [cbClsExtra _int] [cbWndExtra _int] [hInstace _HINSTANCE] @@ -77,6 +77,8 @@ -> (if r i (failed 'GetClassInfoW)))) (define-user32 DefWindowProcW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) +(define-user32 DefWindowProcW/raw _fpointer + #:c-id DefWindowProcW) #;(define-user32 PostQuitMessage (_wfun _int -> _void)) @@ -86,6 +88,8 @@ (send wx wndproc w msg wparam lparam DefWindowProcW) (DefWindowProcW w msg wparam lparam)))) +(define wind-proc-ptr (function-ptr wind-proc _WndProc)) + (define hInstance (GetModuleHandleW #f)) (define background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) @@ -93,7 +97,7 @@ p)) (void (RegisterClassW (make-WNDCLASS CS_OWNDC - wind-proc + wind-proc-ptr 0 0 hInstance @@ -104,7 +108,7 @@ "PLTFrame"))) (void (RegisterClassW (make-WNDCLASS 0 ; using CS_OWNDC creates trouble when resizing? - wind-proc + wind-proc-ptr 0 0 hInstance @@ -114,19 +118,8 @@ #f ; menu "PLTCanvas"))) -(void (RegisterClassW (make-WNDCLASS CS_OWNDC - DefWindowProcW - 0 - 0 - hInstance - #f - #f - #f - #f - "PLTBlitTarget"))) - (void (RegisterClassW (make-WNDCLASS 0 - wind-proc + wind-proc-ptr 0 0 hInstance @@ -139,7 +132,7 @@ (define controls-are-transparent? #f) (void (RegisterClassW (make-WNDCLASS 0 - wind-proc + wind-proc-ptr 0 0 hInstance