From 315948f85732b1d09a7892aa71d5446923f4315b Mon Sep 17 00:00:00 2001 From: eknauel Date: Sat, 25 Oct 2003 16:24:46 +0000 Subject: [PATCH] + 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 | 38 ++++++++- c/libs/xft.h | 20 +++++ scheme/libs/libs-interfaces.scm | 31 +++++++- scheme/libs/xft.scm | 132 ++++++++++++++++++++++++++++++-- 4 files changed, 209 insertions(+), 12 deletions(-) diff --git a/c/libs/xft.c b/c/libs/xft.c index 11df351..f5046f7 100644 --- a/c/libs/xft.c +++ b/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); diff --git a/c/libs/xft.h b/c/libs/xft.h index 375051e..61c37a8 100644 --- a/c/libs/xft.h +++ b/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) \ { \ diff --git a/scheme/libs/libs-interfaces.scm b/scheme/libs/libs-interfaces.scm index 373a851..b95155b 100644 --- a/scheme/libs/libs-interfaces.scm +++ b/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 diff --git a/scheme/libs/xft.scm b/scheme/libs/xft.scm index fdeb70e..5a02c9a 100644 --- a/scheme/libs/xft.scm +++ b/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) - (scx-xft-pattern-get-internal - xft-pattern (xft-pattern-object-id xft-pattern-object) id)) - -(define (scx-xft-pattern-add xft-pattern xft-pattern-object value append?) - (scx-xft-pattern-add-internal - xft-pattern (xft-pattern-object-id xft-pattern-object) value append?)) +(define (scx-xft-pattern-get pattern object id) + (let ((object-id (xft-pattern-object-id object))) + (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 pattern object value append?) + (let* ((object-id (xft-pattern-object-id object)) + (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