Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory cl-net:/tmp/cvs-serv14292/Backends/CLX

Modified Files: medium.lisp port.lisp Log Message: Try to use iso-10646 fonts where appropriate; don't leave the choice of encoding to the server. Patch from Juliusz Chroboczek.

--- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/11/09 19:55:38 1.89 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2009/04/20 10:21:00 1.90 @@ -945,8 +945,8 @@ ;;; is by no means a proper solution to the problem of ;;; internationalization, because fonts tend not to have a complete ;;; coverage of the entirety of the Unicode space, even assuming that -;;; the underlying lisp supports it (as of 2006-02-06, only the case -;;; for SBCL and CLISP); instead, the translation function is meant to +;;; the underlying lisp supports it (this is the case at least for SBCL, +;;; CLISP and CCL); instead, the translation function is meant to ;;; handle font sets by requesting the X server change fonts in the ;;; middle of rendering strings. However, the below stands a chance ;;; of working when using ISO-8859-1-encoded fonts, and will tend to --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2009/04/20 10:14:27 1.139 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2009/04/20 10:21:00 1.140 @@ -980,8 +980,6 @@ :italic-bold "bold-i")) ))

(defun open-font (display font-name) - - (let ((fonts (xlib:list-font-names display font-name :max-fonts 1))) (if fonts (xlib:open-font display (first fonts)) @@ -1013,13 +1011,20 @@ (size-number (if (numberp size) (round size) (or (getf *clx-text-sizes* size) - (getf *clx-text-sizes* :normal)))) - (font-name (format nil "-~A-~A-*-*-~D-*-*-*-*-*-*-*" - family-name face-name size-number))) - (setf (gethash text-style table) - (cons font-name - (open-font (clx-port-display port) font-name))) - font-name)))))) + (getf *clx-text-sizes* :normal))))) + (flet ((try (encoding) + (let* ((fn (format nil "-~A-~A-*-*-~D-*-*-*-*-*-~A" + family-name face-name size-number + encoding)) + (font (open-font (clx-port-display port) fn))) + (and font (cons fn font))))) + (let ((fn-font + (or + (and (> char-code-limit #x100) (try "iso10646-1")) + (try "iso8859-1") + (try "*-*")))) + (setf (gethash text-style table) fn-font) + (car fn-font)))))))))

(defmethod (setf text-style-mapping) (font-name (port clx-port) (text-style text-style)