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

win32: memory management

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-12 13:39:32 -06:00
parent 905594ced3
commit 3f3d5f0f21
11 changed files with 111 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/mred/private/wx/win32/button.rkt
View File

@ -20,7 +20,8 @@
(define base-button%
(class item%
(inherit set-control-font auto-size get-hwnd
subclass-control)
subclass-control
remember-label-bitmap)
(init parent cb label x y w h style font)
@ -53,8 +54,10 @@
[style style])
(when bitmap?
(SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP
(cast (bitmap->hbitmap label #:bg #xFFFFFF) _HBITMAP _LPARAM)))
(let ([hbitmap (bitmap->hbitmap label #:bg #xFFFFFF)])
(remember-label-bitmap hbitmap)
(SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP
(cast hbitmap _HBITMAP _LPARAM))))
(set-control-font font)

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

@ -31,14 +31,9 @@
-> (unless r (failed 'ShowScrollbar))))
(define-gdi32 CreateSolidBrush (_wfun _COLORREF -> _HBRUSH))
(define-gdi32 DeleteObject (_wfun _pointer -> (r : _BOOL)
-> (unless r (failed 'DeleteObject))))
(define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int)
-> (when (zero? r) (failed 'FillRect))))
(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL)
-> (unless r (failed 'DestroyWindow))))
(define _HRGN _pointer)
(define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC))
(define DCX_WINDOW #x00000001)
@ -89,7 +84,8 @@
subclass-control
is-auto-scroll? get-virtual-width get-virtual-height
reset-auto-scroll
refresh-for-autoscroll)
refresh-for-autoscroll
on-size)
(define hscroll? (memq 'hscroll style))
(define vscroll? (memq 'vscroll style))
@ -228,7 +224,8 @@
[w (if (= w -1) (- (RECT-right r) (RECT-left r)) w)]
[h (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)])
(MoveWindow canvas-hwnd 0 0 (max 1 (- w COMBO-WIDTH)) h #t)
(MoveWindow combo-hwnd 0 0 (max 1 w) (- h 2) #t))))
(MoveWindow combo-hwnd 0 0 (max 1 w) (- h 2) #t)))
(on-size 0 0))
;; The `queue-paint' and `paint-children' methods
;; are defined by `canvas-mixin' from ../common/canvas-mixin

45
collects/mred/private/wx/win32/frame.rkt
View File

@ -3,6 +3,7 @@
racket/draw
(only-in racket/list last)
ffi/unsafe
ffi/unsafe/alloc
"../../syntax.rkt"
"../../lock.rkt"
"../common/queue.rkt"
@ -44,8 +45,13 @@
[yHotspot _DWORD]
[hbmMask _HBITMAP]
[hbmColor _HBITMAP]))
(define-user32 DestroyIcon (_wfun _HICON -> (r : _BOOL)
-> (unless r (failed 'DestroyIcon)))
#:wrap (deallocator))
(define-user32 CreateIconIndirect (_wfun _ICONINFO-pointer -> (r : _HICON)
-> (or r (failed 'CreateIconIndirect))))
-> (or r (failed 'CreateIconIndirect)))
#:wrap (allocator DestroyIcon))
(define SPI_GETWORKAREA #x0030)
@ -378,23 +384,36 @@
(define/override (is-frame?) #t)
;; Retain to aviod GC of the icon:
(define small-hicon #f)
(define big-hicon #f)
(define/public (set-icon bm mask [mode 'both])
(let ([hicon (CreateIconIndirect
(make-ICONINFO
#t 0 0
(let* ([bm (make-object bitmap% (send bm get-width) (send bm get-height))]
[dc (make-object bitmap-dc% bm)])
(send dc set-brush "black" 'solid)
(send dc draw-rectangle 0 0 (send bm get-width) (send bm get-height))
(send dc set-bitmap #f)
(bitmap->hbitmap bm #:b&w? #t))
(bitmap->hbitmap bm #:mask mask)))])
(let* ([bg-hbitmap
(let* ([bm (make-object bitmap% (send bm get-width) (send bm get-height))]
[dc (make-object bitmap-dc% bm)])
(send dc set-brush "black" 'solid)
(send dc draw-rectangle 0 0 (send bm get-width) (send bm get-height))
(send dc set-bitmap #f)
(bitmap->hbitmap bm #:b&w? #t))]
[main-hbitmap (bitmap->hbitmap bm #:mask mask)]
[hicon (CreateIconIndirect
(make-ICONINFO
#t 0 0
bg-hbitmap
main-hbitmap))])
(DeleteObject bg-hbitmap)
(DeleteObject main-hbitmap)
(when (or (eq? mode 'small)
(eq? mode 'both))
(SendMessageW hwnd WM_SETICON 0 (cast hicon _HICON _LPARAM)))
(atomically
(set! small-hicon hicon)
(SendMessageW hwnd WM_SETICON 0 (cast hicon _HICON _LPARAM))))
(when (or (eq? mode 'big)
(eq? mode 'both))
(SendMessageW hwnd WM_SETICON 1 (cast hicon _HICON _LPARAM)))))
(atomically
(set! big-hicon hicon)
(SendMessageW hwnd WM_SETICON 1 (cast hicon _HICON _LPARAM))))))
(def/public-unimplemented iconize)
(define/public (set-title s)

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

@ -21,8 +21,6 @@
(define-gdi32 SelectObject/raw _fpointer
#:c-id SelectObject)
(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC))
(define SRCCOPY #x00CC0020)
(define blit-hdc (CreateCompatibleDC #f))

6
collects/mred/private/wx/win32/hbitmap.rkt
View File

@ -10,12 +10,6 @@
(provide bitmap->hbitmap)
(define-gdi32 CreateCompatibleBitmap (_wfun _HDC _int _int -> _HBITMAP))
(define-gdi32 CreateBitmap (_wfun _int _int _UINT _UINT _pointer -> _HBITMAP))
(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC))
(define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL)
-> (unless r (failed 'DeleteDC))))
(define (bitmap->hbitmap bm
#:mask [mask-bm #f]
#:b&w? [b&w? #f]

5
collects/mred/private/wx/win32/item.rkt
View File

@ -76,6 +76,11 @@
(super-new)
(define/override (gets-focus?) #t)
;; Retain to avoid GC of the bitmaps:
(define label-hbitmaps null)
(define/public (remember-label-bitmap hbitmap)
(set! label-hbitmaps (cons hbitmap label-hbitmaps)))
(define/public (set-label s)
(SetWindowTextW (get-hwnd) s))

11
collects/mred/private/wx/win32/message.rkt
View File

@ -64,7 +64,8 @@
(define message%
(class item%
(inherit auto-size set-size set-control-font get-hwnd
subclass-control)
subclass-control
remember-label-bitmap)
(init parent label
x y
@ -100,8 +101,10 @@
(subclass-control (get-hwnd))
(when bitmap?
(SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP
(cast (bitmap->hbitmap label) _HBITMAP _LPARAM)))
(let ([hbitmap (bitmap->hbitmap label)])
(remember-label-bitmap hbitmap)
(SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP
(cast hbitmap _HBITMAP _LPARAM))))
(when (symbol? label)
(SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_ICON
(cast (force (case label
@ -111,7 +114,7 @@
_HICON _LPARAM)))
(set-control-font font)
(if (symbol? label)
(set-size -11111 -11111 32 32)
(auto-size label 0 0 0 0))))

9
collects/mred/private/wx/win32/radio-box.rkt
View File

@ -30,7 +30,8 @@
(inherit auto-size set-control-font
is-enabled-to-root?
subclass-control
set-focus)
set-focus
remember-label-bitmap)
(define callback cb)
(define current-value val)
@ -71,8 +72,10 @@
hInstance
#f)])
(when bitmap?
(SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP
(cast (bitmap->hbitmap label) _HBITMAP _LPARAM)))
(let ([hbitmap (bitmap->hbitmap label)])
(remember-label-bitmap hbitmap)
(SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP
(cast hbitmap _HBITMAP _LPARAM))))
(ShowWindow radio-hwnd SW_SHOW)
(set-control-font font radio-hwnd)
(let-values ([(w h)

43
collects/mred/private/wx/win32/utils.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/define
ffi/unsafe/alloc
"../common/utils.rkt"
"types.rkt")
@ -14,11 +15,18 @@
failed
GetLastError
DestroyWindow
NotifyWindowDestroy
CreateWindowExW
GetWindowLongW
SetWindowLongW
SendMessageW SendMessageW/str
GetSysColor GetRValue GetGValue GetBValue make-COLORREF
CreateBitmap
CreateCompatibleBitmap
DeleteObject
CreateCompatibleDC
DeleteDC
MoveWindow
ShowWindow
EnableWindow
@ -53,13 +61,20 @@
(error who "call failed (~s)"
(GetLastError)))
(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL)
-> (unless r (failed 'DestroyWindow)))
#:wrap (deallocator))
(define NotifyWindowDestroy ((deallocator) void))
(define-user32 CreateWindowExW (_wfun _DWORD
_string/utf-16
_string/utf-16
_UDWORD
_int _int _int _int
_HWND _HMENU _HINSTANCE _pointer
-> _HWND))
-> _HWND)
#:wrap (allocator DestroyWindow))
(define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer))
(define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer))
@ -88,8 +103,30 @@
(define-user32 SetCursor (_wfun _HCURSOR -> _HCURSOR))
(define-user32 GetDC (_wfun _HWND -> _HDC))
(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int))
(define-user32 _GetDC (_wfun _HWND -> _HDC)
#:c-id GetDC)
(define (GetDC hwnd)
(((allocator (lambda (hdc) (ReleaseDC hwnd hdc)))
_GetDC)
hwnd))
(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int)
#:wrap (deallocator cadr))
(define-gdi32 DeleteObject (_wfun _pointer -> (r : _BOOL)
-> (unless r (failed 'DeleteObject)))
#:wrap (deallocator))
(define-gdi32 CreateCompatibleBitmap (_wfun _HDC _int _int -> _HBITMAP)
#:wrap (allocator DeleteObject))
(define-gdi32 CreateBitmap (_wfun _int _int _UINT _UINT _pointer -> _HBITMAP)
#:wrap (allocator DeleteObject))
(define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL)
-> (unless r (failed 'DeleteDC)))
#:wrap (deallocator))
(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC)
#:wrap (allocator DeleteDC))
(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL)
-> (unless r (failed 'InvalidateRect))))

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

@ -114,6 +114,11 @@
(if (try-mouse w msg wParam lParam)
0
(cond
[(= msg WM_DESTROY)
;; release immobile cell
(unregister-hwnd w)
;; so it won't be finalized:
(NotifyWindowDestroy w)]
[(= msg WM_SETFOCUS)
(queue-window-event this (lambda () (on-set-focus)))
0]

6
collects/mred/private/wx/win32/wndclass.rkt
View File

@ -13,6 +13,7 @@
hwnd->wx
any-hwnd->wx
set-hwnd-wx!
unregister-hwnd
MessageBoxW
_WndProc)
@ -38,6 +39,11 @@
(send wx is-hwnd? hwnd)
wx)))))
(define (unregister-hwnd hwnd)
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
(when p
(free-immobile-cell p)
(SetWindowLongW hwnd GWLP_USERDATA #f))))
;; ----------------------------------------