Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv24145
Modified Files: freetype-fonts.lisp mcclim-freetype.asd Log Message: Cache another routine that gets called alot; remove dependency on this xrender implementation
Date: Sat Jun 18 03:56:44 2005 Author: bmastenbrook
Index: mcclim/Experimental/freetype/freetype-fonts.lisp diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.6 mcclim/Experimental/freetype/freetype-fonts.lisp:1.7 --- mcclim/Experimental/freetype/freetype-fonts.lisp:1.6 Wed Jun 15 03:34:06 2005 +++ mcclim/Experimental/freetype/freetype-fonts.lisp Sat Jun 18 03:56:43 2005 @@ -290,20 +290,25 @@
(fmakunbound 'clim-clx::text-style-to-x-font)
+(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* ((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)))) + (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)))))
Index: mcclim/Experimental/freetype/mcclim-freetype.asd diff -u mcclim/Experimental/freetype/mcclim-freetype.asd:1.1 mcclim/Experimental/freetype/mcclim-freetype.asd:1.2 --- mcclim/Experimental/freetype/mcclim-freetype.asd:1.1 Sun Jun 5 22:50:29 2005 +++ mcclim/Experimental/freetype/mcclim-freetype.asd Sat Jun 18 03:56:43 2005 @@ -12,7 +12,7 @@ (list (component-pathname c)))
(defsystem :mcclim-freetype - :depends-on (:xrender :clim :clx) + :depends-on (:clim :clx) :serial t :components ((:file "freetype-package")