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

Modified Files: freetype-fonts.lisp Log Message: Add a little caching to make-vague-font and make-concrete-font; this seems to fix the fd leake in make-concrete-font which eventually results in an unchecked error return code from Freetype and a NULL pointer deref the next time we call into Freetype.

Date: Wed Jun 15 03:34:06 2005 Author: bmastenbrook

Index: mcclim/Experimental/freetype/freetype-fonts.lisp diff -u mcclim/Experimental/freetype/freetype-fonts.lisp:1.5 mcclim/Experimental/freetype/freetype-fonts.lisp:1.6 --- mcclim/Experimental/freetype/freetype-fonts.lisp:1.5 Tue Jun 14 02:07:56 2005 +++ mcclim/Experimental/freetype/freetype-fonts.lisp Wed Jun 15 03:34:06 2005 @@ -35,30 +35,43 @@ ((lib :initarg :lib) (filename :initarg :filename)))

+(defparameter *vague-font-hash* (make-hash-table :test #'equal)) + (defun make-vague-font (filename) - (make-instance 'vague-font - :lib (let ((libf (make-alien freetype:library))) - (declare (type (alien (* freetype:library)) libf)) - (freetype:init-free-type libf) - (deref libf)) - :filename filename)) + (let ((val (gethash filename *vague-font-hash*))) + (or val + (setf (gethash filename *vague-font-hash*) + (make-instance 'vague-font + :lib (let ((libf (make-alien freetype:library))) + (declare (type (alien (* freetype:library)) libf)) + (freetype:init-free-type libf) + (deref libf)) + :filename filename)))))

(defparameter *dpi* 72)

+(defparameter *concrete-font-hash* (make-hash-table :test #'equal)) + (defun make-concrete-font (vague-font size &key (dpi *dpi*)) (with-slots (lib filename) vague-font - (let ((facef (make-alien freetype:face))) - (declare (type (alien (* freetype:face)) facef)) - (freetype:new-face lib filename 0 facef) - (let ((face (deref facef))) - (declare (type (alien freetype:face) face)) - (freetype:set-char-size face 0 (round (* size 64)) (round dpi) (round dpi)) - face)))) + (let* ((key (cons lib filename)) + (val (gethash key *concrete-font-hash*))) + (unless val + (let ((facef (make-alien freetype:face))) + (declare (type (alien (* freetype:face)) facef)) + (if (zerop (freetype:new-face lib filename 0 facef)) + (setf val (setf (gethash key *concrete-font-hash*) + (deref facef))) + (error "Freetype error in make-concrete-font")))) + (let ((face val)) + (declare (type (alien freetype:face) face)) + (freetype:set-char-size face 0 (round (* size 64)) (round dpi) (round dpi)) + face))))

(declaim (inline make-concrete-font))

(defun glyph-pixarray (face char) - (declare (optimize (speed 3) (safety 3) (debug 1)) + (declare (optimize (speed 3) (debug 1)) (inline freetype:load-glyph freetype:render-glyph) (type (alien freetype:face) face)) (freetype:load-glyph face (freetype:get-char-index face (char-code char)) 0)