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 ().

diff --git a/src/cairo/cairo.pkg b/src/cairo/cairo.pkg
index 6ecd686f3e4ff862e733317474d62597a341ff56..fabfe5804e641b360c9de69613a9f146d0b32af5 100644 (file)
--- 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 3a9e9d1bd6ffc8e660971e56526daf0341ee0353..fe82e03ea699ed577c50ae214157b0c07b625c43 100644 (file)
--- 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))))
 \f
 (define (cairo-create surface)
   (guarantee-cairo-surface surface 'cairo-create)

diff --git a/src/glib/glib.scm b/src/glib/glib.scm
index 23a5838f93c4661bd4dc62846d0289b2b350ebdb..9eb6f74027678e4ce6350d2405c6876cc1afa4e6 100644 (file)
--- 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))
 \f
 ;;; GLib Cleanups
 

diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index e6b6d44055b7ec81ad17ad6707aa69fa77226e61..157964c138afb801c268adcd690c3620a2973da4 100644 (file)
--- 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 12f64fef0a70202f1afdb6c54121925f4329500d..a6917e241c6cbe314cd80383ca9bf70fda12f5ea 100644 (file)
--- 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 df26ec39213b19090489ba2316d4804b56273fff..b7d08866a7d13a40c349c5257b83be1536083297 100644 (file)
--- 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 9699172b4d989b56f16d5617bc5abec42f3fa26f..4e90465543f9e2d215f1ba5ff60c5fd58077d162 100644 (file)
--- 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|)))