From 238650e3270706715af4abc43639ffa5a98e188e Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 24 Jul 2010 18:33:36 -0500
Subject: [PATCH] more repairs to constrained-reply and menu-bar handling

---
 collects/mred/private/wx/cocoa/menu-bar.rkt |  9 +---
 collects/mred/private/wx/cocoa/queue.rkt    | 57 +++++++++++----------
 collects/mred/private/wx/common/freeze.rkt  |  5 +-
 collects/racket/draw/lock.rkt               |  7 ++-
 4 files changed, 40 insertions(+), 38 deletions(-)

diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt
index 60eb4bb822..68b09544c9 100644
--- a/collects/mred/private/wx/cocoa/menu-bar.rkt
+++ b/collects/mred/private/wx/cocoa/menu-bar.rkt
@@ -59,14 +59,7 @@
         (and (<= x (NSPoint-x p) (+ x w))
              (<= (- y h) (NSPoint-y p) y)))))))
 
-(define suspend-menu-bar
-  (lambda (on?)
-    ;; We don't actually suspend anything, since the MrEd layer
-    ;; will drop events that shouldn't be delivered.
-    (void)))
-
-(set-menu-bar-hooks! in-menu-bar-range
-                     suspend-menu-bar)
+(set-menu-bar-hooks! in-menu-bar-range)
 
 ;; Init menu bar
 (let ([app (tell NSApplication sharedApplication)]
diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt
index dddec0dfb7..08f9b7f834 100644
--- a/collects/mred/private/wx/cocoa/queue.rkt
+++ b/collects/mred/private/wx/cocoa/queue.rkt
@@ -162,42 +162,47 @@
 (define (set-front-hook! proc) (set! front-hook proc))
 
 (define in-menu-bar-range? (lambda (p) #f))
-(define suspend-menu-bar (lambda (suspend?) (void)))
-(define (set-menu-bar-hooks! r? s) 
-  (set! in-menu-bar-range? r?)
-  (set! suspend-menu-bar s))
+(define (set-menu-bar-hooks! r?) 
+  (set! in-menu-bar-range? r?))
 
 (define events-suspended? #f)
+(define was-menu-bar #f)
 
 (define (check-menu-bar-click evt)
-  (when (and evt 
-             (= 14 (tell #:type _NSUInteger evt type))
-             (= 7 (tell #:type _short evt subtype))
-             (not (tell evt window))
-             (in-menu-bar-range? (tell #:type _NSPoint evt locationInWindow)))
-    ;; Mouse down in the menu bar:
-    (let-values ([(f e) (front-hook)])
-      (when e
-        ;; Don't handle further events until we've made an effort
-        ;; at on-demand notifications.
-        (set! events-suspended? #t)
-        (let ([t (thread (lambda ()
-                           (sleep 2)
-                           ;; on-demand took too long, so disable the menu bar
-                           ;; until the application can catch up
-                           (suspend-menu-bar #t)
-                           (set! events-suspended? #f)))])
-          (queue-event e (lambda ()
-                           (send f on-menu-click)
-                           (set! events-suspended? #f)
-                           (kill-thread t))))))))
+  (if (and evt 
+           (= 14 (tell #:type _NSUInteger evt type))
+           (= 7 (tell #:type _short evt subtype))
+           (not (tell evt window))
+           (in-menu-bar-range? (tell #:type _NSPoint evt locationInWindow)))
+      ;; Mouse down in the menu bar:
+      (let-values ([(f e) (front-hook)])
+        (when e
+          ;; Avoid spiral of on-demand calls:
+          (unless (and was-menu-bar
+                       (eq? e (weak-box-value was-menu-bar)))
+            ;; Don't handle further events until we've made an effort
+            ;; at on-demand notifications.
+            (set! was-menu-bar (make-weak-box e))
+            (set! events-suspended? #t)
+            (let* ([c (make-custodian)]
+                   [t (parameterize ([current-custodian c])
+                        (thread (lambda ()
+                                  (sleep 2)
+                                  ;; on-demand took too long, so wait
+                                  ;; until the application can catch up
+                                  (set! events-suspended? #f))))])
+              (queue-event e (lambda ()
+                               (send f on-menu-click)
+                               (set! events-suspended? #f)
+                               (custodian-shutdown-all c)))))))
+      (set! was-menu-bar #f)))
 
 ;; Call this function only in atomic mode:
 (define (check-one-event wait? dequeue?)
   (pre-event-sync wait?)
   (let ([pool (tell (tell NSAutoreleasePool alloc) init)])
     (when (and events-suspended? wait?)
-      (suspend-menu-bar #t)
+      (set! was-menu-bar #f)
       (set! events-suspended? #f))
     (begin0
      (let ([evt (if events-suspended?
diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt
index 2dabeb9381..4c03a4c48b 100644
--- a/collects/mred/private/wx/common/freeze.rkt
+++ b/collects/mred/private/wx/common/freeze.rkt
@@ -61,15 +61,14 @@
                                     freeze-tag
                                     (lambda () default)))
                                  freeze-tag)
-                                (void)))]
-                   [old (scheme_set_on_atomic_timeout handler)])
+                                (void)))])
               (with-holding 
                handler
                (call-with-continuation-prompt ; to catch aborts
                 (lambda ()
                   (call-with-continuation-prompt ; for composable continuation
                    (lambda ()
-                     (set! prev old)
+                     (set! prev (scheme_set_on_atomic_timeout handler))
                      (set! ready? #t)
                      (begin0
                       (parameterize ([freezer-box #f])
diff --git a/collects/racket/draw/lock.rkt b/collects/racket/draw/lock.rkt
index 5462bb44e2..c66ff9c0d8 100644
--- a/collects/racket/draw/lock.rkt
+++ b/collects/racket/draw/lock.rkt
@@ -48,7 +48,12 @@
 (define (as-entry f)
   (cond
    [(eq? monitor-owner (current-thread))
-    (f)]
+    ;; Need to increment atomicity level for cooperation with
+    ;; freezing speculative computations (in mred/private/wx/common/freeze)
+    (dynamic-wind
+        start-atomic
+        f
+        end-atomic)]
    [else
     (with-continuation-mark 
         exited-key