windows fixes
This commit is contained in:
Matthew Flatt
parent
4134b06b4c
commit
e0bbe944aa
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user