From f2781a69cd349e23bd368a4447bf1ca30b925212 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sun, 18 Mar 2018 17:22:11 -0700 Subject: [PATCH] pango: Add color procedures from glib.scm. Keep them simple, for useful integration, too simple to justify all the extra type checking. And copy error-if-null, the only binding to disappear into (glib internal) and no longer available implicitly. --- src/pango/pango.pkg | 3 +++ src/pango/pango.scm | 36 +++++++++++++++++++++++++++++++++++- 2 files changed, 38 insertions(+), 1 deletion(-) diff --git a/src/pango/pango.pkg b/src/pango/pango.pkg index 1b4787033..2a1d2bb2b 100644 --- a/src/pango/pango.pkg +++ b/src/pango/pango.pkg @@ -32,6 +32,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (files "pango") ;;(depends-on "../glib/glib.ext") (export () + color? make-color color-red color-green color-blue color-alpha + set-color-red! set-color-green! set-color-blue! set-color-alpha! + make-rgba-color guarantee-color ->color pango-color-parse pango-layout-get-context diff --git a/src/pango/pango.scm b/src/pango/pango.scm index 2b56e695d..13e1907d6 100644 --- a/src/pango/pango.scm +++ b/src/pango/pango.scm @@ -26,6 +26,40 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-include "pango") +(define-syntax error-if-null + (syntax-rules () + ((_ ALIEN MESSAGE ...) + (if (alien-null? ALIEN) + (error MESSAGE ...))))) + +(define-integrable (color? object) + (and (flo:flonum? object) (fix:= 4 (flo:vector-length object)))) + +(define-integrable (make-color) (flo:vector-cons 4)) + +(define-integrable (color-red o) (flo:vector-ref o 0)) +(define-integrable (color-green o) (flo:vector-ref o 1)) +(define-integrable (color-blue o) (flo:vector-ref o 2)) +(define-integrable (color-alpha o) (flo:vector-ref o 3)) + +(define-integrable (set-color-red! o r) (flo:vector-set! o 0 r)) +(define-integrable (set-color-green! o g) (flo:vector-set! o 1 g)) +(define-integrable (set-color-blue! o b) (flo:vector-set! o 2 b)) +(define-integrable (set-color-alpha! o a) (flo:vector-set! o 3 a)) + +(define-integrable (make-rgba-color red green blue alpha) + (let ((color (make-color))) + (set-color-red! color red) + (set-color-green! color green) + (set-color-blue! color blue) + (set-color-alpha! color alpha) + color)) + +(define (guarantee-color object operator) + (if (color? object) + object + (error:wrong-type-argument object "a color" operator))) + (define white (make-rgba-color 1. 1. 1. 1.)) (define black (make-rgba-color 0. 0. 0. 1.)) @@ -57,7 +91,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-color-alpha! color 1.) (free rgb) color)))) - + (define-class ( (constructor ())) ()) -- 2.25.1