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

win32: change HWND allocation and deallocation

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-31 11:17:24 -06:00
parent 3bcfd5cf7f
commit daf7f6dd17
14 changed files with 246 additions and 236 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -21,7 +21,6 @@
(define base-button% (define base-button%
(class item% (class item%
(inherit set-control-font auto-size get-hwnd (inherit set-control-font auto-size get-hwnd
subclass-control
remember-label-bitmap) remember-label-bitmap)
(init parent cb label x y w h style font) (init parent cb label x y w h style font)
@ -38,20 +37,20 @@
(super-new [callback cb] (super-new [callback cb]
[parent parent] [parent parent]
[hwnd [hwnd
(CreateWindowExW 0 (CreateWindowExW/control 0
(get-class) (get-class)
(if (string? label) (if (string? label)
label label
"<image>") "<image>")
(bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS (bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS
(if bitmap? (if bitmap?
BS_BITMAP BS_BITMAP
0)) 0))
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-client-hwnd)
#f #f
hInstance hInstance
#f)] #f)]
[style style]) [style style])
(when bitmap? (when bitmap?
@ -73,8 +72,6 @@
(auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)])) (auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)]))
(auto-size-button font label) (auto-size-button font label)
(subclass-control (get-hwnd))
(define/override (is-command? cmd) (define/override (is-command? cmd)
(= cmd BN_CLICKED)) (= cmd BN_CLICKED))

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

@ -82,7 +82,6 @@
get-client-size get-client-size
get-eventspace get-eventspace
set-control-font set-control-font
subclass-control
is-auto-scroll? get-virtual-width get-virtual-height is-auto-scroll? get-virtual-width get-virtual-height
reset-auto-scroll reset-auto-scroll
refresh-for-autoscroll refresh-for-autoscroll
@ -122,18 +121,18 @@
#f)) #f))
(define combo-hwnd (define combo-hwnd
(and panel-hwnd (and panel-hwnd
(CreateWindowExW 0 (CreateWindowExW/control 0
"PLTCOMBOBOX" "PLTCOMBOBOX"
"" ""
(bitwise-ior WS_CHILD WS_VISIBLE (bitwise-ior WS_CHILD WS_VISIBLE
CBS_DROPDOWNLIST CBS_DROPDOWNLIST
WS_HSCROLL WS_VSCROLL WS_HSCROLL WS_VSCROLL
WS_BORDER WS_CLIPSIBLINGS) WS_BORDER WS_CLIPSIBLINGS)
0 0 w h 0 0 w h
panel-hwnd panel-hwnd
#f #f
hInstance hInstance
#f))) #f)))
(define hwnd (or panel-hwnd canvas-hwnd)) (define hwnd (or panel-hwnd canvas-hwnd))
@ -145,8 +144,7 @@
[style style]) [style style])
(when combo-hwnd (when combo-hwnd
(set-control-font #f combo-hwnd) (set-control-font #f combo-hwnd))
(subclass-control combo-hwnd))
(define control-border-theme (define control-border-theme
(and (memq 'control-border style) (and (memq 'control-border style)

27
collects/mred/private/wx/win32/choice.rkt
View File

@ -25,23 +25,22 @@
x y w h x y w h
choices style font) choices style font)
(inherit auto-size set-control-font (inherit auto-size set-control-font
set-size set-size)
subclass-control)
(define callback cb) (define callback cb)
(define hwnd (define hwnd
(CreateWindowExW 0 (CreateWindowExW/control 0
"PLTCOMBOBOX" "PLTCOMBOBOX"
label label
(bitwise-ior WS_CHILD CBS_DROPDOWNLIST (bitwise-ior WS_CHILD CBS_DROPDOWNLIST
WS_HSCROLL WS_VSCROLL WS_HSCROLL WS_VSCROLL
WS_BORDER WS_CLIPSIBLINGS) WS_BORDER WS_CLIPSIBLINGS)
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-client-hwnd)
#f #f
hInstance hInstance
#f)) #f))
(define num-choices (length choices)) (define num-choices (length choices))
@ -66,8 +65,6 @@
(set-size -11111 -11111 w (* h 8)))) (set-size -11111 -11111 w (* h 8))))
(subclass-control hwnd)
(define choice-dropped? #f) (define choice-dropped? #f)
(define/override (ctlproc w msg wParam lParam default) (define/override (ctlproc w msg wParam lParam default)

29
collects/mred/private/wx/win32/gauge.rkt
View File

@ -21,8 +21,7 @@
(define gauge% (define gauge%
(class item% (class item%
(inherit set-size (inherit set-size)
subclass-control)
(init parent (init parent
label label
@ -32,18 +31,18 @@
font) font)
(define hwnd (define hwnd
(CreateWindowExW 0 (CreateWindowExW/control 0
"PLTmsctls_progress32" "PLTmsctls_progress32"
label label
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS (bitwise-ior WS_CHILD WS_CLIPSIBLINGS
(if (memq 'vertical style) (if (memq 'vertical style)
PBS_VERTICAL PBS_VERTICAL
0)) 0))
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-client-hwnd)
#f #f
hInstance hInstance
#f)) #f))
(super-new [callback void] (super-new [callback void]
[parent parent] [parent parent]
@ -56,8 +55,6 @@
(set-size -11111 -11111 100 24) (set-size -11111 -11111 100 24)
(set-size -11111 -11111 24 100)) (set-size -11111 -11111 24 100))
(subclass-control hwnd)
(define/public (get-value) (define/public (get-value)
(SendMessageW hwnd PBM_GETPOS 0 0)) (SendMessageW hwnd PBM_GETPOS 0 0))
(define/public (set-value v) (define/public (set-value v)

22
collects/mred/private/wx/win32/group-panel.rkt
View File

@ -22,19 +22,18 @@
style style
label) label)
(inherit auto-size set-control-font (inherit auto-size set-control-font)
subclass-control)
(define hwnd (define hwnd
(CreateWindowExW 0 (CreateWindowExW/control 0
"PLTBUTTON" "PLTBUTTON"
(or label "") (or label "")
(bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS) (bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS)
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-client-hwnd)
#f #f
hInstance hInstance
#f)) #f))
(define client-hwnd (define client-hwnd
(CreateWindowExW 0 (CreateWindowExW 0
@ -63,7 +62,6 @@
(lambda (w h) (lambda (w h)
(set! label-h h) (set! label-h h)
(set-size -11111 -11111 (+ w 10) (+ h 10)))) (set-size -11111 -11111 (+ w 10) (+ h 10))))
(subclass-control hwnd)
(define/public (set-label lbl) (define/public (set-label lbl)
(SetWindowTextW hwnd lbl)) (SetWindowTextW hwnd lbl))

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

@ -16,17 +16,6 @@
(protect-out item-mixin (protect-out item-mixin
item%)) item%))
(define (control-proc w msg wParam lParam)
(let ([wx (hwnd->wx w)])
(if wx
(send wx ctlproc w msg wParam lParam
(lambda (w msg wParam lParam)
((hwnd->ctlproc w) w msg wParam lParam)))
(let ([default-ctlproc (hwnd->ctlproc w)])
(default-ctlproc w msg wParam lParam)))))
(define control_proc (function-ptr control-proc _WndProc))
(define (item-mixin %) (define (item-mixin %)
(class % (class %
(inherit on-set-focus (inherit on-set-focus
@ -40,11 +29,6 @@
(super-new) (super-new)
(define/public (subclass-control hwnd)
(let ([old-control-proc (function-ptr (GetWindowLongW hwnd GWLP_WNDPROC) _WndProc)])
(set-hwnd-ctlproc! hwnd old-control-proc)
(SetWindowLongW hwnd GWLP_WNDPROC control_proc)))
(define/public (ctlproc w msg wParam lParam default) (define/public (ctlproc w msg wParam lParam default)
(if (try-mouse w msg wParam lParam) (if (try-mouse w msg wParam lParam)
0 0

35
collects/mred/private/wx/win32/list-box.rkt
View File

@ -54,7 +54,6 @@
font label-font) font label-font)
(inherit set-size set-control-font (inherit set-size set-control-font
subclass-control
get-client-size) get-client-size)
(define single? (define single?
@ -62,22 +61,22 @@
(not (memq 'mutiple style)))) (not (memq 'mutiple style))))
(define hwnd (define hwnd
(CreateWindowExW WS_EX_CLIENTEDGE (CreateWindowExW/control WS_EX_CLIENTEDGE
"PLTLISTBOX" "PLTLISTBOX"
label label
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY (bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY
WS_VSCROLL WS_VSCROLL
(if (memq 'hscroll style) WS_HSCROLL 0) (if (memq 'hscroll style) WS_HSCROLL 0)
(cond (cond
;; Win32 sense of "multiple" and "extended" is backwards ;; Win32 sense of "multiple" and "extended" is backwards
[(eq? kind 'extended) LBS_MULTIPLESEL] [(eq? kind 'extended) LBS_MULTIPLESEL]
[(eq? kind 'multiple) LBS_EXTENDEDSEL] [(eq? kind 'multiple) LBS_EXTENDEDSEL]
[else 0])) [else 0]))
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-client-hwnd)
#f #f
hInstance hInstance
#f)) #f))
(for ([s (in-list choices)]) (for ([s (in-list choices)])
(SendMessageW/str hwnd LB_ADDSTRING 0 s)) (SendMessageW/str hwnd LB_ADDSTRING 0 s))
@ -90,8 +89,6 @@
(set-control-font font) (set-control-font font)
(set-size -11111 -11111 40 60) (set-size -11111 -11111 40 60)
(subclass-control hwnd)
(define callback cb) (define callback cb)
(define/override (is-command? cmd) (define/override (is-command? cmd)

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

@ -65,7 +65,6 @@
(define message% (define message%
(class item% (class item%
(inherit auto-size set-size set-control-font get-hwnd (inherit auto-size set-size set-control-font get-hwnd
subclass-control
remember-label-bitmap) remember-label-bitmap)
(init parent label (init parent label
@ -81,26 +80,24 @@
(super-new [callback void] (super-new [callback void]
[parent parent] [parent parent]
[hwnd [hwnd
(CreateWindowExW 0 (CreateWindowExW/control 0
(get-class) (get-class)
(if (string? label) (if (string? label)
label label
"<image>") "<image>")
(bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS (bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS
(if bitmap? (if bitmap?
SS_BITMAP SS_BITMAP
(if (symbol? label) (if (symbol? label)
SS_ICON SS_ICON
0))) 0)))
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-client-hwnd)
#f #f
hInstance hInstance
#f)] #f)]
[style style]) [style style])
(subclass-control (get-hwnd))
(when bitmap? (when bitmap?
(let ([hbitmap (bitmap->hbitmap label)]) (let ([hbitmap (bitmap->hbitmap label)])
(remember-label-bitmap hbitmap) (remember-label-bitmap hbitmap)

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

@ -30,7 +30,6 @@
(inherit auto-size set-control-font (inherit auto-size set-control-font
is-enabled-to-root? is-enabled-to-root?
subclass-control
set-focus) set-focus)
(define callback cb) (define callback cb)
@ -59,20 +58,20 @@
[bitmap? (and (label . is-a? . bitmap%) [bitmap? (and (label . is-a? . bitmap%)
(send label ok?))] (send label ok?))]
[radio-hwnd [radio-hwnd
(CreateWindowExW 0 (CreateWindowExW/control 0
"PLTBUTTON" "PLTBUTTON"
(if (string? label) (if (string? label)
label label
"<image>") "<image>")
(bitwise-ior BS_RADIOBUTTON WS_CHILD WS_CLIPSIBLINGS (bitwise-ior BS_RADIOBUTTON WS_CHILD WS_CLIPSIBLINGS
(if bitmap? (if bitmap?
BS_BITMAP BS_BITMAP
0)) 0))
0 0 0 0 0 0 0 0
hwnd hwnd
#f #f
hInstance hInstance
#f)]) #f)])
(when bitmap? (when bitmap?
(let ([hbitmap (bitmap->hbitmap label)]) (let ([hbitmap (bitmap->hbitmap label)])
(set! label-bitmaps (cons hbitmap label-bitmaps)) (set! label-bitmaps (cons hbitmap label-bitmaps))
@ -96,9 +95,6 @@
[hwnd hwnd] [hwnd hwnd]
[extra-hwnds radio-hwnds] [extra-hwnds radio-hwnds]
[style style]) [style style])
(for ([radio-hwnd (in-list radio-hwnds)])
(subclass-control radio-hwnd))
(define/override (is-hwnd? a-hwnd) (define/override (is-hwnd? a-hwnd)
(or (ptr-equal? hwnd a-hwnd) (or (ptr-equal? hwnd a-hwnd)

23
collects/mred/private/wx/win32/slider.rkt
View File

@ -40,8 +40,7 @@
style style
font) font)
(inherit set-control-font (inherit set-control-font
auto-size auto-size)
subclass-control)
(define callback cb) (define callback cb)
(define vertical? (memq 'vertical style)) (define vertical? (memq 'vertical style))
@ -79,15 +78,15 @@
(define value-hwnd (define value-hwnd
(and panel-hwnd (and panel-hwnd
(CreateWindowExW 0 (CreateWindowExW/control 0
"STATIC" "STATIC"
(format "~s" val) (format "~s" val)
(bitwise-ior SS_CENTER WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE) (bitwise-ior SS_CENTER WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE)
0 0 0 0 0 0 0 0
panel-hwnd panel-hwnd
#f #f
hInstance hInstance
#f))) #f)))
(define hwnd (or panel-hwnd slider-hwnd)) (define hwnd (or panel-hwnd slider-hwnd))
@ -129,8 +128,6 @@
(SendMessageW slider-hwnd TBM_SETRANGE 1 (MAKELPARAM lo hi)) (SendMessageW slider-hwnd TBM_SETRANGE 1 (MAKELPARAM lo hi))
(set-value val) (set-value val)
(subclass-control slider-hwnd)
(define/override (set-size x y w h) (define/override (set-size x y w h)
(super set-size x y w h) (super set-size x y w h)
(when panel-hwnd (when panel-hwnd

23
collects/mred/private/wx/win32/tab-panel.rkt
View File

@ -45,19 +45,18 @@
(define callback void) (define callback void)
(inherit auto-size set-control-font (inherit auto-size set-control-font
is-shown-to-root? is-shown-to-root?)
subclass-control)
(define hwnd (define hwnd
(CreateWindowExW 0 (CreateWindowExW/control 0
"PLTSysTabControl32" "PLTSysTabControl32"
"" ""
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS) (bitwise-ior WS_CHILD WS_CLIPSIBLINGS)
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-client-hwnd)
#f #f
hInstance hInstance
#f)) #f))
(define client-hwnd (define client-hwnd
(CreateWindowExW 0 (CreateWindowExW 0
@ -76,8 +75,6 @@
[hwnd hwnd] [hwnd hwnd]
[style style]) [style style])
(subclass-control hwnd)
(define/override (get-client-hwnd) (define/override (get-client-hwnd)
client-hwnd) client-hwnd)

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

@ -19,11 +19,6 @@
GetLastError GetLastError
DestroyWindow
NotifyWindowDestroy
CreateWindowExW
clean-up-destroyed
GetWindowLongW GetWindowLongW
SetWindowLongW SetWindowLongW
SendMessageW SendMessageW/str SendMessageW SendMessageW/str
@ -71,23 +66,6 @@
(error who "call failed (~s)" (error who "call failed (~s)"
(GetLastError))) (GetLastError)))
(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL)
-> (unless r (failed 'DestroyWindow)))
#:wrap (deallocator))
(define NotifyWindowDestroy ((deallocator) void))
(define (clean-up-destroyed)
(free-remembered-now DestroyWindow))
(define-user32 CreateWindowExW (_wfun _DWORD
_string/utf-16
_string/utf-16
_UDWORD
_int _int _int _int
_HWND _HMENU _HINSTANCE _pointer
-> _HWND)
#:wrap (allocator remember-to-free-later))
(define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) (define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer))
(define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) (define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer))

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

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

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

@ -1,7 +1,9 @@
#lang racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
ffi/unsafe/alloc
racket/class racket/class
"../../lock.rkt" "../../lock.rkt"
"../common/utils.rkt"
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
"const.rkt" "const.rkt"
@ -12,11 +14,12 @@
DefWindowProcW DefWindowProcW
background-hbrush background-hbrush
set-hwnd-wx! set-hwnd-wx!
set-hwnd-ctlproc!
hwnd->wx hwnd->wx
hwnd->ctlproc hwnd->ctlproc
any-hwnd->wx any-hwnd->wx
unregister-hwnd CreateWindowExW
CreateWindowExW/control
clean-up-destroyed
MessageBoxW MessageBoxW
_WndProc)) _WndProc))
@ -32,50 +35,69 @@
;; | (cons <ctlproc> <wx-weak-box>) ;; | (cons <ctlproc> <wx-weak-box>)
;; <wx-weak-box> = (make-weak-box <object%>) ;; <wx-weak-box> = (make-weak-box <object%>)
(define all-cells (make-hash)) (define all-hwnds (make-hash))
;; call in atomic mode:
(define (register-hwnd! hwnd)
(hash-set! all-hwnds (cast hwnd _pointer _long) #t))
;; call in atomic mode:
(define (alloc-hwnd-cell hwnd)
(let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
(or c
(let ([c (malloc-immobile-cell #f)])
(SetWindowLongW hwnd GWLP_USERDATA c)
c))))
(define (set-hwnd-wx! hwnd wx) (define (set-hwnd-wx! hwnd wx)
(let ([c (malloc-immobile-cell (make-weak-box wx))]) (let* ([c (atomically (alloc-hwnd-cell hwnd))]
(SetWindowLongW hwnd GWLP_USERDATA c) [v (ptr-ref c _racket)])
(atomically (hash-set! all-cells (cast c _pointer _long) #t)))) (ptr-set! c _racket (cons wx (and v (cdr v))))))
(define (set-hwnd-ctlproc! hwnd ctlproc) (define (set-hwnd-ctlproc! hwnd ctlproc)
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) (let* ([c (atomically (alloc-hwnd-cell hwnd))]
(ptr-set! p _racket (cons (ptr-ref p _racket) ctlproc)))) [v (ptr-ref c _racket)])
(ptr-set! c _racket (cons (and v (car v)) ctlproc))))
(define (hwnd->wx hwnd) (define (hwnd->wx hwnd)
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) (let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
(and p (let ([wb (ptr-ref p _racket)]) (and c (let ([wb (ptr-ref c _racket)])
(and wb (and wb
(weak-box-value (if (pair? wb) (weak-box-value (if (pair? wb)
(car wb) (car wb)
wb))))))) wb)))))))
(define (hwnd->ctlproc hwnd) (define (hwnd->ctlproc hwnd)
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) (let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
(and p (let ([wb (ptr-ref p _racket)]) (and c (let ([wb (ptr-ref c _racket)])
(and wb (and wb
(pair? wb) (pair? wb)
(cdr wb)))))) (cdr wb))))))
(define (any-hwnd->wx hwnd) (define (any-hwnd->wx hwnd)
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) (and
(and p (atomically (hash-ref all-hwnds (cast hwnd _pointer _long) #f))
(atomically (hash-ref all-cells (cast p _pointer _long) #f)) (let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
(let ([wx (let ([wb (ptr-ref p _racket)]) (and c
(and wb (let ([wx (let ([wb (ptr-ref c _racket)])
(weak-box-value (if (pair? wb) (and wb
(car wb) (weak-box-value (if (pair? wb)
wb))))]) (car wb)
(and wx wb))))])
(send wx is-hwnd? hwnd) (and wx
wx))))) (send wx is-hwnd? hwnd)
wx))))))
(define (unregister-hwnd hwnd) ;; call in atomic mode:
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) (define (unregister-hwnd? hwnd)
(when p (let ([addr (cast hwnd _pointer _long)])
(free-immobile-cell p) (and (hash-ref all-hwnds addr #f)
(SetWindowLongW hwnd GWLP_USERDATA #f)))) (let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
(when c
(free-immobile-cell c)
(hash-ref all-hwnds addr #f)
(SetWindowLongW hwnd GWLP_USERDATA #f)
#t)))))
;; ---------------------------------------- ;; ----------------------------------------
@ -95,6 +117,74 @@
(define _WndProc (_wfun #:atomic? #t #:keep (box null) (define _WndProc (_wfun #:atomic? #t #:keep (box null)
_HWND _UINT _WPARAM _LPARAM -> _LRESULT)) _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
(define (wind-proc w msg wparam lparam)
(if (= msg WM_DESTROY)
(begin
(unregister-hwnd? w)
(DefWindowProcW w msg wparam lparam))
(let ([wx (hwnd->wx w)])
(if wx
(send wx wndproc w msg wparam lparam DefWindowProcW)
(DefWindowProcW w msg wparam lparam)))))
(define wind-proc-ptr (function-ptr wind-proc _WndProc))
(define (control-proc w msg wParam lParam)
(if (= msg WM_DESTROY)
(let ([default-ctlproc (hwnd->ctlproc w)])
(unregister-hwnd? w)
(default-ctlproc w))
(let ([wx (hwnd->wx w)])
(if wx
(send wx ctlproc w msg wParam lParam
(lambda (w msg wParam lParam)
((hwnd->ctlproc w) w msg wParam lParam)))
(let ([default-ctlproc (hwnd->ctlproc w)])
(default-ctlproc w msg wParam lParam))))))
(define control_proc (function-ptr control-proc _WndProc))
(define (subclass-control hwnd)
(let ([old-control-proc (function-ptr (GetWindowLongW hwnd GWLP_WNDPROC) _WndProc)])
(set-hwnd-ctlproc! hwnd old-control-proc)
(SetWindowLongW hwnd GWLP_WNDPROC control_proc)))
;; ----------------------------------------
(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL)
-> (unless r (failed 'DestroyWindow))))
(define (maybe-destroy-window hwnd)
(atomically
(when (unregister-hwnd? hwnd)
(DestroyWindow hwnd))))
(define (clean-up-destroyed)
(free-remembered-now maybe-destroy-window))
(define-user32 _CreateWindowExW (_wfun _DWORD
_string/utf-16
_string/utf-16
_UDWORD
_int _int _int _int
_HWND _HMENU _HINSTANCE _pointer
-> _HWND)
#:c-id CreateWindowExW)
(define (make-CreateWindowEx register!)
((allocator remember-to-free-later)
(lambda (dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam)
(let ([hwnd (_CreateWindowExW dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam)])
(register-hwnd! hwnd)
hwnd))))
(define CreateWindowExW (make-CreateWindowEx register-hwnd!))
(define CreateWindowExW/control (make-CreateWindowEx (lambda (hwnd)
(register-hwnd! hwnd)
(subclass-control hwnd))))
;; ----------------------------------------
(define-cstruct _WNDCLASS ([style _UINT] (define-cstruct _WNDCLASS ([style _UINT]
[lpfnWndProc _fpointer] [lpfnWndProc _fpointer]
[cbClsExtra _int] [cbClsExtra _int]
@ -120,14 +210,6 @@
#;(define-user32 PostQuitMessage (_wfun _int -> _void)) #;(define-user32 PostQuitMessage (_wfun _int -> _void))
(define (wind-proc w msg wparam lparam)
(let ([wx (hwnd->wx w)])
(if wx
(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 hInstance (GetModuleHandleW #f))
(define background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) (define background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])