diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index a290834db2..4b18d545ba 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -240,6 +240,11 @@ (check-style cwho #f '(no-caption resize-border no-sheet close-button) style))) (rename [super-on-subwindow-char on-subwindow-char]) (private-field [wx #f]) + (public + [show-without-yield (lambda () + (as-entry + (lambda () + (send wx call-show #t (lambda () (send wx show-without-yield))))))]) (override [on-subwindow-char (lambda (w event) (super-on-subwindow-char w event) diff --git a/collects/mred/private/wx/common/dialog.rkt b/collects/mred/private/wx/common/dialog.rkt index 319b265f22..834e869549 100644 --- a/collects/mred/private/wx/common/dialog.rkt +++ b/collects/mred/private/wx/common/dialog.rkt @@ -12,6 +12,7 @@ (super-new) (define close-sema #f) + (define close-sema-ready? #f) (define dialog-level 0) (define/override (get-dialog-level) dialog-level) @@ -31,17 +32,32 @@ (unless on? (set! dialog-level 0)) (unless on? - (when close-sema + (when close-sema-ready? (semaphore-post close-sema) - (set! close-sema #f))) + (set! close-sema #f) + (set! close-sema-ready? #f))) + (when on? + ;; mark `close-sema' as having a corresponding `show #t' + ;; so that a future `show #f' can clear it; without this + ;; extra flag, `close-sema' could be set, `show #f' could + ;; post it, and then the `show #t' that created hte sema + ;; could happen after the `show #f' + (set! close-sema-ready? #t)) (super direct-show on?)) + (define/private (get-show-semaphore) + (atomically + (let ([s (or close-sema (make-semaphore))]) + (unless close-sema (set! close-sema s)) + (semaphore-peek-evt s)))) + + (define/public (show-without-yield) + (get-show-semaphore) ; in case some other thread wants to wait + (super show #t)) + (define/override (show on?) (if on? - (let ([s (atomically - (let ([s (or close-sema (make-semaphore))]) - (unless close-sema (set! close-sema s)) - (semaphore-peek-evt s)))]) + (let ([s (get-show-semaphore)]) (super show on?) (yield s) (void)) diff --git a/collects/mred/private/wxtop.rkt b/collects/mred/private/wxtop.rkt index 022cf962bd..cda7b38b39 100644 --- a/collects/mred/private/wxtop.rkt +++ b/collects/mred/private/wxtop.rkt @@ -346,6 +346,17 @@ 1 1) (set! already-trying? #f) (resized)]))))))]) + + (public + [call-show + (lambda (on? do-show) + (when on? + (position-for-initial-show)) + (if on? + (hash-table-put! top-level-windows this #t) + (hash-table-remove! top-level-windows this)) + (as-exit ; as-exit because there's an implicit wx:yield for dialogs + do-show))]) (override ;; show: add capability to set perform-updates @@ -356,12 +367,8 @@ ;; pass now to superclass's show. [show (lambda (on?) - (when on? - (position-for-initial-show)) - (if on? - (hash-table-put! top-level-windows this #t) - (hash-table-remove! top-level-windows this)) - (as-exit ; as-exit because there's an implicit wx:yield for dialogs + (call-show + on? (lambda () (super show on?))))] [on-visible diff --git a/collects/scribblings/gui/dialog-class.scrbl b/collects/scribblings/gui/dialog-class.scrbl index 15df432952..983ffd2912 100644 --- a/collects/scribblings/gui/dialog-class.scrbl +++ b/collects/scribblings/gui/dialog-class.scrbl @@ -114,4 +114,11 @@ If @scheme[show?] is true, the method does not immediately return. Instead, method returns as soon as possible after the dialog is hidden. } + +@defmethod[(show-without-yield) + void?]{ + +Like @racket[(send @#,this-obj[] @#,method[dialog% show] #t)], but returns +immediately instead of @racket[yield]ing.} + }