windows fixes

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
+		 (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))
-                 c))))
+		   (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))

collects/racket/draw/bitmap-dc.rkt

@@ -32,7 +32,7 @@
 
     (def/public (set-bitmap [(make-or-false bitmap%) v])
       (do-set-bitmap v)
-      (reset-cr))
+      (when c (reset-cr c)))
 
     (def/public (get-bitmap) bm)
 

collects/racket/draw/dc.rkt

@@ -49,14 +49,19 @@
 ;; This is the interface that the backend specific code must implement
 (define dc-backend<%>
   (interface ()
-    ;; get-cr : -> cairo_t
+    ;; get-cr : -> cairo_t or #f
     ;;
     ;; Gets a cairo_t created in a backend specific manner.
     ;; We assume that no one else is using this Cairo context
-    ;; or its surface (i.e., no state will change out frm user us,
+    ;; or its surface (i.e., no state will change out from user us,
     ;; and our state won't bother anyone else).
     get-cr
 
+    ;; release-cr : cairo_t -> void
+    ;;
+    ;; Stops using a cairo_t obtained by a get-cr
+    release-cr
+
     ;; Ends a document
     end-cr
 
@@ -110,6 +115,7 @@
   (class* object% (dc-backend<%>)
 
     (define/public (get-cr) #f)
+    (define/public (release-cr cr) (void))
     (define/public (end-cr) (void))
     (define/public (reset-cr) (void))
     
@@ -153,7 +159,7 @@
   (defclass* dc% backend% (dc<%>)
     (super-new)
 
-    (inherit flush-cr get-cr end-cr init-cr-matrix get-pango
+    (inherit flush-cr get-cr release-cr end-cr init-cr-matrix get-pango
              install-color dc-adjust-smoothing reset-clip
              collapse-bitmap-b&w?)
 
@@ -165,7 +171,10 @@
        (lambda ()
          (let ([cr (get-cr)])
            (if cr 
-               (begin . body)
+	       (dynamic-wind
+		   void
+		   (lambda () . body) 
+		   (lambda () (release-cr cr)))
                default)))))
 
     (define/public (in-cairo-context cb)
@@ -250,23 +259,28 @@
                           (cairo_matrix_t-x0 m)
                           (cairo_matrix_t-y0 m))))
 
+    (define/private (do-reset-matrix cr)
+      (cairo_set_matrix cr matrix)
+      (cairo_translate cr origin-x origin-y)
+      (cairo_scale cr scale-x scale-y)
+      (cairo_rotate cr rotation))
+    
     (define/private (reset-matrix)
       (with-cr
        (void)
        cr
-       (cairo_set_matrix cr matrix)
+       (do-reset-matrix cr)))
-       (cairo_translate cr origin-x origin-y)
-       (cairo_scale cr scale-x scale-y)
-       (cairo_rotate cr rotation)))
 
     (inherit get-font-metrics-key)
     (define/public (cache-font-metrics-key)
       (get-font-metrics-key scale-x scale-y))
 
-    (define/override (reset-cr)
+    (define/override (reset-cr cr)
       (set! context #f)
       (reset-layouts!)
-      (reset-matrix))
+      (do-reset-matrix cr)
+      (when clipping-region
+        (send clipping-region install-region cr)))
 
     (define smoothing 'unsmoothed)
 

collects/racket/draw/png.rkt

@@ -20,7 +20,7 @@
 
 (define PNG_LIBPNG_VER_STRING 
   (case (system-type)
-    [(macosx) #"1.4"]
+    [(macosx windows) #"1.4"]
     [else #"1.2"]))
 
 (define _png_structp (_cpointer 'png_structp))

collects/racket/draw/xpm.rkt

@@ -38,7 +38,7 @@
           (err "unrecognized format")))
     (for ([i (in-range (bytes->int (cadddr m) 10))]) (read-color))
     (values (bytes->int (cadr m) 10) (bytes->int (caddr m) 10)))
-  (unless (equal? "/* XPM */" (read-line in)) (err "not an XPM file"))
+  (unless (equal? "/* XPM */" (read-line in 'any)) (err "not an XPM file"))
   (unless (regexp-match? rx:start in) (err "expected C prefix not found"))
   (let*-values ([(width height) (read-meta)]
                 [(result) (make-vector height)]