cairo/cairo-graphics: Get serial with glib.

diff --git a/src/cairo/cairo-graphics.scm b/src/cairo/cairo-graphics.scm
index 09496187f591a512f9cac56d5b824c7d1ff1605d..d5f9df709434ab8fea50e51cad8fcf0a30b7ae43 100644 (file)
--- 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 948a742ac9fe430f2fa41f3bb7475c86548eaa5a..78c0a29bf54301bf520ef97cdc086d4c5a50e3a7 100644 (file)
--- 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 12ed2cd60e10a14b8a2606207d5baca26770e213..a679fa681d94d3ee5981a538a27c5e43263208a6 100644 (file)
--- 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