From: Matt Birkholz Date: Tue, 20 Mar 2018 02:55:14 +0000 (-0700) Subject: cairo/cairo-graphics: Get serial with glib. X-Git-Tag: mit-scheme-pucked-devops-0.6 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0fc1b3b4352faa8a2ace4dd7cb971cf80cba017c;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