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.

diff --git a/src/pango/pango.pkg b/src/pango/pango.pkg
index 1b478703300635e9652cead93b75e10e23a7378a..2a1d2bb2b6061ec457b25ea7b9926644ecab3fab 100644 (file)
--- 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>
          pango-layout-get-context

diff --git a/src/pango/pango.scm b/src/pango/pango.scm
index 2b56e695d13ed1659b11a4f88923b8ea0e3aa9e3..13e1907d6b1055a9f85b1de90fc23deb2ea734ff 100644 (file)
--- 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))))
-
+\f
 (define-class (<pango-layout> (constructor ()))
     (<gobject>))