windows fixes

original commit: e0bbe944aa92584880fb20fc485d0d0e93f1c2c1

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)

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)

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

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)]

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))

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))