From daf7f6dd17c0f1d5544a489a68c46e377e0eca07 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 31 Oct 2010 11:17:24 -0600 Subject: [PATCH] win32: change HWND allocation and deallocation --- collects/mred/private/wx/win32/button.rkt | 31 ++-- collects/mred/private/wx/win32/canvas.rkt | 28 ++-- collects/mred/private/wx/win32/choice.rkt | 27 ++- collects/mred/private/wx/win32/gauge.rkt | 29 ++-- .../mred/private/wx/win32/group-panel.rkt | 22 ++- collects/mred/private/wx/win32/item.rkt | 16 -- collects/mred/private/wx/win32/list-box.rkt | 35 ++-- collects/mred/private/wx/win32/message.rkt | 35 ++-- collects/mred/private/wx/win32/radio-box.rkt | 32 ++-- collects/mred/private/wx/win32/slider.rkt | 23 ++- collects/mred/private/wx/win32/tab-panel.rkt | 23 ++- collects/mred/private/wx/win32/utils.rkt | 22 --- collects/mred/private/wx/win32/window.rkt | 5 - collects/mred/private/wx/win32/wndclass.rkt | 154 ++++++++++++++---- 14 files changed, 246 insertions(+), 236 deletions(-) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 0c3a2924af..b492db36a4 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -21,7 +21,6 @@ (define base-button% (class item% (inherit set-control-font auto-size get-hwnd - subclass-control remember-label-bitmap) (init parent cb label x y w h style font) @@ -38,20 +37,20 @@ (super-new [callback cb] [parent parent] [hwnd - (CreateWindowExW 0 - (get-class) - (if (string? label) - label - "") - (bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS - (if bitmap? - BS_BITMAP - 0)) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)] + (CreateWindowExW/control 0 + (get-class) + (if (string? label) + label + "") + (bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + BS_BITMAP + 0)) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)] [style style]) (when bitmap? @@ -73,8 +72,6 @@ (auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)])) (auto-size-button font label) - (subclass-control (get-hwnd)) - (define/override (is-command? cmd) (= cmd BN_CLICKED)) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index f46c513be8..dc22282926 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -82,7 +82,6 @@ get-client-size get-eventspace set-control-font - subclass-control is-auto-scroll? get-virtual-width get-virtual-height reset-auto-scroll refresh-for-autoscroll @@ -122,18 +121,18 @@ #f)) (define combo-hwnd (and panel-hwnd - (CreateWindowExW 0 - "PLTCOMBOBOX" - "" - (bitwise-ior WS_CHILD WS_VISIBLE - CBS_DROPDOWNLIST - WS_HSCROLL WS_VSCROLL - WS_BORDER WS_CLIPSIBLINGS) - 0 0 w h - panel-hwnd - #f - hInstance - #f))) + (CreateWindowExW/control 0 + "PLTCOMBOBOX" + "" + (bitwise-ior WS_CHILD WS_VISIBLE + CBS_DROPDOWNLIST + WS_HSCROLL WS_VSCROLL + WS_BORDER WS_CLIPSIBLINGS) + 0 0 w h + panel-hwnd + #f + hInstance + #f))) (define hwnd (or panel-hwnd canvas-hwnd)) @@ -145,8 +144,7 @@ [style style]) (when combo-hwnd - (set-control-font #f combo-hwnd) - (subclass-control combo-hwnd)) + (set-control-font #f combo-hwnd)) (define control-border-theme (and (memq 'control-border style) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 940cca94fe..5eff9838e3 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -25,23 +25,22 @@ x y w h choices style font) (inherit auto-size set-control-font - set-size - subclass-control) + set-size) (define callback cb) (define hwnd - (CreateWindowExW 0 - "PLTCOMBOBOX" - label - (bitwise-ior WS_CHILD CBS_DROPDOWNLIST - WS_HSCROLL WS_VSCROLL - WS_BORDER WS_CLIPSIBLINGS) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)) + (CreateWindowExW/control 0 + "PLTCOMBOBOX" + label + (bitwise-ior WS_CHILD CBS_DROPDOWNLIST + WS_HSCROLL WS_VSCROLL + WS_BORDER WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) (define num-choices (length choices)) @@ -66,8 +65,6 @@ (set-size -11111 -11111 w (* h 8)))) - (subclass-control hwnd) - (define choice-dropped? #f) (define/override (ctlproc w msg wParam lParam default) diff --git a/collects/mred/private/wx/win32/gauge.rkt b/collects/mred/private/wx/win32/gauge.rkt index d87bf8ce01..6c92bd59bc 100644 --- a/collects/mred/private/wx/win32/gauge.rkt +++ b/collects/mred/private/wx/win32/gauge.rkt @@ -21,8 +21,7 @@ (define gauge% (class item% - (inherit set-size - subclass-control) + (inherit set-size) (init parent label @@ -32,18 +31,18 @@ font) (define hwnd - (CreateWindowExW 0 - "PLTmsctls_progress32" - label - (bitwise-ior WS_CHILD WS_CLIPSIBLINGS - (if (memq 'vertical style) - PBS_VERTICAL - 0)) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)) + (CreateWindowExW/control 0 + "PLTmsctls_progress32" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS + (if (memq 'vertical style) + PBS_VERTICAL + 0)) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) (super-new [callback void] [parent parent] @@ -56,8 +55,6 @@ (set-size -11111 -11111 100 24) (set-size -11111 -11111 24 100)) - (subclass-control hwnd) - (define/public (get-value) (SendMessageW hwnd PBM_GETPOS 0 0)) (define/public (set-value v) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt index 3dce9e4032..493986752d 100644 --- a/collects/mred/private/wx/win32/group-panel.rkt +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -22,19 +22,18 @@ style label) - (inherit auto-size set-control-font - subclass-control) + (inherit auto-size set-control-font) (define hwnd - (CreateWindowExW 0 - "PLTBUTTON" - (or label "") - (bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)) + (CreateWindowExW/control 0 + "PLTBUTTON" + (or label "") + (bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) (define client-hwnd (CreateWindowExW 0 @@ -63,7 +62,6 @@ (lambda (w h) (set! label-h h) (set-size -11111 -11111 (+ w 10) (+ h 10)))) - (subclass-control hwnd) (define/public (set-label lbl) (SetWindowTextW hwnd lbl)) diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index 20477dd901..bc549375e9 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -16,17 +16,6 @@ (protect-out item-mixin 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 %) (class % (inherit on-set-focus @@ -40,11 +29,6 @@ (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) (if (try-mouse w msg wParam lParam) 0 diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index 1ff72c9847..df223e2ff2 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -54,7 +54,6 @@ font label-font) (inherit set-size set-control-font - subclass-control get-client-size) (define single? @@ -62,22 +61,22 @@ (not (memq 'mutiple style)))) (define hwnd - (CreateWindowExW WS_EX_CLIENTEDGE - "PLTLISTBOX" - label - (bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY - WS_VSCROLL - (if (memq 'hscroll style) WS_HSCROLL 0) - (cond - ;; Win32 sense of "multiple" and "extended" is backwards - [(eq? kind 'extended) LBS_MULTIPLESEL] - [(eq? kind 'multiple) LBS_EXTENDEDSEL] - [else 0])) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)) + (CreateWindowExW/control WS_EX_CLIENTEDGE + "PLTLISTBOX" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY + WS_VSCROLL + (if (memq 'hscroll style) WS_HSCROLL 0) + (cond + ;; Win32 sense of "multiple" and "extended" is backwards + [(eq? kind 'extended) LBS_MULTIPLESEL] + [(eq? kind 'multiple) LBS_EXTENDEDSEL] + [else 0])) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) (for ([s (in-list choices)]) (SendMessageW/str hwnd LB_ADDSTRING 0 s)) @@ -90,8 +89,6 @@ (set-control-font font) (set-size -11111 -11111 40 60) - (subclass-control hwnd) - (define callback cb) (define/override (is-command? cmd) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index e4ee583c3c..a140cbea73 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -65,7 +65,6 @@ (define message% (class item% (inherit auto-size set-size set-control-font get-hwnd - subclass-control remember-label-bitmap) (init parent label @@ -81,26 +80,24 @@ (super-new [callback void] [parent parent] [hwnd - (CreateWindowExW 0 - (get-class) - (if (string? label) - label - "") - (bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS - (if bitmap? - SS_BITMAP - (if (symbol? label) - SS_ICON - 0))) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)] + (CreateWindowExW/control 0 + (get-class) + (if (string? label) + label + "") + (bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + SS_BITMAP + (if (symbol? label) + SS_ICON + 0))) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)] [style style]) - (subclass-control (get-hwnd)) - (when bitmap? (let ([hbitmap (bitmap->hbitmap label)]) (remember-label-bitmap hbitmap) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 30453ffe4b..bb9c9de7b5 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -30,7 +30,6 @@ (inherit auto-size set-control-font is-enabled-to-root? - subclass-control set-focus) (define callback cb) @@ -59,20 +58,20 @@ [bitmap? (and (label . is-a? . bitmap%) (send label ok?))] [radio-hwnd - (CreateWindowExW 0 - "PLTBUTTON" - (if (string? label) - label - "") - (bitwise-ior BS_RADIOBUTTON WS_CHILD WS_CLIPSIBLINGS - (if bitmap? - BS_BITMAP - 0)) - 0 0 0 0 - hwnd - #f - hInstance - #f)]) + (CreateWindowExW/control 0 + "PLTBUTTON" + (if (string? label) + label + "") + (bitwise-ior BS_RADIOBUTTON WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + BS_BITMAP + 0)) + 0 0 0 0 + hwnd + #f + hInstance + #f)]) (when bitmap? (let ([hbitmap (bitmap->hbitmap label)]) (set! label-bitmaps (cons hbitmap label-bitmaps)) @@ -96,9 +95,6 @@ [hwnd hwnd] [extra-hwnds radio-hwnds] [style style]) - - (for ([radio-hwnd (in-list radio-hwnds)]) - (subclass-control radio-hwnd)) (define/override (is-hwnd? a-hwnd) (or (ptr-equal? hwnd a-hwnd) diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index 05aafb36b7..efecc60d23 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -40,8 +40,7 @@ style font) (inherit set-control-font - auto-size - subclass-control) + auto-size) (define callback cb) (define vertical? (memq 'vertical style)) @@ -79,15 +78,15 @@ (define value-hwnd (and panel-hwnd - (CreateWindowExW 0 - "STATIC" - (format "~s" val) - (bitwise-ior SS_CENTER WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE) - 0 0 0 0 - panel-hwnd - #f - hInstance - #f))) + (CreateWindowExW/control 0 + "STATIC" + (format "~s" val) + (bitwise-ior SS_CENTER WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE) + 0 0 0 0 + panel-hwnd + #f + hInstance + #f))) (define hwnd (or panel-hwnd slider-hwnd)) @@ -129,8 +128,6 @@ (SendMessageW slider-hwnd TBM_SETRANGE 1 (MAKELPARAM lo hi)) (set-value val) - (subclass-control slider-hwnd) - (define/override (set-size x y w h) (super set-size x y w h) (when panel-hwnd diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index 5ff10ba0cf..a85aaf96dd 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -45,19 +45,18 @@ (define callback void) (inherit auto-size set-control-font - is-shown-to-root? - subclass-control) + is-shown-to-root?) (define hwnd - (CreateWindowExW 0 - "PLTSysTabControl32" - "" - (bitwise-ior WS_CHILD WS_CLIPSIBLINGS) - 0 0 0 0 - (send parent get-client-hwnd) - #f - hInstance - #f)) + (CreateWindowExW/control 0 + "PLTSysTabControl32" + "" + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) (define client-hwnd (CreateWindowExW 0 @@ -76,8 +75,6 @@ [hwnd hwnd] [style style]) - (subclass-control hwnd) - (define/override (get-client-hwnd) client-hwnd) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index ce27d48f24..cc519e1962 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -19,11 +19,6 @@ GetLastError - DestroyWindow - NotifyWindowDestroy - CreateWindowExW - clean-up-destroyed - GetWindowLongW SetWindowLongW SendMessageW SendMessageW/str @@ -71,23 +66,6 @@ (error who "call failed (~s)" (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 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index c2b8b832ff..bcd94f97be 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -143,11 +143,6 @@ (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] diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 4e3a62f1c0..c41a49436a 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -1,7 +1,9 @@ #lang racket/base (require ffi/unsafe + ffi/unsafe/alloc racket/class "../../lock.rkt" + "../common/utils.rkt" "utils.rkt" "types.rkt" "const.rkt" @@ -12,11 +14,12 @@ DefWindowProcW background-hbrush set-hwnd-wx! - set-hwnd-ctlproc! hwnd->wx hwnd->ctlproc any-hwnd->wx - unregister-hwnd + CreateWindowExW + CreateWindowExW/control + clean-up-destroyed MessageBoxW _WndProc)) @@ -32,50 +35,69 @@ ;; | (cons ) ;; = (make-weak-box ) -(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) - (let ([c (malloc-immobile-cell (make-weak-box wx))]) - (SetWindowLongW hwnd GWLP_USERDATA c) - (atomically (hash-set! all-cells (cast c _pointer _long) #t)))) + (let* ([c (atomically (alloc-hwnd-cell hwnd))] + [v (ptr-ref c _racket)]) + (ptr-set! c _racket (cons wx (and v (cdr v)))))) (define (set-hwnd-ctlproc! hwnd ctlproc) - (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) - (ptr-set! p _racket (cons (ptr-ref p _racket) ctlproc)))) + (let* ([c (atomically (alloc-hwnd-cell hwnd))] + [v (ptr-ref c _racket)]) + (ptr-set! c _racket (cons (and v (car v)) ctlproc)))) (define (hwnd->wx hwnd) - (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) - (and p (let ([wb (ptr-ref p _racket)]) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (and c (let ([wb (ptr-ref c _racket)]) (and wb (weak-box-value (if (pair? wb) (car wb) wb))))))) (define (hwnd->ctlproc hwnd) - (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) - (and p (let ([wb (ptr-ref p _racket)]) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (and c (let ([wb (ptr-ref c _racket)]) (and wb (pair? wb) (cdr wb)))))) (define (any-hwnd->wx hwnd) - (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) - (and p - (atomically (hash-ref all-cells (cast p _pointer _long) #f)) - (let ([wx (let ([wb (ptr-ref p _racket)]) - (and wb - (weak-box-value (if (pair? wb) - (car wb) - wb))))]) - (and wx - (send wx is-hwnd? hwnd) - wx))))) + (and + (atomically (hash-ref all-hwnds (cast hwnd _pointer _long) #f)) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (and c + (let ([wx (let ([wb (ptr-ref c _racket)]) + (and wb + (weak-box-value (if (pair? wb) + (car wb) + wb))))]) + (and wx + (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)))) +;; call in atomic mode: +(define (unregister-hwnd? hwnd) + (let ([addr (cast hwnd _pointer _long)]) + (and (hash-ref all-hwnds addr #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) _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] [lpfnWndProc _fpointer] [cbClsExtra _int] @@ -120,14 +210,6 @@ #;(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 background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])