From e0bbe944aa92584880fb20fc485d0d0e93f1c2c1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 29 Jul 2010 16:56:58 -0600 Subject: [PATCH] windows fixes --- collects/mred/private/wx/cocoa/dc.rkt | 2 +- collects/mred/private/wx/gtk/canvas.rkt | 5 ++-- collects/mred/private/wx/gtk/dc.rkt | 21 +++++++++++-- collects/mred/private/wx/gtk/frame.rkt | 5 ++++ collects/mred/private/wx/gtk/menu-bar.rkt | 11 +++++-- collects/mred/private/wx/gtk/window.rkt | 2 ++ collects/racket/draw/bitmap-dc.rkt | 2 +- collects/racket/draw/dc.rkt | 36 ++++++++++++++++------- collects/racket/draw/png.rkt | 2 +- collects/racket/draw/xpm.rkt | 2 +- 10 files changed, 66 insertions(+), 22 deletions(-) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index 9f5863838c..ddc01161e6 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 56df00e95b..2cd0c3c589 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 20e5302995..a421218e31 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 e406732641..2c6b2ac53d 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 84abe61cc4..52dfe4e5f5 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 edb83cabc5..d52a0dd438 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)) diff --git a/collects/racket/draw/bitmap-dc.rkt b/collects/racket/draw/bitmap-dc.rkt index 066f3d98aa..46d245bf6b 100644 --- a/collects/racket/draw/bitmap-dc.rkt +++ b/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) diff --git a/collects/racket/draw/dc.rkt b/collects/racket/draw/dc.rkt index d84b0a2c89..3735e9df5b 100644 --- a/collects/racket/draw/dc.rkt +++ b/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) @@ -249,24 +258,29 @@ (cairo_matrix_t-yy m) (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) - (cairo_translate cr origin-x origin-y) - (cairo_scale cr scale-x scale-y) - (cairo_rotate cr rotation))) + (do-reset-matrix cr))) (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) diff --git a/collects/racket/draw/png.rkt b/collects/racket/draw/png.rkt index 4f309f27c4..3bbf719e0c 100644 --- a/collects/racket/draw/png.rkt +++ b/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)) diff --git a/collects/racket/draw/xpm.rkt b/collects/racket/draw/xpm.rkt index bebec86dee..86b28e39d1 100644 --- a/collects/racket/draw/xpm.rkt +++ b/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)]