From 633df82f43d05e38dd8d5e07bcfe92b88b0f419c Mon Sep 17 00:00:00 2001
From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sun, 7 Feb 2016 16:52:07 -0700
Subject: [PATCH] pango: Collect multiple definitions of ->color.

Implement ->color to accept symbols too, esp. 'white and 'black.  Add
make-rgba-color.  Create and cache the colors White and Black.  Export
->color (along with pango-color-parse) to ().
---
 src/cairo/cairo.pkg    |  1 -
 src/cairo/cairo.scm    |  7 -------
 src/glib/glib.scm      |  8 ++++++++
 src/gtk/fix-layout.scm | 16 ----------------
 src/gtk/gtk.pkg        |  4 ++--
 src/pango/pango.pkg    |  2 +-
 src/pango/pango.scm    | 12 ++++++++++++
 7 files changed, 23 insertions(+), 27 deletions(-)

diff --git a/src/cairo/cairo.pkg b/src/cairo/cairo.pkg
index 6ecd686f3..fabfe5804 100644
--- a/src/cairo/cairo.pkg
+++ b/src/cairo/cairo.pkg
@@ -32,7 +32,6 @@ USA.
   (parent (glib))
   (files "cairo")
   (import (pango)
-	  pango-color-parse
 	  guarantee-pango-layout)
   (export ()
 	  cairo-image-surface-create
diff --git a/src/cairo/cairo.scm b/src/cairo/cairo.scm
index 3a9e9d1bd..fe82e03ea 100644
--- a/src/cairo/cairo.scm
+++ b/src/cairo/cairo.scm
@@ -131,13 +131,6 @@ USA.
   (let ((c (->color color 'cairo-pattern-add-color-stop)))
     (C-call "cairo_pattern_add_color_stop_rgba" pattern (->flonum offset)
 	    (color-red c) (color-green c) (color-blue c) (color-alpha c))))
-
-(define (->color spec operator)
-  (cond ((color? spec) spec)
-	((string? spec)
-	 (pango-color-parse spec))
-	(else
-	 (error:wrong-type-argument spec "a color spec" operator))))
 
 (define (cairo-create surface)
   (guarantee-cairo-surface surface 'cairo-create)
diff --git a/src/glib/glib.scm b/src/glib/glib.scm
index 23a5838f9..9eb6f7402 100644
--- a/src/glib/glib.scm
+++ b/src/glib/glib.scm
@@ -106,6 +106,14 @@ USA.
 
 (define-integrable-operator (set-color-alpha! o a)
   (if (color? o) (flo:vector-set! o 3 a)(error:wrong-type-argument o"a color")))
+
+(define-integrable-operator (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))
 
 ;;; GLib Cleanups
 
diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index e6b6d4405..157964c13 100644
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -1049,22 +1049,6 @@ USA.
        (if (set-option!? ink 'COLOR color)
 	   (drawing-damage ink))))))
 
-(define (->color spec operator)
-  (cond ((color? spec) spec)
-	((string? spec)
-	 (let ((rgba (malloc (C-sizeof "GdkRGBA") '|GdkRGBA|)))
-	   (if (zero? (C-call "gdk_rgba_parse" rgba spec))
-	       (error:wrong-type-argument spec "a color spec" operator)
-	       (let ((color (make-color)))
-		 (set-color-red! color (C-> rgba "GdkRGBA red"))
-		 (set-color-green! color (C-> rgba "GdkRGBA green"))
-		 (set-color-blue! color (C-> rgba "GdkRGBA blue"))
-		 (set-color-alpha! color (C-> rgba "GdkRGBA alpha"))
-		 (free rgba)
-		 color))))
-	(else
-	 (error:wrong-type-argument spec "a color spec" operator))))
-
 (define (line-ink-dash-color ink)
   (guarantee-line-ink ink 'line-ink-dash-color)
   (get-option ink 'DASH-COLOR '()))
diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index 12f64fef0..a6917e241 100644
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -34,7 +34,7 @@ USA.
 (define-package (gtk)
   (parent (glib))
   (files "gtk")
-  ;;(depends-on "gtk-const.bin")
+  ;;(depends-on "gtk-const.bin" "../glib/")
   )
 
 (define-package (gtk gdk)
@@ -291,7 +291,7 @@ USA.
   (files "gtk-graphics")
   (import (gtk fix-layout)
 	  fix-ink-extent fix-rect-height fix-rect-width
-	  ->color set-surface-ink-surface! drawing-damage)
+	  set-surface-ink-surface! drawing-damage)
   (export ()
 	  gtk-graphics/set-background-color
 	  gtk-graphics/set-foreground-color
diff --git a/src/pango/pango.pkg b/src/pango/pango.pkg
index df26ec392..b7d08866a 100644
--- a/src/pango/pango.pkg
+++ b/src/pango/pango.pkg
@@ -11,7 +11,7 @@ Pango System Packaging |#
   (files "pango")
   ;;(depends-on "../glib/glib.ext")
   (export ()
-	  pango-color-parse
+	  ->color pango-color-parse
 	  <pango-layout>
 	  pango-layout-get-context
 	  pango-layout-context-changed
diff --git a/src/pango/pango.scm b/src/pango/pango.scm
index 9699172b4..4e9046554 100644
--- a/src/pango/pango.scm
+++ b/src/pango/pango.scm
@@ -26,6 +26,18 @@ USA.
 
 (C-include "pango")
 
+(define white (make-rgba-color 1. 1. 1. 1.))
+(define black (make-rgba-color 0. 0. 0. 1.))
+
+(define (->color spec operator)
+  (cond ((color? spec) spec)
+	((eq? spec 'WHITE) white)
+	((eq? spec 'BLACK) black)
+	((symbol? spec) (pango-color-parse (symbol-name spec)))
+	((string? spec) (pango-color-parse spec))
+	(else
+	 (error:wrong-type-argument spec "a color spec" operator))))
+
 (define (pango-color-parse spec)
   (guarantee-string spec 'pango-color-parse)
   (let ((rgb (malloc (C-sizeof "PangoColor") '|PangoColor|)))
-- 
2.25.1