diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 6d5470bd12..b6bfe1eaff 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -12,6 +12,7 @@ "dc.rkt" "queue.rkt" "item.rkt" + "../common/backing-dc.rkt" "../common/event.rkt" "../common/queue.rkt" "../../syntax.rkt" @@ -26,26 +27,29 @@ (import-protocol NSComboBoxDelegate) +;; Called when a canvas has no backing store ready +(define (clear-background wx) + (let ([bg (send wx get-canvas-background-for-clearing)]) + (when bg + (let ([ctx (tell NSGraphicsContext currentContext)]) + (tellv ctx saveGraphicsState) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] + [adj (lambda (v) (/ v 255.0))]) + (CGContextSetRGBFillColor cg + (adj (color-red bg)) + (adj (color-blue bg)) + (adj (color-green bg)) + 1.0) + (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) + (make-NSSize 32000 32000)))) + (tellv ctx restoreGraphicsState))))) + (define-objc-class MyView NSView #:mixins (FocusResponder KeyMouseResponder) [wx] (-a _void (drawRect: [_NSRect r]) - (unless (send wx reject-partial-update r) - (let ([bg (send wx get-canvas-background-for-clearing)]) - (when bg - (let ([ctx (tell NSGraphicsContext currentContext)]) - (tellv ctx saveGraphicsState) - (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] - [adj (lambda (v) (/ v 255.0))]) - (CGContextSetRGBFillColor cg - (adj (color-red bg)) - (adj (color-blue bg)) - (adj (color-green bg)) - 1.0) - (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) - (make-NSSize 32000 32000)))) - (tellv ctx restoreGraphicsState)))) - (send wx queue-paint) + (unless (send wx paint-or-queue-paint) + (clear-background wx) ;; ensure that `nextEventMatchingMask:' returns (post-dummy-event))) (-a _void (viewWillMoveToWindow: [_id w]) @@ -117,24 +121,11 @@ [wx] (-a _void (drawRect: [_NSRect r]) (super-tell #:type _void drawRect: #:type _NSRect r) - (unless (send wx during-menu-click?) - (let ([bg (send wx get-canvas-background-for-clearing)]) - (when bg - (let ([ctx (tell NSGraphicsContext currentContext)]) - (tellv ctx saveGraphicsState) - (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] - [adj (lambda (v) (/ v 255.0))]) - (CGContextSetRGBFillColor cg - (adj (color-red bg)) - (adj (color-blue bg)) - (adj (color-green bg)) - 1.0) - (CGContextFillRect cg (make-NSRect (make-NSPoint 0 0) - (make-NSSize 32000 32000)))) - (tellv ctx restoreGraphicsState)))) - (send wx queue-paint) - ;; ensure that `nextEventMatchingMask:' returns - (post-dummy-event))) + (unless (send wx paint-or-queue-paint) + (unless (send wx during-menu-click?) + (clear-background wx) + ;; ensure that `nextEventMatchingMask:' returns + (post-dummy-event)))) (-a _void (comboBoxWillPopUp: [_id notification]) (send wx starting-combo)) (-a _void (comboBoxWillDismiss: [_id notification]) @@ -154,7 +145,7 @@ [ignored-name #f] [gl-config #f]) - (inherit get-cocoa + (inherit get-cocoa get-cocoa-window get-eventspace make-graphics-context is-shown-to-root? @@ -173,55 +164,69 @@ (define virtual-height #f) (define virtual-width #f) + (define is-combo? (memq 'combo style)) + (define has-control-border? (and (not is-combo?) + (memq 'control-border style))) + (define-values (x-margin y-margin x-sb-margin y-sb-margin) (cond - [(memq 'control-border style) (values 3 3 3 3)] + [has-control-border? (values 3 3 3 3)] [(memq 'border style) (values 1 1 0 0)] [else (values 0 0 0 0)])) (define canvas-style style) (define/override (focus-is-on on?) - (when (memq 'control-border canvas-style) + (when has-control-border? (tellv cocoa setFocusState: #:type _BOOL on?) - (tellv cocoa setNeedsDisplay: #:type _BOOL #t))) + (tellv cocoa setNeedsDisplay: #:type _BOOL #t)) + (super focus-is-on on?)) ;; Avoid multiple queued paints: (define paint-queued? #f) - ;; To handle paint requests that happen while on-paint - ;; is being called already: - (define now-drawing? #f) - (define refresh-after-drawing? #f) (define/public (queue-paint) ;; can be called from any thread, including the event-pump thread (unless paint-queued? (set! paint-queued? #t) - (queue-window-event this (lambda () - (set! paint-queued? #f) - (when (is-shown-to-root?) - (set! now-drawing? #t) - (fix-dc) - (on-paint) - (set! now-drawing? #f) - (when refresh-after-drawing? - (set! refresh-after-drawing? #f) - (refresh))))))) + (let ([req (request-flush-delay (get-cocoa-window))]) + (queue-window-event this (lambda () + (set! paint-queued? #f) + (when (is-shown-to-root?) + (send dc reset-backing-retained) ; start with a clean slate + (let ([bg (get-canvas-background)]) + (when bg + (let ([old-bg (send dc get-background)]) + (send dc set-background bg) + (send dc clear) + (send dc set-background old-bg)))) + (on-paint) + (queue-backing-flush) + (cancel-flush-delay req))))))) + + (define/public (paint-or-queue-paint) + (or (do-backing-flush this dc (tell NSGraphicsContext currentContext) + (if is-combo? 2 0) (if is-combo? 2 0)) + (begin + (queue-paint) + #f))) + (define/override (refresh) ;; can be called from any thread, including the event-pump thread + (queue-paint)) + + (define/public (queue-backing-flush) (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)) (define/override (get-cocoa-content) content-cocoa) - (define is-combo? (memq 'combo style)) - (super-new [parent parent] [cocoa (as-objc-allocation (tell (tell (cond [is-combo? NSView] - [(memq 'control-border style) FocusView] + [has-control-border? FocusView] [(memq 'border style) (if (memq 'vscroll style) CornerlessFrameView FrameView)] @@ -249,34 +254,18 @@ (tellv content-cocoa setDelegate: content-cocoa) (install-control-font content-cocoa #f)) - (define dc (make-object dc% (make-graphics-context) 0 0 10 10 - (lambda () - (let ([w (box 0)] - [h (box 0)]) - (get-virtual-size w h) - (values (unbox w) (unbox h)))))) + (define dc (make-object dc% this)) + + (send dc start-backing-retained) (queue-paint) (define/public (get-dc) dc) - (define/public (fix-dc) + (define/public (fix-dc [refresh? #t]) (when (dc . is-a? . dc%) - (if (is-shown-to-before-root?) - (let ([p (tell #:type _NSPoint content-cocoa - convertPoint: #:type _NSPoint (make-NSPoint 0 0) - toView: #f)] - [xb (box 0)] - [yb (box 0)]) - (get-client-size xb yb) - (send dc reset-bounds - (+ (NSPoint-x p) (if is-combo? 2 0)) - (- (NSPoint-y p) (if is-combo? 22 0)) - (max 1 (- (unbox xb) (if is-combo? 22 0))) - (unbox yb) - (if auto-scroll? (scroll-pos h-scroller) 0) - (if auto-scroll? (scroll-pos v-scroller) 0))) - (send dc reset-bounds 0 0 0 0 0 0)))) + (send dc reset-backing-retained)) + (when refresh? (refresh))) (define/override (get-client-size xb yb) (super get-client-size xb yb) @@ -532,13 +521,9 @@ bg-col)) (define/public (set-canvas-background col) (set! bg-col col)) (define/public (get-canvas-background-for-clearing) - (if now-drawing? - (begin - (set! refresh-after-drawing? #t) - #f) - (and (not (memq 'transparent canvas-style)) - (not (memq 'no-autoclear canvas-style)) - bg-col))) + (and (not (memq 'transparent canvas-style)) + (not (memq 'no-autoclear canvas-style)) + bg-col)) (define/public (reject-partial-update r) ;; Called in the event-pump thread. @@ -657,6 +642,14 @@ (define/public (set-resize-corner on?) (void)) + (define/public (get-backing-size xb yb) + (get-client-size xb yb) + (when is-combo? + (set-box! xb (- (unbox xb) 22)))) + + (define/public (is-flipped?) + (tell #:type _BOOL (get-cocoa-content) isFlipped)) + (define/public (get-virtual-size xb yb) (get-client-size xb yb) (when virtual-width (set-box! xb virtual-width)) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index dd55ba0dc3..bfe3c8c90f 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -1,16 +1,19 @@ #lang racket/base -(require ffi/unsafe/objc +(require racket/class ffi/unsafe - racket/class - "utils.rkt" - "types.rkt" + ffi/unsafe/objc racket/draw/cairo - racket/draw/dc racket/draw/local + "types.rkt" + "utils.rkt" + "window.rkt" + "../../lock.rkt" "../common/queue.rkt" - "../../syntax.rkt") + "../common/backing-dc.rkt") (provide dc% + do-backing-flush + _CGContextRef CGContextSetRGBFillColor CGContextFillRect @@ -19,79 +22,79 @@ CGContextAddLines) (define _CGContextRef (_cpointer 'CGContextRef)) +(define-appserv CGContextSynchronize (_fun _CGContextRef -> _void)) (define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) (define-appserv CGContextScaleCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) -(define-appserv CGContextFlush (_fun _CGContextRef -> _void)) +(define-appserv CGContextSaveGState (_fun _CGContextRef -> _void)) +(define-appserv CGContextRestoreGState (_fun _CGContextRef -> _void)) (define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void)) (define-appserv CGContextFillRect (_fun _CGContextRef _NSRect -> _void)) (define-appserv CGContextAddRect (_fun _CGContextRef _NSRect -> _void)) (define-appserv CGContextAddLines (_fun _CGContextRef (v : (_vector i _NSPoint)) (_long = (vector-length v)) -> _void)) (define-appserv CGContextStrokePath (_fun _CGContextRef -> _void)) -(define-appserv CGContextConvertPointToUserSpace (_fun _CGContextRef _NSPoint -> _NSPoint)) -(define-appserv CGContextConvertSizeToUserSpace (_fun _CGContextRef _NSSize -> _NSSize)) - -(define dc-backend% - (class* default-dc-backend% (dc-backend<%>) - (init context dx dy width height -get-virtual-size) - (super-new) - - (inherit reset-cr set-auto-scroll) - - (define the-context context) ;; retain as long as we need `cg' - (define cg (tell #:type _CGContextRef context graphicsPort)) - - (define old-dx 0) - (define old-dy 0) - - (define/private (set-bounds dx dy width height) - (set! old-dx dx) - (set! old-dy (+ dy height)) - (CGContextTranslateCTM cg old-dx old-dy) - (CGContextScaleCTM cg 1 -1) - (let ([surface (cairo_quartz_surface_create_for_cg_context cg width height)]) - (set! cr (cairo_create surface)) - (cairo_surface_destroy surface)) - (set! clip-width width) - (set! clip-height height) - (reset-clip cr)) - - (define clip-width width) - (define clip-height height) - - (define/override (reset-clip cr) - (super reset-clip cr) - (let ([m (make-cairo_matrix_t 0 0 0 0 0 0)]) - (cairo_get_matrix cr m) - (cairo_set_matrix cr (make-cairo_matrix_t 1 0 0 1 0 0)) - (cairo_rectangle cr 0 0 clip-width clip-height) - (cairo_clip cr) - (cairo_set_matrix cr m))) - - (define cr #f) - (set-bounds dx dy width height) - - (define/public (reset-bounds dx dy width height auto-dx auto-dy) - (let ([old-cr cr]) - (when old-cr - (set! cr #f) - (cairo_destroy old-cr))) - (set-auto-scroll auto-dx auto-dy) - (CGContextScaleCTM cg 1 -1) - (CGContextTranslateCTM cg (- old-dx) (- old-dy)) - (set-bounds dx dy width height) - (reset-cr cr)) - - (define get-virtual-size -get-virtual-size) - (def/override (get-size) - (let-values ([(w h) (get-virtual-size)]) - (values (exact->inexact w) - (exact->inexact h)))) - - (define/override (get-cr) cr) - - (define/override (flush-cr) - (add-event-boundary-sometimes-callback! cg CGContextFlush)))) (define dc% - (dc-mixin dc-backend%)) + (class backing-dc% + (init [(cnvs canvas)]) + (define canvas cnvs) + (super-new) + + (define/override (get-backing-size xb yb) + (send canvas get-backing-size xb yb)) + + (define/override (get-size) + (let ([xb (box 0)] + [yb (box 0)]) + (send canvas get-virtual-size xb yb) + (values (unbox xb) (unbox yb)))) + + (define/override (queue-backing-flush) + (send canvas queue-backing-flush)) + + (define suspend-count 0) + (define req #f) + + (define/override (suspend-flush) + (as-entry + (lambda () + (when (zero? suspend-count) + (set! req (request-flush-delay (send canvas get-cocoa-window)))) + (set! suspend-count (add1 suspend-count)) + (super suspend-flush)))) + + (define/override (resume-flush) + (as-entry + (lambda () + (set! suspend-count (sub1 suspend-count)) + (when (and (zero? suspend-count) req) + (cancel-flush-delay req) + (set! req #f)) + (super resume-flush)))))) + +(define (do-backing-flush canvas dc ctx dx dy) + (tellv ctx saveGraphicsState) + (begin0 + (send dc on-backing-flush + (lambda (bm) + (let ([w (box 0)] + [h (box 0)]) + (send canvas get-client-size w h) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]) + (unless (send canvas is-flipped?) + (CGContextTranslateCTM cg 0 (unbox h)) + (CGContextScaleCTM cg 1 -1)) + (CGContextTranslateCTM cg dx dy) + (let* ([surface (cairo_quartz_surface_create_for_cg_context cg (unbox w) (unbox h))] + [cr (cairo_create surface)]) + (cairo_surface_destroy surface) + (let ([s (cairo_get_source cr)]) + (cairo_pattern_reference s) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 (unbox w) (unbox h)) + (cairo_fill cr) + (cairo_set_source cr s) + (cairo_pattern_destroy s)) + (cairo_destroy cr)))))) + (tellv ctx restoreGraphicsState))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index c8b2578299..660a13a038 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -55,12 +55,14 @@ (when wx (set! front wx) (send wx install-mb) + (send wx notify-responder #t) (queue-window-event wx (lambda () (send wx on-activate #t))))] [-a _void (windowDidResignMain: [_id notification]) (when wx (when (eq? front wx) (set! front #f)) (send empty-mb install) + (send wx notify-responder #f) (queue-window-event wx (lambda () (send wx on-activate #f))))]) @@ -150,6 +152,8 @@ (define/override (get-wx-window) this) (define/override (make-graphics-context) + (tell cocoa graphicsContext) + #; (as-objc-allocation (tell NSGraphicsContext graphicsContextWithWindow: cocoa))) @@ -257,6 +261,28 @@ (define/override (is-view?) #f) + (define is-main? #f) + (define first-responder #f) + + (define/public (notify-responder on?) + (set! is-main? on?) + (when first-responder + (do-notify-responder first-responder on?))) + + (define/private (do-notify-responder wx on?) + (send wx focus-is-on on?) + (queue-window-event wx + (if on? + (lambda () (send wx on-set-focus)) + (lambda () (send wx on-kill-focus))))) + + (define/override (is-responder wx on?) + (if on? + (set! first-responder wx) + (set! first-responder #f)) + (when is-main? + (do-notify-responder wx on?))) + (define/public (flip-screen y) (let ([f (tell #:type _NSRect (tell cocoa screen) frame)]) (- (NSSize-height (NSRect-size f)) y))) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 57b8fc683e..940acca57c 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -206,8 +206,6 @@ (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?) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 0f99ecf71c..0796b38cdd 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -7,6 +7,7 @@ "const.rkt" "types.rkt" "keycode.rkt" + "../../lock.rkt" "../common/event.rkt" "../common/queue.rkt" "../../syntax.rkt" @@ -15,9 +16,13 @@ (objc-unsafe!) (provide window% - queue-window-event + FocusResponder - KeyMouseResponder) + KeyMouseResponder + + queue-window-event + request-flush-delay + cancel-flush-delay) (define-local-member-name flip-client) @@ -30,16 +35,12 @@ [-a _BOOL (becomeFirstResponder) (and (super-tell becomeFirstResponder) (begin - (send wx focus-is-on #t) - (queue-window-event wx (lambda () - (send wx on-set-focus))) + (send wx is-responder wx #t) #t))] [-a _BOOL (resignFirstResponder) (and (super-tell resignFirstResponder) (begin - (send wx focus-is-on #f) - (queue-window-event wx (lambda () - (send wx on-kill-focus))) + (send wx is-responder wx #f) #t))]) (define-objc-mixin (KeyMouseResponder Superclass) @@ -177,7 +178,11 @@ (unless no-show? (show #t)) - (define/public (focus-is-on on?) (void)) + (define/public (focus-is-on on?) + (void)) + + (define/public (is-responder wx on?) + (send parent is-responder wx on?)) (define/public (get-cocoa) cocoa) (define/public (get-cocoa-content) cocoa) @@ -384,5 +389,37 @@ (def/public-unimplemented centre))) + +;; ---------------------------------------- + (define (queue-window-event win thunk) (queue-event (send win get-eventspace) thunk)) + +(define depth 0) + +(define (request-flush-delay cocoa-win) + (as-entry + (lambda () + (let ([req (box cocoa-win)]) + (set! depth (add1 depth)) + (tellv cocoa-win disableFlushWindow) + (add-event-boundary-sometimes-callback! + req + (lambda (v) + ;; in atomic mode + (when (unbox req) + (set-box! req #f) + (set! depth (sub1 depth)) + (tellv cocoa-win enableFlushWindow) + (tellv cocoa-win flushWindow)))) + req)))) + +(define (cancel-flush-delay req) + (as-entry + (lambda () + (let ([cocoa-win (unbox req)]) + (when cocoa-win + (set-box! req #f) + (set! depth (sub1 depth)) + (tellv cocoa-win enableFlushWindow) + (remove-event-boundary-callback! req)))))) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index c8cef0ed50..c3d3beeabe 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -3,21 +3,27 @@ racket/draw/dc racket/draw/bitmap-dc racket/draw/bitmap - racket/draw/local) + racket/draw/local + "../../lock.rkt" + "queue.rkt") (provide backing-dc% ;; scoped method names: get-backing-size - flush-backing - start-on-paint - end-on-paint) + queue-backing-flush + on-backing-flush + start-backing-retained + end-backing-retained + reset-backing-retained) (define-local-member-name get-backing-size - flush-backing - start-on-paint - end-on-paint) + queue-backing-flush + on-backing-flush + start-backing-retained + end-backing-retained + reset-backing-retained) (define backing-dc% (class (dc-mixin bitmap-dc-backend%) @@ -32,47 +38,83 @@ (set-box! xb 1) (set-box! yb 1)) - ;; override this method to push the bitmap to - ;; the device that it backs - (define/public (flush-backing bm) + ;; override this method to set up a callback to + ;; `on-backing-flush' when the backing store can be rendered + ;; to the screen + (define/public (queue-backing-flush) (void)) - (define on-paint-cr #f) + (define retained-cr #f) + (define retained-counter 0) + (define needs-flush? #f) - (define/public (start-on-paint) + ;; called with a procedure that is applied to a bitmap; + ;; returns #f if there's nothing to flush + (define/public (on-backing-flush proc) + (cond + [(not retained-cr) #f] + [(positive? retained-counter) + (proc (internal-get-bitmap)) + #t] + [else + (reset-backing-retained proc) + #t])) + + (define/public (reset-backing-retained [proc void]) + (let ([cr retained-cr]) + (when cr + (let ([bm (internal-get-bitmap)]) + (set! retained-cr #f) + (internal-set-bitmap #f #t) + (super release-cr retained-cr) + (proc bm) + (release-backing-bitmap bm))))) + + (define/public (start-backing-retained) (call-with-cr-lock (lambda () - (if on-paint-cr - (log-error "nested start-on-paint") - (set! on-paint-cr (get-cr)))))) + (set! retained-counter (add1 retained-counter))))) - (define/public (end-on-paint) + (define/public (end-backing-retained) (call-with-cr-lock (lambda () - (if (not on-paint-cr) + (if (zero? retained-counter) (log-error "unbalanced end-on-paint") - (let ([cr on-paint-cr]) - (set! on-paint-cr #f) - (release-cr cr)))))) + (set! retained-counter (sub1 retained-counter)))))) (define/override (get-cr) - (or on-paint-cr + (or retained-cr (let ([w (box 0)] [h (box 0)]) - (get-backing-size) + (get-backing-size w h) (let ([bm (get-backing-bitmap (unbox w) (unbox h))]) - (internal-set-bitmap bm)) - (super get-cr)))) + (internal-set-bitmap bm #t)) + (let ([cr (super get-cr)]) + (set! retained-cr cr) + cr)))) (define/override (release-cr cr) - (unless (eq? cr on-paint-cr) - (let ([bm (internal-get-bitmap)]) - (internal-set-bitmap #f) - (flush-backing bm) - (release-backing-bitmap bm)))))) + (when (zero? flush-suspends) + (queue-backing-flush))) + + (define flush-suspends 0) + + (define/override (suspend-flush) + (as-entry + (lambda () + ;; if not suspended currently, sleep to encourage any + ;; existing flush requests to complete + (when (zero? flush-suspends) (sleep)) + (set! flush-suspends (add1 flush-suspends))))) + (define/override (resume-flush) + (as-entry + (lambda () + (set! flush-suspends (sub1 flush-suspends)) + (when (zero? flush-suspends) + (queue-backing-flush))))))) (define (get-backing-bitmap w h) (make-object bitmap% w h #f #t)) (define (release-backing-bitmap bm) - (send bm release-bitma-storage)) + (send bm release-bitmap-storage)) diff --git a/collects/mred/private/wxme/pasteboard.rkt b/collects/mred/private/wxme/pasteboard.rkt index 0d9a76bf42..e1a7d208b5 100644 --- a/collects/mred/private/wxme/pasteboard.rkt +++ b/collects/mred/private/wxme/pasteboard.rkt @@ -1340,18 +1340,25 @@ [bgmode (send dc get-text-mode)] [rgn (send dc get-clipping-region)]) + (send dc suspend-flush) + (send dc set-clipping-rect (- left x) (- top y) width height) - - (draw dc (- x) (- y) left top width height show-caret bg-color) - - (send dc set-clipping-region rgn) - - (send dc set-brush brush) - (send dc set-pen pen) - (send dc set-font font) - (send dc set-text-foreground fg) - (send dc set-text-background bg) - (send dc set-text-mode bgmode))))) + + (dynamic-wind + void + (lambda () + (draw dc (- x) (- y) left top width height show-caret bg-color)) + (lambda () + (send dc set-clipping-region rgn) + + (send dc set-brush brush) + (send dc set-pen pen) + (send dc set-font font) + (send dc set-text-foreground fg) + (send dc set-text-background bg) + (send dc set-text-mode bgmode) + + (send dc resume-flush))))))) (end-sequence-lock)))])) ;; ---------------------------------------- diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 1d560f3f7c..e01fa2b435 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -5042,16 +5042,23 @@ (send dc set-clipping-rect (- left x) (- top y) width height) - (do-redraw dc top bottom left right (- y) (- x) show-caret show-xsel? bg-color) + (send dc suspend-flush) - (send dc set-clipping-region rgn) + (dynamic-wind + void + (lambda () + (do-redraw dc top bottom left right (- y) (- x) show-caret show-xsel? bg-color)) + (lambda () + (send dc set-clipping-region rgn) + + (send dc set-brush brush) + (send dc set-pen pen) + (send dc set-font font) + (send dc set-text-foreground fg) + (send dc set-text-background bg) + (send dc set-text-mode bgmode) - (send dc set-brush brush) - (send dc set-pen pen) - (send dc set-font font) - (send dc set-text-foreground fg) - (send dc set-text-background bg) - (send dc set-text-mode bgmode)))))) + (send dc resume-flush)))))))) (end-sequence-lock)))])) diff --git a/collects/racket/draw/bitmap-dc.rkt b/collects/racket/draw/bitmap-dc.rkt index 41493acdde..ef7389ad18 100644 --- a/collects/racket/draw/bitmap-dc.rkt +++ b/collects/racket/draw/bitmap-dc.rkt @@ -32,11 +32,13 @@ (set! c (cairo_create (send bm get-cairo-surface))) (set! b&w? (not (send bm is-color?))))) - (define/public (internal-set-bitmap v) - (call-with-cr-lock - (lambda () - (do-set-bitmap v #t) - (when c (reset-cr c))))) + (define/public (internal-set-bitmap v [direct? #f]) + (if direct? + (do-set-bitmap v #t) + (call-with-cr-lock + (lambda () + (do-set-bitmap v #t) + (when c (reset-cr c)))))) (define/public (internal-get-bitmap) bm) diff --git a/collects/racket/draw/dc.rkt b/collects/racket/draw/dc.rkt index 4ae179b593..fe8b358478 100644 --- a/collects/racket/draw/dc.rkt +++ b/collects/racket/draw/dc.rkt @@ -458,6 +458,9 @@ (def/public (get-text-background) text-bg) (def/public (get-background) bg) + (def/public (suspend-flush) (void)) + (def/public (resume-flush) (void)) + (def/public (set-text-mode [(symbol-in solid transparent) mode]) (set! text-mode mode)) (def/public (get-text-mode) text-mode)