- Don't export fontsets --- that'll make memory handling and calling

finalizers much more complicated.  Convert fontset to a list of
  patterns instead.

- Don't add a finalizer to pattern returned xft-font-match.  This
  seems to be the reason for the segfaults.  However, I have to admit
  don't fully understand why this is so.
This commit is contained in:
eknauel 2004-04-27 16:15:19 +00:00
parent 0617270567
commit 7040a29760
3 changed files with 32 additions and 122 deletions

View File

@ -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,8 +31,7 @@ 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)
@ -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))))

View File

@ -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?

View File

@ -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,16 +197,10 @@
(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)
@ -230,39 +208,14 @@
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))
(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))
(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")