From c2ce22a9b7c574e121de2ca583aa6bc7aca0e050 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 31 Oct 2010 19:42:39 -0600 Subject: [PATCH] win32: further deallocation fixes, plus some test fixes original commit: f8294247833a45371a62a3ac050069e1b3c3bcb1 --- collects/mred/private/wx/win32/dialog.rkt | 22 +-- collects/mred/private/wx/win32/slider.rkt | 32 ++-- collects/mred/private/wx/win32/types.rkt | 2 + collects/mred/private/wx/win32/wndclass.rkt | 160 ++++++++++++-------- 4 files changed, 115 insertions(+), 101 deletions(-) diff --git a/collects/mred/private/wx/win32/dialog.rkt b/collects/mred/private/wx/win32/dialog.rkt index b3e8a887..c249f2f9 100644 --- a/collects/mred/private/wx/win32/dialog.rkt +++ b/collects/mred/private/wx/win32/dialog.rkt @@ -28,27 +28,8 @@ [class _short] ; 0 [title _short])) ; 0 -(define _INT_PTR _long) -(define _DialogProc (_wfun _HWND _UINT _WPARAM _LPARAM -> _INT_PTR)) - - (define DS_MODALFRAME #x80) -(define-user32 CreateDialogIndirectParamW (_wfun _HINSTANCE - _DLGTEMPLATE-pointer - _HWND - _fpointer - -> _HWND)) - -(define (dlgproc w msg wParam lParam) - (let ([wx (hwnd->wx w)]) - (if wx - (send wx wndproc w msg wParam lParam - (lambda (w msg wParam lParam) 0)) - 0))) - -(define dialog-proc (function-ptr dlgproc _DialogProc)) - (define dialog% (class (dialog-mixin frame%) (super-new) @@ -62,7 +43,8 @@ 0 0 w h 0 0 0) (and parent (send parent get-hwnd)) - dialog-proc)]) + dialog-proc + 0)]) (SetWindowTextW hwnd label) (MoveWindow hwnd 0 0 w h #t) hwnd)) diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index efecc60d..6f003c63 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -59,22 +59,22 @@ #f))) (define slider-hwnd - (CreateWindowExW 0 - "PLTmsctls_trackbar32" - label - (bitwise-ior WS_CHILD WS_CLIPSIBLINGS - (if vertical? - TBS_VERT - TBS_HORZ) - (if panel-hwnd - WS_VISIBLE - 0)) - 0 0 0 0 - (or panel-hwnd - (send parent get-client-hwnd)) - #f - hInstance - #f)) + (CreateWindowExW/control 0 + "PLTmsctls_trackbar32" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS + (if vertical? + TBS_VERT + TBS_HORZ) + (if panel-hwnd + WS_VISIBLE + 0)) + 0 0 0 0 + (or panel-hwnd + (send parent get-client-hwnd)) + #f + hInstance + #f)) (define value-hwnd (and panel-hwnd diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index 1ef78ccf..cc29d864 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -21,6 +21,7 @@ _HRESULT _WCHAR _SIZE_T + _INT_PTR _HINSTANCE _HWND @@ -66,6 +67,7 @@ (define _HRESULT _int32) (define _WCHAR _int16) (define _SIZE_T _long) +(define _INT_PTR _intptr) (define _HINSTANCE (_cpointer/null 'HINSTANCE)) (define _HWND (_cpointer/null 'HWND)) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 1f0da158..378aa3be 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -19,6 +19,7 @@ any-hwnd->wx CreateWindowExW CreateWindowExW/control + CreateDialogIndirectParamW dialog-proc clean-up-destroyed MessageBoxW _WndProc)) @@ -29,73 +30,63 @@ ;; The weak pointer must be wrapped in an immuable cell. ;; In addition, if we need to save a control's old ;; ctlproc, we put it in the same immutable cell. -;; So: -;; = (make-immutable-cell ) -;; = -;; | (cons ) -;; = (make-weak-box ) (define all-hwnds (make-hash)) ;; call in atomic mode: (define (register-hwnd! hwnd) - (hash-set! all-hwnds (cast hwnd _pointer _long) hwnd)) - -;; 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)))) - + (hash-set! all-hwnds (cast hwnd _pointer _long) #t) + (let ([c (malloc-immobile-cell (vector #f #f #f))]) + (void (SetWindowLongW hwnd GWLP_USERDATA c)))) + (define (set-hwnd-wx! hwnd wx) - (let* ([c (atomically (alloc-hwnd-cell hwnd))] + (let* ([c (GetWindowLongW hwnd GWLP_USERDATA)] [v (ptr-ref c _racket)]) - (ptr-set! c _racket (cons (make-weak-box wx) - (and v (cdr v)))))) + (vector-set! v 0 (make-weak-box wx)))) -(define (set-hwnd-ctlproc! hwnd ctlproc) - (let* ([c (atomically (alloc-hwnd-cell hwnd))] +(define (set-hwnd-ctlproc! hwnd save-ptr ctlproc) + (let* ([c (GetWindowLongW hwnd GWLP_USERDATA)] [v (ptr-ref c _racket)]) - (ptr-set! c _racket (cons (and v (car v)) - ctlproc)))) + (vector-set! v 1 ctlproc) + (vector-set! v 2 save-ptr))) (define (hwnd->wx hwnd) (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) - (and c (let ([wb (ptr-ref c _racket)]) - (and wb - (car wb) - (weak-box-value (car wb))))))) - -(define (hwnd->ctlproc hwnd) - (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) - (and c (let ([wb (ptr-ref c _racket)]) - (and wb (cdr wb)))))) + (and c (let ([v (ptr-ref c _racket)]) + (and v + (let ([wb (vector-ref v 0)]) + (and wb + (weak-box-value wb)))))))) (define (any-hwnd->wx hwnd) (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 - (car wb) - (weak-box-value (car wb))))]) - (and wx - (send wx is-hwnd? hwnd) - wx)))))) + (let ([wx (hwnd->wx hwnd)]) + (and wx + (send wx is-hwnd? hwnd) + wx)))) + +(define (hwnd->ctlproc hwnd) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (and c (let ([v (ptr-ref c _racket)]) + (and v (vector-ref v 1)))))) + +(define (hwnd->ctlproc-fptr hwnd) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (and c (let ([v (ptr-ref c _racket)]) + (and v (vector-ref v 2)))))) ;; call in atomic mode: -(define (unregister-hwnd? hwnd [same? (lambda (v) (eq? v hwnd))]) - (let ([addr (cast hwnd _pointer _long)]) - (and (same? (hash-ref all-hwnds addr #f)) - (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) - (when c - (free-immobile-cell c) - (SetWindowLongW hwnd GWLP_USERDATA #f)) - (hash-remove! all-hwnds addr) - #t)))) +(define (can-unregister-hwnd? hwnd) + (hash-ref all-hwnds (cast hwnd _pointer _long) #f)) + +;; call in atomic mode: +(define (unregister-hwnd! hwnd) + (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) + (when c + (free-immobile-cell c) + (SetWindowLongW hwnd GWLP_USERDATA #f)) + (hash-remove! all-hwnds (cast hwnd _pointer _long)))) ;; ---------------------------------------- @@ -118,7 +109,7 @@ (define (wind-proc w msg wparam lparam) (if (= msg WM_DESTROY) (begin - (unregister-hwnd? w (lambda (x) x)) + (unregister-hwnd! w) (DefWindowProcW w msg wparam lparam)) (let ([wx (hwnd->wx w)]) (if wx @@ -128,25 +119,43 @@ (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 (lambda (x) x)) - (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)]) + (let ([default-ctlproc (hwnd->ctlproc w)]) + (if (= msg WM_DESTROY) + (begin + (SetWindowLongW w GWLP_WNDPROC (hwnd->ctlproc-fptr w)) + (unregister-hwnd! w) + (default-ctlproc w msg wParam lParam)) + (let ([wx (hwnd->wx w)]) + (if wx + (send wx ctlproc w msg wParam lParam + (lambda (w msg wParam lParam) + (default-ctlproc w msg wParam lParam))) (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) + (let* ([fptr (GetWindowLongW hwnd GWLP_WNDPROC)] + [old-control-proc (function-ptr fptr _WndProc)]) + (set-hwnd-ctlproc! hwnd fptr old-control-proc) (SetWindowLongW hwnd GWLP_WNDPROC control_proc))) + +(define _DialogProc (_wfun _HWND _UINT _WPARAM _LPARAM -> _INT_PTR)) + +(define (dlgproc w msg wParam lParam) + (if (= msg WM_DESTROY) + (begin + (unregister-hwnd! w) + 0) + (let ([wx (hwnd->wx w)]) + (if wx + (send wx wndproc w msg wParam lParam + (lambda (w msg wParam lParam) 0)) + 0)))) + +(define dialog-proc (function-ptr dlgproc _DialogProc)) + ;; ---------------------------------------- (define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL) @@ -154,7 +163,7 @@ (define (maybe-destroy-window hwnd) (atomically - (when (unregister-hwnd? hwnd) + (when (can-unregister-hwnd? hwnd) (DestroyWindow hwnd)))) (define (clean-up-destroyed) @@ -171,8 +180,12 @@ (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)]) + (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)))) @@ -181,6 +194,23 @@ (register-hwnd! hwnd) (subclass-control hwnd)))) + +(define-user32 _CreateDialogIndirectParamW (_wfun _HINSTANCE + _pointer ; _DLGTEMPLATE-pointer + _HWND + _fpointer + _LPARAM + -> _HWND) + #:c-id CreateDialogIndirectParamW) + +(define CreateDialogIndirectParamW + ((allocator remember-to-free-later) + (lambda (hInstance lpTemplate hWndParent lpDialogFunc lParamInit) + (let ([hwnd (_CreateDialogIndirectParamW + hInstance lpTemplate hWndParent lpDialogFunc lParamInit)]) + (register-hwnd! hwnd) + hwnd)))) + ;; ---------------------------------------- (define-cstruct _WNDCLASS ([style _UINT]