- 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.

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)))
+    (xft-list-fonts-pattern-objects display screen p os)))
-      (fontset->list-of-patterns fs))))
 
 (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))))
 

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?
    

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)
+  (c-pointer xft-fontset-c-pointer))
-  (dependencies xft-fontset-dependencies set-xft-fontset-dependencies!))
 
 (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*)
+  (unregister-xft-pointer! (xft-color-c-pointer color))
-      (error "free() called twice on" color)
+  (xft-color-free (xft-color-display color)
-      (set! *freed-objects* (cons (xft-color-c-pointer color) *freed-objects*)))
+		  (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*)
+  (unregister-xft-pointer! (xft-draw-c-pointer draw))
-      (error "free() called twice on" draw)
+  (xft-draw-destroy 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*)
+  (unregister-xft-pointer! (xft-objectset-c-pointer objectset))
-      (error "free() called twice on" objectset)
+  (xft-objectset-destroy 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))
+    (let ((patterns (fontset->list-of-patterns fontset)))
-	(begin
+      (xft-fontset-destroy fontset)
-	  (register-xft-pointer! (xft-fontset-c-pointer fontset) fontset)
+      patterns)))
-	  (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))))
 
 (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")