diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index 04ba7784..d9a18b8e 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -20,8 +20,9 @@ (if wx (send wx ctlproc w msg wParam lParam (lambda (w msg wParam lParam) - (send wx default-ctlproc w msg wParam lParam))) - (send wx default-ctlproc 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)) @@ -36,14 +37,11 @@ (define/public (command e) (callback this e)) - (define old-control-procs null) - (super-new) (define/public (subclass-control hwnd) (let ([old-control-proc (function-ptr (GetWindowLongW hwnd GWLP_WNDPROC) _WndProc)]) - (set! old-control-procs (cons (cons hwnd old-control-proc) - old-control-procs)) + (set-hwnd-ctlproc! hwnd old-control-proc) (SetWindowLongW hwnd GWLP_WNDPROC control_proc))) (define/public (ctlproc w msg wParam lParam default) @@ -60,15 +58,7 @@ (wndproc-for-ctlproc w msg wParam lParam default)]))) (define/public (wndproc-for-ctlproc w msg wParam lParam default) - (wndproc w msg wParam lParam default)) - - (define/public (default-ctlproc w msg wParam lParam) - (let loop ([l old-control-procs]) - (cond - [(null? l) (error 'default-ctlproc "cannot find control in: ~e for: ~e" this w)] - [(ptr-equal? (caar l) w) - ((cdar l) w msg wParam lParam)] - [else (loop (cdr l))]))))) + (wndproc w msg wParam lParam default)))) (define item% (class (item-mixin window%) diff --git a/collects/mred/private/wx/win32/menu-item.rkt b/collects/mred/private/wx/win32/menu-item.rkt index 6141375a..c974b6ae 100644 --- a/collects/mred/private/wx/win32/menu-item.rkt +++ b/collects/mred/private/wx/win32/menu-item.rkt @@ -4,6 +4,7 @@ "utils.rkt" "types.rkt" "const.rkt" + "../../lock.rkt" "../../syntax.rkt") (provide menu-item% @@ -14,7 +15,7 @@ (define ids (make-hash)) (define (id-to-menu-item id) - (let ([wb (hash-ref ids id #f)]) + (let ([wb (atomically (hash-ref ids id #f))]) (and wb (weak-box-value wb)))) (defclass menu-item% object% @@ -22,12 +23,12 @@ (define id (let loop () (let ([id (add1 (random #x7FFE))]) - (let ([wb (hash-ref ids id #f)]) + (let ([wb (atomically (hash-ref ids id #f))]) (if (and wb (weak-box-value wb)) (loop) (begin - (hash-set! ids id (make-weak-box this)) + (atomically (hash-set! ids id (make-weak-box this))) id)))))) (define parent #f) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index ca8e3035..7fd628d4 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -88,6 +88,7 @@ (free-msg msg)))) (define (queue-message-dequeue es hwnd) + ;; in atomic mode (let ([t (eventspace-extra-table es)] [id (cast hwnd _HWND _long)]) (unless (hash-ref t id #f) @@ -98,6 +99,7 @@ (define msg (malloc-msg)) (define (check-window-event hwnd data) + ;; in atomic mode (let* ([root (let loop ([hwnd hwnd]) (let ([p (GetWindow hwnd GW_OWNER)]) (if p @@ -123,6 +125,7 @@ (define check_window_event (function-ptr check-window-event _enum_proc)) (define (dispatch-all-ready) + ;; in atomic mode (pre-event-sync #f) ;; Windows uses messages above #x4000 to hilite items in the task bar, diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 88c3a53f..f6771c81 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -174,7 +174,7 @@ [cmd (LOWORD (NMHDR-code nmhdr))]) (if (and wx (send wx is-command? cmd)) (begin - (send wx do-command control-hwnd) + (send wx do-command cmd control-hwnd) 0) (default w msg wParam lParam)))] [(or (= msg WM_HSCROLL) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index d789de66..ba0b187e 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -10,31 +10,62 @@ (provide hInstance DefWindowProcW background-hbrush - hwnd->wx - any-hwnd->wx set-hwnd-wx! - unregister-hwnd + set-hwnd-ctlproc! + hwnd->wx + hwnd->ctlproc + any-hwnd->wx + unregister-hwnd MessageBoxW _WndProc) ;; ---------------------------------------- +;; We use the "user data" field of an HWND to +;; store a weak pointer back to the Racket object. +;; 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-cells (make-hash)) -(define (hwnd->wx hwnd) - (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) - (and p (ptr-ref p _racket)))) - (define (set-hwnd-wx! hwnd wx) - (let ([c (malloc-immobile-cell 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)))) +(define (set-hwnd-ctlproc! hwnd ctlproc) + (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) + (ptr-set! p _racket (cons (ptr-ref p _racket) ctlproc)))) + +(define (hwnd->wx hwnd) + (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) + (and p (let ([wb (ptr-ref p _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)]) + (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 (ptr-ref p _racket)]) + (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)))))