From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Mon, 19 Mar 2018 00:22:11 +0000 (-0700)
Subject: pango: Add color procedures from glib.scm.
X-Git-Tag: mit-scheme-pucked-x11-0.2.2~19
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f2781a69cd349e23bd368a4447bf1ca30b925212;p=mit-scheme.git

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 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>
 	  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 (<pango-layout> (constructor ()))
     (<gobject>))