- 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
parent
0617270567
commit
7040a29760
|
|
@ -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))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
Loading…
Reference in New Issue