suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

win32: avoid continued failure when painting fails

Browse Source 
original commit: a5c4863848279b205411aa8ce2400ff02afc3a32
This commit is contained in:
Matthew Flatt 2010-12-10 19:57:05 -07:00
parent a0d21c5c08
commit b80ef37630
2 changed files with 18 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/mred/private/wx/win32/canvas.rkt
View File

@ -155,23 +155,24 @@
[(= msg WM_PAINT)
(let* ([ps (malloc 128)]
[hdc (BeginPaint w ps)])
(if for-gl?
(queue-paint)
(if (positive? paint-suspended)
(set! suspended-refresh? #t)
(let* ([hbrush (if no-autoclear?
#f
(if transparent?
background-hbrush
(CreateSolidBrush bg-colorref)))])
(when hbrush
(let ([r (GetClientRect canvas-hwnd)])
(FillRect hdc r hbrush))
(unless transparent?
(DeleteObject hbrush)))
(unless (do-canvas-backing-flush hdc)
(queue-paint)))))
(EndPaint hdc ps))
(when hdc
(if for-gl?
(queue-paint)
(if (positive? paint-suspended)
(set! suspended-refresh? #t)
(let* ([hbrush (if no-autoclear?
#f
(if transparent?
background-hbrush
(CreateSolidBrush bg-colorref)))])
(when hbrush
(let ([r (GetClientRect canvas-hwnd)])
(FillRect hdc r hbrush))
(unless transparent?
(DeleteObject hbrush)))
(unless (do-canvas-backing-flush hdc)
(queue-paint)))))
(EndPaint hdc ps)))
0]
[(= msg WM_NCPAINT)
(if control-border-theme

2
collects/mred/private/wx/win32/window.rkt
View File

@ -56,8 +56,6 @@
-> (unless r (failed 'ClientToScreen))))
(define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT))
(define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int)
-> (when (zero? r) (failed 'FillRect))))
(define-shell32 DragAcceptFiles (_wfun _HWND _BOOL -> _void))