diff --git a/scheme/examples/hello-xft.scm b/scheme/examples/hello-xft.scm index 897a99d..ee3b3fe 100755 --- a/scheme/examples/hello-xft.scm +++ b/scheme/examples/hello-xft.scm @@ -1,24 +1,15 @@ #!/bin/sh + exec scsh -lel heap-images/load.scm -lel cml/load.scm -lel scx/load.scm -o xlib -o rendezvous-channels -o threads -o srfi-1 -o signals -o xft -o xrender -s "$0" "$@" !# (define *font-size* 36.0) -(define (fontset->list-of-patterns fs) - (let ((count (xft-fontset-count fs)) - (ref (lambda (x) (xft-fontset-ref fs x)))) - (unfold - (lambda (x) (equal? count x)) - ref - (lambda (x) (+ x 1)) - 0))) - (define (list-all-fonts display screen) (let ((p (make-xft-pattern)) (os (make-xft-objectset))) (xft-objectset-add os (xft-pattern-object family)) - (let ((fs (xft-list-fonts-pattern-objects display screen p os))) - (fontset->list-of-patterns fs)))) + (xft-list-fonts-pattern-objects display screen p os))) (define (family-name-of-font font) (call-with-values @@ -40,13 +31,12 @@ exec scsh -lel heap-images/load.scm -lel cml/load.scm -lel scx/load.scm -o xlib (xft-font-match dpy screen copy))) (lambda (result pattern) (cond - ((and (xft-result-match? result) - (xft-font-open-pattern dpy pattern)) + ((xft-font-open-pattern dpy pattern) => (lambda (font) font)) (else (xft-pattern-print pattern) (error "Could not open font!")))))) - + (define (font-demo) (let* ((dpy (open-display)) (screen (display:default-screen dpy)) @@ -95,6 +85,7 @@ exec scsh -lel heap-images/load.scm -lel cml/load.scm -lel scx/load.scm -o xlib (if (null? font-patterns) (loop (list-all-fonts dpy screen) standard-font) (let ((font (open-font dpy screen (car font-patterns)))) + (xft-pattern-print (car font-patterns)) (draw-font-name xft-draw xft-black xft-white font) (loop (cdr font-patterns) font)))) diff --git a/scheme/libs/libs-interfaces.scm b/scheme/libs/libs-interfaces.scm index d439617..56ccb90 100644 --- a/scheme/libs/libs-interfaces.scm +++ b/scheme/libs/libs-interfaces.scm @@ -18,12 +18,6 @@ xft-font-height xft-font-max-advance-width - xft-fontset? - make-xft-fontset - xft-fontset-count - xft-fontset-ref - xft-fontset-add - xft-objectset? make-xft-objectset xft-objectset-add @@ -76,7 +70,6 @@ xft-draw-string-8bit xft-draw-rect xft-draw-set-clip - xft-fontset-print xft-pattern-print xft-default-has-render? diff --git a/scheme/libs/xft.scm b/scheme/libs/xft.scm index 25dfc10..8b6ee2f 100644 --- a/scheme/libs/xft.scm +++ b/scheme/libs/xft.scm @@ -8,8 +8,6 @@ ;; Key is an integer (memory address of the Xft structure), value a ;; weak pointer to the Scheme object. -(define *freed-objects* '()) - (define *object-table* (make-value-weak-table)) @@ -22,19 +20,6 @@ (define (lookup-xft-pointer pointer) (lookup-in-weak-table *object-table* pointer)) -;; Be careful about sequence in which we call the finalizers on Xft -;; objects. There are some dependencies which impose constraints on -;; the sequence we can call the finalizers. Ok, maybe I'm a bit -;; paranoid about that. - -(define (cons-weak obj list) - (cons (make-weak-pointer obj) list)) - -(define (filter-collected list) - (filter (lambda (weak-pointer) - (not (weak-pointer-ref weak-pointer))) - list)) - ;; types (define-record-type xft-pattern :xft-pattern @@ -78,10 +63,9 @@ (define-exported-binding "xft-objectset" :xft-objectset) (define-record-type xft-fontset :xft-fontset - (really-make-xft-fontset c-pointer dependencies) + (really-make-xft-fontset c-pointer) xft-fontset? - (c-pointer xft-fontset-c-pointer) - (dependencies xft-fontset-dependencies set-xft-fontset-dependencies!)) + (c-pointer xft-fontset-c-pointer)) (define-exported-binding "xft-fontset" :xft-fontset) @@ -213,56 +197,25 @@ (error "scx: internal error. Could not map rgba id to finite type")))))) (define (xft-pattern-finalizer pattern) - (if (member (xft-pattern-c-pointer pattern) *freed-objects*) - (error "free() called twice on" pattern) - (set! *freed-objects* (cons (xft-pattern-c-pointer pattern) *freed-objects*))) (unregister-xft-pointer! (xft-pattern-c-pointer pattern)) (xft-pattern-destroy pattern)) (define (xft-color-finalizer color) - (if (member (xft-color-c-pointer color) *freed-objects*) - (error "free() called twice on" color) - (set! *freed-objects* (cons (xft-color-c-pointer color) *freed-objects*))) - (unregister-xft-pointer! (xft-color-c-pointer color)) - (xft-color-free (xft-color-display color) - (xft-color-visual color) + (unregister-xft-pointer! (xft-color-c-pointer color)) + (xft-color-free (xft-color-display color) + (xft-color-visual color) (xft-color-colormap color) color)) (define (xft-draw-finalizer draw) - (if (member (xft-draw-c-pointer draw) *freed-objects*) - (error "free() called twice on" draw) - (set! *freed-objects* (cons (xft-draw-c-pointer draw) *freed-objects*))) - (unregister-xft-pointer! (xft-draw-c-pointer draw)) - (xft-draw-destroy draw)) + (unregister-xft-pointer! (xft-draw-c-pointer draw)) + (xft-draw-destroy draw)) (define (xft-objectset-finalizer objectset) - (if (member (xft-objectset-c-pointer objectset) *freed-objects*) - (error "free() called twice on" objectset) - (set! *freed-objects* (cons (xft-objectset-c-pointer objectset) *freed-objects*))) - (unregister-xft-pointer! (xft-objectset-c-pointer objectset)) - (xft-objectset-destroy objectset)) - -(define (xft-fontset-finalizer fontset) - (cond - ((null? (xft-fontset-dependencies fontset)) - (add-finalizer! fontset xft-fontset-freeing-finalizer)) - (else - (set-xft-fontset-dependencies! - fontset (filter-collected (xft-fontset-dependencies fontset))) - (add-finalizer! fontset xft-fontset-finalizer)))) - -(define (xft-fontset-freeing-finalizer fontset) - (if (member (xft-fontset-c-pointer fontset) *freed-objects*) - (error "free() called twice on" fontset) - (set! *freed-objects* (cons (xft-fontset-c-pointer fontset) *freed-objects*))) - (unregister-xft-pointer! (xft-fontset-c-pointer fontset)) - (xft-fontset-destroy fontset)) + (unregister-xft-pointer! (xft-objectset-c-pointer objectset)) + (xft-objectset-destroy objectset)) (define (xft-font-finalizer font) - (if (member (xft-font-c-pointer font) *freed-objects*) - (error "free() called twice on" font) - (set! *freed-objects* (cons (xft-font-c-pointer font) *freed-objects*))) (unregister-xft-pointer! (xft-font-c-pointer font)) (xft-font-close-internal font)) @@ -333,7 +286,7 @@ => (lambda (obj) (values result obj))) (else (register-xft-pointer! (xft-pattern-c-pointer pattern) pattern) - (add-finalizer! pattern xft-pattern-finalizer) + ;(add-finalizer! pattern xft-pattern-finalizer) (values result pattern))))))) (define (xft-font-open-pattern display pattern) @@ -356,7 +309,7 @@ (define (xft-font-open-xlfd display screen name) (let* ((screen-numer (screen:number screen)) (font (xft-font-open-xlfd-internal display screen-numer name))) - (or (lookup-xft-pointer (xft-font-c-pointer font) font) + (or (lookup-xft-pointer (xft-font-c-pointer font)) (begin (register-xft-pointer! (xft-font-c-pointer font) font) (add-finalizer! font xft-font-finalizer) @@ -411,40 +364,25 @@ (or visual (error "XftDrawVisual() unavailable in this version of Xft")))) +(define (fontset->list-of-patterns fs) + (let ((count (xft-fontset-count fs))) + (unfold + (lambda (x) + (equal? count x)) + (lambda (index) + (xft-pattern-duplicate + (xft-fontset-ref fs index))) + (lambda (x) + (+ x 1)) + 0))) + (define (xft-list-fonts-pattern-objects display screen pattern objectset) (let* ((screen-number (screen:number screen)) (fontset (xft-list-fonts-pattern-objects-internal display screen-number pattern objectset))) - (or (lookup-xft-pointer (xft-fontset-c-pointer fontset)) - (begin - (register-xft-pointer! (xft-fontset-c-pointer fontset) fontset) - (set-xft-fontset-dependencies! fontset '()) - (add-finalizer! fontset xft-fontset-finalizer) - fontset)))) - -(define (make-xft-fontset) - (let ((fontset (xft-fontset-create))) - (or (lookup-xft-pointer (xft-fontset-c-pointer fontset)) - (begin - (register-xft-pointer! (xft-fontset-c-pointer fontset) fontset) - (set-xft-fontset-dependencies! fontset '()) - (add-finalizer! fontset xft-fontset-finalizer) - fontset)))) - -(define (xft-fontset-add fontset pattern) - (set-xft-fontset-dependencies! - fontset (cons-weak pattern (xft-fontset-dependencies fontset))) - (xft-fontset-add-internal fontset pattern)) - -(define (xft-fontset-ref fontset index) - (let ((pattern (xft-fontset-ref-internal fontset index))) - (or (lookup-xft-pointer (xft-pattern-c-pointer pattern)) - (begin - (register-xft-pointer! (xft-pattern-c-pointer pattern) pattern) - (set-xft-fontset-dependencies! - fontset (cons-weak pattern (xft-fontset-dependencies fontset))) - ;(add-finalizer! pattern xft-pattern-finalizer) - pattern)))) + (let ((patterns (fontset->list-of-patterns fontset))) + (xft-fontset-destroy fontset) + patterns))) (define (xft-color-alloc-name display visual colormap name) (call-with-values @@ -616,18 +554,10 @@ (display screen-number pattern objectset) "scx_XftListFontsPatternObjects") -(import-lambda-definition xft-fontset-create - () - "scx_XftFontSetCreate") - (import-lambda-definition xft-fontset-destroy (fontset) "scx_XftFontSetDestroy") -(import-lambda-definition xft-fontset-add-internal - (fontset pattern) - "scx_XftFontSetAdd") - (import-lambda-definition xft-color-alloc-name-internal (display visual colormap name) "scx_XftColorAllocName") @@ -644,10 +574,6 @@ (pattern) "scx_XftPatternPrint") -(import-lambda-definition xft-fontset-print - (fontset) - "scx_XftFontSetPrint") - (import-lambda-definition xft-default-has-render? (display) "scx_XftDefaultHasRender") @@ -676,6 +602,6 @@ (fontset) "scx_xftfontset_count_get") -(import-lambda-definition xft-fontset-ref-internal +(import-lambda-definition xft-fontset-ref (fontset index) "scx_xftfontset_pattern_ref")