diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index 9f586383..ddc01161 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -69,7 +69,7 @@ (CGContextScaleCTM cg 1 -1) (CGContextTranslateCTM cg (- old-dx) (- old-dy)) (set-bounds dx dy width height) - (reset-cr)) + (reset-cr cr)) (def/override (get-size) (values (exact->inexact clip-width) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 56df00e9..2cd0c3c5 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -85,7 +85,7 @@ [gl-config #f]) (inherit get-gtk set-size get-size get-client-size - on-size register-as-child) + on-size register-as-child get-top-win) (define client-gtk (gtk_drawing_area_new)) (define-values (gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) @@ -134,7 +134,8 @@ (let ([w (box 0)] [h (box 0)]) (get-client-size w h) - (values (unbox w) (unbox h))))])) + (values (unbox w) (unbox h))))] + [window-lock (send (get-top-win) get-dc-lock)])) (gtk_widget_realize gtk) (gtk_widget_realize client-gtk) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 20e53029..a421218e 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -20,7 +20,9 @@ (define dc-backend% (class default-dc-backend% (init-field gtk - get-client-size) + get-client-size + window-lock) + (inherit reset-cr) (define c #f) @@ -28,8 +30,21 @@ (or c (let ([w (g_object_get_window gtk)]) (and w - (set! c (gdk_cairo_create w)) - c)))) + (begin + ;; Under Windows, creating a Cairo context within + ;; a frame inteferes with any other Cairo context + ;; within the same frame. So we use a lock to + ;; serialize drawing to different contexts. + (when window-lock (semaphore-wait window-lock)) + (set! c (gdk_cairo_create w)) + (reset-cr c) + c))))) + + (define/override (release-cr cr) + (when window-lock + (cairo_destroy c) + (set! c #f) + (semaphore-post window-lock))) (define/public (reset-dc) ;; FIXME: ensure that the dc is not in use diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index e4067326..2c6b2ac5 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -124,6 +124,11 @@ (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y) (void)) + (define/override (get-top-win) this) + + (define dc-lock (and (eq? 'windows (system-type)) (make-semaphore 1))) + (define/public (get-dc-lock) dc-lock) + (define/override (center dir wrt) (let ([w-box (box 0)] [h-box (box 0)] diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index 84abe61c..52dfe4e5 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -18,6 +18,8 @@ (define-gtk gtk_menu_item_new_with_mnemonic (_fun _string -> _GtkWidget)) (define-gtk gtk_menu_item_set_submenu (_fun _GtkWidget (_or-null _GtkWidget) -> _void)) (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) (define (fixup-mneumonic title) (regexp-replace* @@ -56,7 +58,12 @@ (define/public (get-top-window) top-wx) - (def/public-unimplemented set-label-top) + (define/public (set-label-top pos str) + (let ([l (list-ref menus pos)]) + (let ([item-gtk (car l)]) + (gtk_label_set_text_with_mnemonic (gtk_bin_get_child item-gtk) + (fixup-mneumonic str))))) + (def/public-unimplemented number) (def/public-unimplemented enable-top) @@ -77,7 +84,7 @@ (define (append-menu menu title) (send menu set-parent this) (let ([item (gtk_menu_item_new_with_mnemonic (fixup-mneumonic title))]) - (set! menus (append menus (list (list item menu title)))) + (set! menus (append menus (list (list item menu)))) (let ([gtk (send menu get-gtk)]) (g_object_ref gtk) (gtk_menu_item_set_submenu item gtk)) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index edb83cab..d52a0dd4 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -285,6 +285,8 @@ (define/public (get-parent) parent) + (define/public (get-top-win) (send parent get-top-win)) + (define/public (get-size xb yb) (set-box! xb save-w) (set-box! yb save-h))