win32: fix gl canvas repaint

This commit is contained in:
Matthew Flatt 2010-10-13 17:38:49 -06:00
parent 47281a9d2d
commit 3d9f52a4d1

View File

@ -89,6 +89,7 @@
(define hscroll? (memq 'hscroll style)) (define hscroll? (memq 'hscroll style))
(define vscroll? (memq 'vscroll style)) (define vscroll? (memq 'vscroll style))
(define for-gl? (memq 'gl style))
(define panel-hwnd (define panel-hwnd
(and (memq 'combo style) (and (memq 'combo style)
@ -155,19 +156,21 @@
[(= msg WM_PAINT) [(= msg WM_PAINT)
(let* ([ps (malloc 128)] (let* ([ps (malloc 128)]
[hdc (BeginPaint w ps)]) [hdc (BeginPaint w ps)])
(unless (positive? paint-suspended) (if for-gl?
(let* ([hbrush (if no-autoclear? (queue-paint)
#f (unless (positive? paint-suspended)
(if transparent? (let* ([hbrush (if no-autoclear?
background-hbrush #f
(CreateSolidBrush bg-colorref)))]) (if transparent?
(when hbrush background-hbrush
(let ([r (GetClientRect canvas-hwnd)]) (CreateSolidBrush bg-colorref)))])
(FillRect hdc r hbrush)) (when hbrush
(unless transparent? (let ([r (GetClientRect canvas-hwnd)])
(DeleteObject hbrush))) (FillRect hdc r hbrush))
(unless (do-backing-flush this dc hdc) (unless transparent?
(queue-paint)))) (DeleteObject hbrush)))
(unless (do-backing-flush this dc hdc)
(queue-paint)))))
(EndPaint hdc ps)) (EndPaint hdc ps))
0] 0]
[(= msg WM_NCPAINT) [(= msg WM_NCPAINT)
@ -254,7 +257,8 @@
(define/override (refresh) (queue-paint)) (define/override (refresh) (queue-paint))
(define/public (queue-backing-flush) (define/public (queue-backing-flush)
(InvalidateRect canvas-hwnd #f #f)) (unless for-gl?
(InvalidateRect canvas-hwnd #f #f)))
(define/public (make-compatible-bitmap w h) (define/public (make-compatible-bitmap w h)
(send dc make-backing-bitmap w h)) (send dc make-backing-bitmap w h))