From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Tue, 20 Mar 2018 02:55:14 +0000 (-0700)
Subject: cairo/cairo-graphics: Get serial with glib.
X-Git-Tag: mit-scheme-pucked-cairo-0.6
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0b226e585fa8f62813c0918e95e155b04603e383;p=mit-scheme.git
cairo/cairo-graphics: Get serial with glib.
---
diff --git a/src/cairo/cairo-graphics.scm b/src/cairo/cairo-graphics.scm
index 09496187f..d5f9df709 100644
--- a/src/cairo/cairo-graphics.scm
+++ b/src/cairo/cairo-graphics.scm
@@ -58,15 +58,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
(cairo-matrix k 0. 0.
0. (flo:negate k) 0.)))
(cairo-translate cr 1.0 -1.0)
- (let ((black (->color "black" 'make-cairo-graphics))
- (white (->color "white" 'make-cairo-graphics)))
- (cairo-set-source-color cr white)
- (cairo-paint cr)
- (cairo-set-source-color cr black)
- (set-cairo-graphics-bgcolor-name! graphics "white")
- (set-cairo-graphics-bgcolor! graphics white)
- (set-cairo-graphics-fgcolor-name! graphics "black")
- (set-cairo-graphics-fgcolor! graphics black))
+ (cairo-set-source-color cr white)
+ (cairo-paint cr)
+ (cairo-set-source-color cr black)
+ (set-cairo-graphics-bgcolor-name! graphics "white")
+ (set-cairo-graphics-bgcolor! graphics white)
+ (set-cairo-graphics-fgcolor-name! graphics "black")
+ (set-cairo-graphics-fgcolor! graphics black)
graphics)))
(define (cairo-graphics/available?) #t)
@@ -262,14 +260,18 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
(define (cairo-graphics/set-background-color device name)
(let ((graphics (graphics-device/descriptor device)))
(if (not (string=? name (cairo-graphics-bgcolor-name graphics)))
- (let ((new (->color name 'cairo-graphics/set-background-color)))
+ (let ((new (with-glib-lock
+ (lambda ()
+ (->color name 'cairo-graphics/set-background-color)))))
(set-cairo-graphics-bgcolor! graphics new)
(set-cairo-graphics-bgcolor-name! graphics name)))))
(define (cairo-graphics/set-foreground-color device name)
(let ((graphics (graphics-device/descriptor device)))
(if (not (string=? name (cairo-graphics-fgcolor-name graphics)))
- (let ((new (->color name 'cairo-graphics/set-foreground-color)))
+ (let ((new (with-glib-lock
+ (lambda ()
+ (->color name 'cairo-graphics/set-foreground-color)))))
(set-cairo-graphics-fgcolor! graphics new)
(set-cairo-graphics-fgcolor-name! graphics name)
(cairo-set-source-color (cairo-graphics-context graphics) new)))))
diff --git a/src/cairo/cairo.pkg b/src/cairo/cairo.pkg
index 948a742ac..78c0a29bf 100644
--- a/src/cairo/cairo.pkg
+++ b/src/cairo/cairo.pkg
@@ -35,9 +35,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
(parent (cairo))
(files "cairo")
(import (glib)
- add-glib-cleanup
assert-without-interruption
- execute-glib-cleanup
+ assert-glib-locked
+ with-glib-lock
gobject-alien)
(import (pango)
->color
diff --git a/src/cairo/cairo.scm b/src/cairo/cairo.scm
index 12ed2cd60..a679fa681 100644
--- a/src/cairo/cairo.scm
+++ b/src/cairo/cairo.scm
@@ -31,6 +31,17 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
(define-integrable (color-blue o) (flo:vector-ref o 2))
(define-integrable (color-alpha o) (flo:vector-ref o 3))
+(define (rgba-color red green blue alpha)
+ (let ((color (flo:vector-cons 4)))
+ (flo:vector-set! color 0 red)
+ (flo:vector-set! color 1 green)
+ (flo:vector-set! color 2 blue)
+ (flo:vector-set! color 3 alpha)
+ color))
+
+(define white (rgba-color 1. 1. 1. 1.))
+(define black (rgba-color 0. 0. 0. 1.))
+
(define (guarantee-color object operator)
(if (not (and (flo:flonum? object) (fix:= 4 (flo:vector-length object))))
(error:wrong-type-argument object "an rgba color" operator)))
@@ -38,7 +49,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
(define (cairo-image-surface-create width height)
(let ((surface (make-alien '|cairo_surface_t|))
(copy (make-alien '|cairo_surface_t|)))
- (add-glib-cleanup surface (make-cairo-surface-cleanup copy))
+ (add-cairo-cleanup surface (make-cairo-surface-cleanup copy))
(C-call "cairo_image_surface_create" copy
(C-enum "CAIRO_FORMAT_RGB24") width height)
(copy-alien-address! surface copy)
@@ -58,7 +69,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
(without-interruption
(lambda ()
(if (not (alien-null? surface))
- (execute-glib-cleanup surface)))))
+ (execute-cairo-cleanup surface)))))
(define (check-cairo-surface-status surface)
(let ((status (C-call "cairo_surface_status" surface)))
@@ -85,7 +96,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
(define (cairo-pattern-create-linear x1 y1 x2 y2)
(let ((pattern (make-alien '|cairo_pattern_t|))
(copy (make-alien '|cairo_pattern_t|)))
- (add-glib-cleanup pattern (make-cairo-pattern-cleanup copy))
+ (add-cairo-cleanup pattern (make-cairo-pattern-cleanup copy))
(C-call "cairo_pattern_create_linear" copy
(->flonum x1) (->flonum y1) (->flonum x2) (->flonum y2))
(copy-alien-address! pattern copy)
@@ -95,7 +106,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
(define (cairo-pattern-create-radial cx0 cy0 radius0 cx1 cy1 radius1)
(let ((pattern (make-alien '|cairo_pattern_t|))
(copy (make-alien '|cairo_pattern_t|)))
- (add-glib-cleanup pattern (make-cairo-pattern-cleanup copy))
+ (add-cairo-cleanup pattern (make-cairo-pattern-cleanup copy))
(C-call "cairo_pattern_create_radial" copy
(->flonum cx0) (->flonum cy0) (->flonum radius0)
(->flonum cx1) (->flonum cy1) (->flonum radius1))
@@ -116,7 +127,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
(without-interruption
(lambda ()
(if (not (alien-null? pattern))
- (execute-glib-cleanup pattern)))))
+ (execute-cairo-cleanup pattern)))))
(define (check-cairo-pattern-status pattern)
(let ((status (C-call "cairo_pattern_status" pattern)))
@@ -143,7 +154,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
(guarantee-cairo-surface surface 'cairo-create)
(let ((cairo (make-alien '|cairo_t|))
(copy (make-alien '|cairo_t|)))
- (add-glib-cleanup cairo (make-cairo-cleanup copy))
+ (add-cairo-cleanup cairo (make-cairo-cleanup copy))
(C-call "cairo_create" copy surface)
(copy-alien-address! cairo copy)
(check-cairo-status cairo)
@@ -161,7 +172,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
(check-cairo-status cairo)
(without-interruption
(lambda ()
- (execute-glib-cleanup cairo))))
+ (execute-cairo-cleanup cairo))))
(define (check-cairo-status cairo)
(let ((status (C-call "cairo_status" cairo)))
@@ -319,8 +330,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
(->flonum start-angle) (->flonum end-angle)))
(define (cairo-show-pango-layout cairo layout)
- (guarantee-cairo cairo 'cairo-pango-layout)
- (guarantee-pango-layout layout 'cairo-pango-layout)
+ (guarantee-cairo cairo 'cairo-show-pango-layout)
+ (guarantee-pango-layout layout 'cairo-show-pango-layout)
+ (assert-glib-locked 'cairo-show-pango-layout)
(C-call "pango_cairo_show_layout" cairo (gobject-alien layout)))
(define (cairo-show-text cairo string)
@@ -438,4 +450,65 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
(define (guarantee-flonum object operator)
(if (not (flo:flonum? object))
- (error:wrong-type-argument object "a flonum" operator)))
\ No newline at end of file
+ (error:wrong-type-argument object "a flonum" operator)))
+
+(define cairo-cleanups)
+(define cairo-cleanups-mutex)
+
+(define (cleanup-cairo!)
+ (with-thread-mutex-try-lock cairo-cleanups-mutex
+ (lambda ()
+ (let loop ((cleanups cairo-cleanups)
+ (prev #f))
+ (if (pair? cleanups)
+ (if (weak-pair/car? (car cleanups))
+ (loop (cdr cleanups) cleanups)
+ (let ((next (cdr cleanups)))
+ ((weak-cdr (car cleanups)))
+ (if prev
+ (set-cdr! prev next)
+ (set! cairo-cleanups next))
+ (loop next prev))))))
+ (lambda ()
+ unspecific)))
+
+(define (add-cairo-cleanup object thunk)
+ (let ((weak (weak-cons object thunk)))
+ (with-thread-mutex-lock cairo-cleanups-mutex
+ (lambda ()
+ (set! cairo-cleanups (cons weak cairo-cleanups))))
+ weak))
+
+(define (execute-cairo-cleanup object)
+ (assert-without-interruption 'execute-cairo-cleanup)
+ (with-thread-mutex-lock cairo-cleanups-mutex
+ (lambda ()
+ (without-interruption
+ (lambda ()
+ (let ((entry (weak-assq object cairo-cleanups)))
+ (if entry
+ (begin
+ ((weak-cdr entry))
+ (set! cairo-cleanups (delq! entry cairo-cleanups)))))))))
+ unspecific)
+
+(define (weak-assq obj alist)
+ (let loop ((alist alist))
+ (if (null? alist)
+ #f
+ (let* ((entry (car alist))
+ (key (weak-car entry)))
+ (if (eq? obj key)
+ entry
+ (loop (cdr alist)))))))
+
+(define (reset-cairo-package!)
+ (set! cairo-cleanups '())
+ (set! cairo-cleanups-mutex (make-thread-mutex)))
+
+(define (initialize-package!)
+ (reset-cairo-package!)
+ (add-event-receiver! event:after-restore reset-cairo-package!)
+ (add-gc-daemon! cleanup-cairo!))
+
+(initialize-package!)
\ No newline at end of file