[mcclim-cvs] CVS mcclim/Backends/CLX

[crhodes]

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)