[mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-fonts.lisp

[Christophe Rhodes]

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype
In directory common-lisp.net:/tmp/cvs-serv5783/Experimental/freetype

Modified Files:
	freetype-fonts.lisp 
Log Message:
make one more errant cache display-specific.  Now I can destroy ports 
and restart Closure without too many nasty surprises.

(These font caches would be better put in a slot in the port, so that we 
didn't hang on to dead displays in *font-info* and friends)

Date: Thu Jul 14 14:09:24 2005
Author: crhodes

Index: mcclim/Experimental/freetype/freetype-fonts.lisp
diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.8 mcclim/Experimental/freetype/freetype-fonts.lisp:1.9
--- mcclim/Experimental/freetype/freetype-fonts.lisp:1.8	Tue Jul 12 13:45:58 2005
+++ mcclim/Experimental/freetype/freetype-fonts.lisp	Thu Jul 14 14:09:24 2005
@@ -148,8 +148,8 @@
 (defun display-generate-glyph (display font matrix glyph-index)
   (let* ((glyph-id (display-draw-glyph-id display))
          (font (or (gethash font *font-hash*)
-                    (setf (gethash font *font-hash*)
-                          (make-vague-font font))))
+		   (setf (gethash font *font-hash*)
+			 (make-vague-font font))))
          (face (make-concrete-font font matrix)))
     (multiple-value-bind (arr left top dx dy) (glyph-pixarray face (code-char glyph-index))
       (when (= (array-dimension arr 0) 0)
@@ -293,24 +293,24 @@
 (defparameter *free-type-face-hash* (make-hash-table :test #'equal))
 
 (defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) text-style)
-  (multiple-value-bind (family face size) (clim:text-style-components text-style)
-    (setf face (or face :roman))
-    (setf size (or size :normal))
-    (cond (size
-           (setf size (getf *sizes* size size))
-           (let ((val (gethash (list family face size) *free-type-face-hash*)))
-             (if val val
-                 (setf (gethash (list family face size) *free-type-face-hash*)
-                       (let* ((font-path-relative (cdr (assoc (list family face) *families/faces*
-                                                              :test #'equal)))
-                              (font-path (namestring (merge-pathnames font-path-relative *freetype-font-path*))))
-                         (if (and font-path (probe-file font-path))
-                             (make-free-type-face (slot-value port 'clim-clx::display)
-                                                  font-path
-                                                  size)
-                             (call-next-method)))))))
-          (t
-           (call-next-method)))))
+  (multiple-value-bind (family face size) 
+      (clim:text-style-components text-style)
+    (let ((display (clim-clx::clx-port-display port)))
+      (setf face (or face :roman))
+      (setf size (or size :normal))
+      (cond (size
+	     (setf size (getf *sizes* size size))
+	     (let ((val (gethash (list display family face size) *free-type-face-hash*)))
+	       (if val val
+		   (setf (gethash (list display family face size) *free-type-face-hash*)
+			 (let* ((font-path-relative (cdr (assoc (list family face) *families/faces*
+								:test #'equal)))
+				(font-path (namestring (merge-pathnames font-path-relative *freetype-font-path*))))
+			   (if (and font-path (probe-file font-path))
+			       (make-free-type-face display font-path size)
+			       (call-next-method)))))))
+	    (t
+	     (call-next-method))))))
 
 (defmethod clim-clx::text-style-to-X-font ((port clim-clx::clx-port) text-style)
   (error "You lost: ~S." text-style))