dialog show & button width fixes

collects/mred/private/app.rkt

@@ -42,7 +42,8 @@
 			 (dynamic-wind
 			     void
 			     (lambda ()
-			       (send af on-exit)
+                               (as-exit (lambda ()
+                                          (send af on-exit)))
 			       (unless (null? (wx:get-top-level-windows))
 				 (wx:cancel-quit)))
 			     (lambda () 

collects/mred/private/wx/cocoa/button.rkt

@@ -14,19 +14,22 @@
 (objc-unsafe!)
 
 (provide button%
+         core-button%
          MyButton)
 
 ;; ----------------------------------------
 
 (import-class NSButton NSView NSImageView)
 
+(define MIN-BUTTON-WIDTH 72)
+
 (define-objc-class MyButton NSButton
   #:mixins (FocusResponder)
   [wx]
   (-a _void (clicked: [_id sender])
       (queue-window-event wx (lambda () (send wx clicked)))))
 
-(defclass button% item%
+(defclass core-button% item%
   (init parent cb label x y w h style font
         [button-type #f])
   (init-field [event-type 'button])
@@ -55,6 +58,14 @@
         (tellv cocoa setTitle: #:type _NSString "<bad>")])
       (init-font cocoa font)
       (tellv cocoa sizeToFit)
+      (when (and (eq? event-type 'button)
+                 (string? label))
+        (let ([frame (tell #:type _NSRect cocoa frame)])
+          (when ((NSSize-width (NSRect-size frame)) . < . MIN-BUTTON-WIDTH)
+            (tellv cocoa setFrame: #:type _NSRect 
+                   (make-NSRect (NSRect-origin frame)
+                                (make-NSSize MIN-BUTTON-WIDTH
+                                             (NSSize-height (NSRect-size frame))))))))
       cocoa))
 
   (define cocoa (if (and button-type
@@ -119,3 +130,7 @@
                         [time-stamp (current-milliseconds)])))
   
   (def/public-unimplemented set-border))
+
+(define button%
+  (class core-button% (super-new)))
+

collects/mred/private/wx/cocoa/check-box.rkt

@@ -13,7 +13,7 @@
 
 ;; ----------------------------------------
 
-(defclass check-box% button%
+(defclass check-box% core-button%
   (inherit get-cocoa)
   (super-new [button-type NSSwitchButton]
              [event-type 'check-box])

collects/mred/private/wx/cocoa/dialog.rkt

@@ -2,6 +2,7 @@
 (require scheme/class
           "../../syntax.rkt"
           "../common/queue.rkt"
+          "../../lock.rkt"
          "frame.rkt")
 
 (provide dialog%)
@@ -13,19 +14,21 @@
 
   (define/override (direct-show on?)
     (unless on?
-      (when close-sema
-        (semaphore-post close-sema)
-        (set! close-sema #f)))
+      (as-entry
+       (lambda ()
+         (when close-sema
+           (semaphore-post close-sema)
+           (set! close-sema #f)))))
     (super direct-show on?))
 
   (define/override (show on?)
     (if on?
-        (unless close-sema
-          (let ([s (make-semaphore)])
-            (set! close-sema s)
-            (super show on?)
-            (yield s)))
+        (let ([s (as-entry
+                  (lambda ()
+                    (let ([s (or close-sema (make-semaphore))])
+                      (unless close-sema (set! close-sema s))
+                      s)))])
+          (super show on?)
+          (yield s)
+          (void))
         (super show on?))))
-
-    
-

collects/mred/private/wx/cocoa/queue.rkt

@@ -200,6 +200,8 @@
                                (custodian-shutdown-all c)))))))
       (set! was-menu-bar #f)))
 
+(define o (current-error-port))
+
 ;; Call this function only in atomic mode:
 (define (check-one-event wait? dequeue?)
   (pre-event-sync wait?)

collects/mred/private/wx/common/queue.rkt

@@ -333,4 +333,5 @@
             (lambda (k v) k)))
 
 (define (queue-quit-event)
+  ;; called in event-pump thread
   (queue-event main-eventspace (application-quit-handler) 'med))

collects/racket/draw/lock.rkt

@@ -4,7 +4,10 @@
 
 (provide (protect-out as-entry
                       as-exit
-                      entry-point))
+                      entry-point
+
+                      inside-lock?
+                      any-lock?))
 
 ;; We need atomic mode for a couple of reasons:
 ;;
@@ -123,3 +126,8 @@
        (syntax (case-lambda 
                 [vars (as-entry (lambda () body1 body ...))]
                 ...))])))
+
+;; For debugging: 
+(define (inside-lock?) (eq? monitor-owner (current-thread)))
+(define (any-lock?) (and monitor-owner #t))
+