From: Matt Birkholz Date: Mon, 19 Mar 2018 06:18:21 +0000 (-0700) Subject: pango: Punt exported color procedures. X-Git-Tag: mit-scheme-pucked-x11-0.2.2~11 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=991ac8a8b534edf9a80771c8f8afd99c7cceffe2;p=mit-scheme.git pango: Punt exported color procedures. Use simple flo:vector aliases in Cairo and Gtk-Screen. Simplify Gtk's. --- diff --git a/src/cairo/cairo.pkg b/src/cairo/cairo.pkg index fedd620b4..948a742ac 100644 --- a/src/cairo/cairo.pkg +++ b/src/cairo/cairo.pkg @@ -40,8 +40,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. execute-glib-cleanup gobject-alien) (import (pango) - ->color color-red color-green color-blue color-alpha - guarantee-color + ->color guarantee-pango-layout) (export (cairo) cairo-image-surface-create diff --git a/src/cairo/cairo.scm b/src/cairo/cairo.scm index 79da4f4d2..12ed2cd60 100644 --- a/src/cairo/cairo.scm +++ b/src/cairo/cairo.scm @@ -26,6 +26,15 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-include "cairo") +(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 (guarantee-color object operator) + (if (not (and (flo:flonum? object) (fix:= 4 (flo:vector-length object)))) + (error:wrong-type-argument object "an rgba color" operator))) + (define (cairo-image-surface-create width height) (let ((surface (make-alien '|cairo_surface_t|)) (copy (make-alien '|cairo_surface_t|))) diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg index f1f1d96f3..b72db119d 100644 --- a/src/gtk-screen/gtk-screen.pkg +++ b/src/gtk-screen/gtk-screen.pkg @@ -70,7 +70,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. assert-glib-locked assert-without-interruption gobject-alien gobject-unref!) (import (pango) - make-rgba-color pango-context-get-metrics pango-context-spacing pango-font-description-free diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index 1c5a68ab0..c9a3b25e3 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -2625,6 +2625,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-rectangle-ink-color! cursor "green") (set-rectangle-ink-fill-color! cursor (make-rgba-color 0. 1. 0. .5))) +(define (make-rgba-color red green blue alpha) + (let ((color (flo:vector-cons 4))) + (flo:vector-set! color 0 red) + (flo:vector-set! color 1 green) + (flo:vector-set! color 2 blue) + (flo:vector-set! color 3 alpha) + color)) + (define (guarantee-cursor-ink object) (if (cursor-ink? object) object (error:wrong-type-argument object "" 'guarantee-cursor-ink))) diff --git a/src/gtk/gtk.scm b/src/gtk/gtk.scm index 6fc6f64cc..5c8aae5de 100644 --- a/src/gtk/gtk.scm +++ b/src/gtk/gtk.scm @@ -80,29 +80,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (bit-ior . ints) (reduce bitwise-ior 0 ints)) -(define-integrable (color? object) +(define (color? object) (and (flo:flonum? object) (fix:= 4 (flo:vector-length object)))) -(define-integrable (make-color) (flo:vector-cons 4)) -(define-integrable-operator (color-red o) - (if (color? o) (flo:vector-ref o 0) (error:wrong-type-argument o "a color"))) -(define-integrable-operator (color-green o) - (if (color? o) (flo:vector-ref o 1) (error:wrong-type-argument o "a color"))) -(define-integrable-operator (color-blue o) - (if (color? o) (flo:vector-ref o 2) (error:wrong-type-argument o "a color"))) -(define-integrable-operator (color-alpha o) - (if (color? o) (flo:vector-ref o 3) (error:wrong-type-argument o "a color"))) -(define-integrable-operator (set-color-red! o r) - (if (color? o) (flo:vector-set! o 0 r)(error:wrong-type-argument o"a color"))) -(define-integrable-operator (set-color-green! o g) - (if (color? o) (flo:vector-set! o 1 g)(error:wrong-type-argument o"a color"))) -(define-integrable-operator (set-color-blue! o b) - (if (color? o) (flo:vector-set! o 2 b)(error:wrong-type-argument o"a color"))) -(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) + +(define (make-rgba-color red green blue alpha) + (let ((color (flo:vector-cons 4))) + (flo:vector-set! color 0 red) + (flo:vector-set! color 1 green) + (flo:vector-set! color 2 blue) + (flo:vector-set! color 3 alpha) color)) \ No newline at end of file diff --git a/src/pango/pango.pkg b/src/pango/pango.pkg index ea6c89502..ed2c4049e 100644 --- a/src/pango/pango.pkg +++ b/src/pango/pango.pkg @@ -35,9 +35,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (files "pango") ;;(depends-on "../glib/glib.ext") (export (pango) - 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 guarantee-pango-layout pango-layout-get-context diff --git a/src/pango/pango.scm b/src/pango/pango.scm index 13e1907d6..e68e75bdb 100644 --- a/src/pango/pango.scm +++ b/src/pango/pango.scm @@ -32,7 +32,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (if (alien-null? ALIEN) (error MESSAGE ...))))) -(define-integrable (color? object) +(define (color? object) (and (flo:flonum? object) (fix:= 4 (flo:vector-length object)))) (define-integrable (make-color) (flo:vector-cons 4)) @@ -47,7 +47,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) +(define (rgba-color red green blue alpha) (let ((color (make-color))) (set-color-red! color red) (set-color-green! color green) @@ -55,13 +55,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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.)) +(define white (rgba-color 1. 1. 1. 1.)) +(define black (rgba-color 0. 0. 0. 1.)) (define (->color spec operator) (assert-glib-locked '->color)