+ export some Xft constants to Scheme

+ finite types for some Xft pattern objects: xft-weight, xft-slant,
  xft-spacing, xft-rgba

+ functions for translating Xft constants to finite types

+ make XftPatternGet/Add() use the finite types

+ fixed a serious bug in scx_XftPatternAdd

c/libs/xft.c

@@ -107,7 +107,7 @@ s48_value scx_XftPatternAdd(s48_value sxp, s48_value sobj,
   p = scx_extract_xftpattern(sxp);
   obj = s48_extract_integer(sobj);
   append = S48_TRUE_P(sappend);
-  tbl = lookup_pattern_property_by_id(sobj);
+  tbl = lookup_pattern_property_by_id(obj);
 
   switch (tbl->type) {
   case SCX_XFT_STRING:
@@ -539,6 +539,42 @@ void scx_xft_init(void)
   SCX_EXPORT_INTEGER_TO_S48("scx-xft-pattern-char-height", scx_xft_pattern_char_height,
 			    SCX_XFT_CHAR_HEIGHT);
 
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-weight-light", scx_xft_weight_light,
+			    XFT_WEIGHT_LIGHT);
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-weight-medium", scx_xft_weight_medium,
+			    XFT_WEIGHT_MEDIUM);
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-weight-demibold", scx_xft_weight_demibold,
+			    XFT_WEIGHT_DEMIBOLD);
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-weight-bold", scx_xft_weight_bold,
+			    XFT_WEIGHT_BOLD);
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-weight-black", scx_xft_weight_black,
+			    XFT_WEIGHT_BLACK);
+
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-slant-roman", scx_xft_slant_roman,
+			    XFT_SLANT_ROMAN);
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-slant-italic", scx_xft_slant_italic,
+			    XFT_SLANT_ITALIC);
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-slant-oblique", scx_xft_slant_oblique,
+			    XFT_SLANT_OBLIQUE);
+
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-spacing-proportional", scx_xft_spacing_proportional,
+			    XFT_PROPORTIONAL);
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-spacing-mono", scx_xft_spacing_mono,
+			    XFT_MONO);
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-spacing-charcell", scx_xft_spacing_charcell,
+			    XFT_CHARCELL);
+
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-rgba-none", scx_xft_rgba_none,
+			    XFT_RGBA_NONE);
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-rgba-rgb", scx_xft_rgba_rgb,
+			    XFT_RGBA_RGB);
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-rgba-bgr", scx_xft_rgba_bgr,
+			    XFT_RGBA_BGR);
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-rgba-vrgb", scx_xft_rgba_vrgb,
+			    XFT_RGBA_VRGB);
+  SCX_EXPORT_INTEGER_TO_S48("scx-xft-rgba-vbgr", scx_xft_rgba_vbgr,
+			    XFT_RGBA_VBGR);
+
   S48_EXPORT_FUNCTION(scx_XftPatternCreate);
   S48_EXPORT_FUNCTION(scx_XftPatternDestroy);
   S48_EXPORT_FUNCTION(scx_XftPatternDuplicate);

c/libs/xft.h

@@ -142,6 +142,26 @@ SCX_DECLARE_STATIC_S48VAL(scx_xft_pattern_dpi);
 SCX_DECLARE_STATIC_S48VAL(scx_xft_pattern_char_width);
 SCX_DECLARE_STATIC_S48VAL(scx_xft_pattern_char_height);
 
+SCX_DECLARE_STATIC_S48VAL(scx_xft_weight_light);
+SCX_DECLARE_STATIC_S48VAL(scx_xft_weight_medium);
+SCX_DECLARE_STATIC_S48VAL(scx_xft_weight_demibold);
+SCX_DECLARE_STATIC_S48VAL(scx_xft_weight_bold);
+SCX_DECLARE_STATIC_S48VAL(scx_xft_weight_black);
+
+SCX_DECLARE_STATIC_S48VAL(scx_xft_slant_roman);
+SCX_DECLARE_STATIC_S48VAL(scx_xft_slant_italic);
+SCX_DECLARE_STATIC_S48VAL(scx_xft_slant_oblique);
+
+SCX_DECLARE_STATIC_S48VAL(scx_xft_spacing_proportional);
+SCX_DECLARE_STATIC_S48VAL(scx_xft_spacing_mono);
+SCX_DECLARE_STATIC_S48VAL(scx_xft_spacing_charcell);
+
+SCX_DECLARE_STATIC_S48VAL(scx_xft_rgba_none);
+SCX_DECLARE_STATIC_S48VAL(scx_xft_rgba_rgb);
+SCX_DECLARE_STATIC_S48VAL(scx_xft_rgba_bgr);
+SCX_DECLARE_STATIC_S48VAL(scx_xft_rgba_vrgb);
+SCX_DECLARE_STATIC_S48VAL(scx_xft_rgba_vbgr);
+
 #define XFT_REC_ACCESSOR_MAKER(FN, TN, RN) \
 	s48_value FN(TN *p)				\
 	{						\

scheme/libs/libs-interfaces.scm

@@ -42,13 +42,36 @@
    scx-xft-draw-drawable
    scx-xft-draw-colormap
    scx-xft-draw-visual
-   (xft-pattern-object :syntax)
-   xft-pattern-object-elements
 
    scx-xft-result-match?
    scx-xft-result-no-match?
    scx-xft-result-type-mismatch?
-   scx-xft-result-no-id?))
+   scx-xft-result-no-id?
+
+   (xft-pattern-object :syntax)
+   xft-pattern-object?
+   xft-pattern-object-elements
+   xft-pattern-object-name
+
+   (xft-weight :syntax)
+   xft-weight?
+   xft-weight-elements
+   xft-weight-name
+
+   (xft-slant :syntax)
+   xft-slant?
+   xft-slant-elements
+   xft-slant-name
+
+   (xft-spacing :syntax)
+   xft-spacing?
+   xft-spacing-elements
+   xft-spacing-name
+
+   (xft-rgba :syntax)
+   xft-rgba?
+   xft-rgba-elements
+   xft-rgba-name))
 
 (define-interface xrender-interface
   (export

scheme/libs/xft.scm

@@ -83,6 +83,95 @@
    (char-width	(lookup-shared-valued "scx-xft-pattern-char-width"))
    (char-height (lookup-shared-valued "scx-xft-pattern-char-height"))))
 
+(define-finite-type xft-weight :xft-weight
+  (id)
+  xft-weight?
+  xft-weight-elements
+  xft-weight-name
+  xft-weight-index
+  (id xft-weight-id)
+  ((light	(lookup-shared-valued "scx-xft-weight-light"))
+   (medium	(lookup-shared-valued "scx-xft-weight-medium"))
+   (demibold	(lookup-shared-valued "scx-xft-weight-demibold"))
+   (bold	(lookup-shared-valued "scx-xft-weight-bold"))
+   (black	(lookup-shared-valued "scx-xft-weight-black"))))
+
+(define-finite-type xft-slant :xft-slant
+  (id)
+  xft-slant?
+  xft-slant-elements
+  xft-slant-name
+  xft-slant-index
+  (id xft-slant-id)
+  ((roman	(lookup-shared-valued "scx-xft-slant-roman"))
+   (italic	(lookup-shared-valued "scx-xft-slant-italic"))
+   (oblique	(lookup-shared-valued "scx-xft-slant-oblique"))))
+
+(define-finite-type xft-spacing :xft-spacing
+  (id)
+  xft-spacing?
+  xft-spacing-elements
+  xft-spacing-name
+  xft-spacing-index
+  (id xft-spacing-id)
+  ((proportional	(lookup-shared-valued "scx-xft-spacing-proportional"))
+   (mono		(lookup-shared-valued "scx-xft-spacing-mono"))
+   (charcell		(lookup-shared-valued "scx-xft-spacing-charcell"))))
+
+(define-finite-type xft-rgba :xft-rgba
+  (id)
+  xft-rgba?
+  xft-rgba-elements
+  xft-rgba-name
+  xft-rgba-index
+  (id xft-rgba-id)
+  ((none	(lookup-shared-valued "scx-xft-rgba-none"))
+   (rgb		(lookup-shared-valued "scx-xft-rgba-rgb"))
+   (bgr		(lookup-shared-valued "scx-xft-rgba-bgr"))
+   (vrgb	(lookup-shared-valued "scx-xft-rgba-vrgb"))
+   (vbgr	(lookup-shared-valued "scx-xft-rgba-vbgr"))))
+
+(define (make-finite-type-alist elements id-proc)
+  (map (lambda (e) 
+	 (cons (id-proc e) e))
+       (vector->list elements)))
+       
+(define xft-weight-id->xft-weight
+  (let ((alist 
+	 (make-finite-type-alist xft-weight-elements xft-weight-id)))
+    (lambda (id)
+      (cond 
+       ((assoc id alist) => cdr)
+       (else 
+	(error "scx: internal error. Could not map weight id to finite type"))))))
+
+(define xft-slant-id->xft-slant
+  (let ((alist 
+	 (make-finite-type-alist xft-slant-elements xft-slant-id)))
+    (lambda (id)
+      (cond
+       ((assoc id alist) => cdr)
+       (else
+	(error "scx: internal error. Could not map slant id to finite type"))))))
+
+(define xft-spacing-id->xft-spacing
+  (let ((alist 
+	 (make-finite-type-alist xft-spacing-elements xft-spacing-id)))
+    (lambda (id)
+      (cond
+       ((assoc id alist) => cdr)
+       (else
+	(error "scx: internal error. Could not map spacing id to finite type"))))))
+
+(define xft-rgba-id->xft-rgba
+  (let ((alist
+	 (make-finite-type-alist xft-rgba-elements xft-rgba-id)))
+    (lambda (id)
+      (cond
+       ((assoc id alist) => cdr)
+       (else
+	(error "scx: internal error. Could not map rgba id to finite type"))))))
+
 ;;; add finalizers
 
 (define (make-xft-pattern)
@@ -95,13 +184,42 @@
     (add-finalizer! copy scx-xft-pattern-destroy)
     copy))
 
-(define (scx-xft-pattern-get xft-pattern xft-pattern-object id)
+(define (scx-xft-pattern-get pattern object id)
-  (scx-xft-pattern-get-internal
+  (let ((object-id (xft-pattern-object-id object)))
-   xft-pattern (xft-pattern-object-id xft-pattern-object) id))
+    (call-with-values
+     (lambda ()
+       (apply values 
+	      (scx-xft-pattern-get-internal pattern object-id id)))
+     (lambda (code value)
+       (values code
+	       (cond
+		((not (scx-xft-result-match? code))
+		 #f)
+		((equal? object (xft-pattern-object weight))
+		 (xft-weight-id->xft-weight value))
+		((equal? object (xft-pattern-object slant))
+		 (xft-slant-id->xft-slant value))
+		((equal? object (xft-pattern-object spacing))
+		 (xft-spacing-id->xft-spacing value))
+		((equal? object (xft-pattern-object rgba))
+		 (xft-rgba-id->xft-rgba value))
+		(else value)))))))
 	   
-(define (scx-xft-pattern-add xft-pattern xft-pattern-object value append?)
+(define (scx-xft-pattern-add pattern object value append?)
-  (scx-xft-pattern-add-internal
+  (let* ((object-id (xft-pattern-object-id object))
-   xft-pattern (xft-pattern-object-id xft-pattern-object) value append?))
+	 (call (lambda (value)
+		 (scx-xft-pattern-add-internal 
+		  pattern object-id value append?))))
+    (cond
+     ((equal? object (xft-pattern-object weight))
+      (call (xft-weight-id value)))
+     ((equal? object (xft-pattern-object slant))
+      (call (xft-slant-id value)))
+     ((equal? object (xft-pattern-object spacing))
+      (call (xft-spacing-id value)))
+     ((equal? object (xft-pattern-object rgba))
+      (call (xft-rgba-id value)))
+     (else (call value)))))
 
 (define (scx-xft-font-match display screen xft-pattern)
   (call-with-values