win32 memory-management repair

original commit: 9b19337c971658b3c65c3869d61c691defd2a72e

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)))
+                ((hwnd->ctlproc w) w msg wParam lParam)))
-        (send wx default-ctlproc 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)
+        (set-hwnd-ctlproc! hwnd old-control-proc)
-                                      old-control-procs))
         (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))
+      (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))])))))
 
 (define item% 
   (class (item-mixin window%)

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)

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,

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)

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:
+;;  <user-data>   = (make-immutable-cell <remembered>)
+;;  <remembered>  = <wx-weak-box>
+;;                | (cons <ctlproc> <wx-weak-box>)
+;;  <wx-weak-box> = (make-weak-box <object%>)
 
 (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)))))