[mcclim-cvs] CVS mcclim/Backends/CLX

[crhodes]

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX
In directory common-lisp:/tmp/cvs-serv22211/Backends/CLX

Modified Files:
	medium.lisp 
Log Message:
Another .gold.ac.uk diff minimization: a translate-function which allows
more than ASCII (and a long comment explaining why this is nowhere near 
the complete solution)


--- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp	2006/01/22 21:17:07	1.71
+++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp	2006/02/17 14:16:39	1.72
@@ -625,45 +625,78 @@
 (defmethod text-style-width (text-style (medium clx-medium))
   (text-style-character-width text-style medium #\m))
 
+(eval-when (:compile-toplevel :execute)
+  ;; ASCII / CHAR-CODE compatibility checking
+  (unless (equal (mapcar #'char-code '(#\Backspace #\Tab #\Linefeed
+                                       #\Page #\Return #\Rubout))
+                 '(8 9 10 12 13 127))
+    (error "~S not ASCII-compatible for semi-standard characters: ~
+           implement a CLX translate function for this implementation."
+           'code-char))
+  (let ((standard-chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~"))
+    (dotimes (i 95)
+      (unless (eql (char standard-chars i) (code-char (+ i 32)))
+        (error "~S not ASCII-compatible for standard character ~S: ~
+                implement a CLX translate function for this implementation."
+               'code-char (code-char (+ i 32)))))))
+
+;;; The default CLX translation function is defined to work only for
+;;; ASCII characters; quoting from the documentation,
+;;;
+;;;   The default :translate function handles all characters that
+;;;   satisfy graphic-char-p by converting each character into its
+;;;   ASCII code.
+;;;
+;;; We provide our own translation function which is essentially the
+;;; same as that of CLX, but with the ASCII restriction relaxed.  This
+;;; 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
+;;; 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
+;;; lose in other cases.
 (defun translate (src src-start src-end afont dst dst-start)
-  ;; This is for replacing the clx-translate-default-function
-  ;; who does'nt know about accentated characters because
-  ;; of a call to cl:graphic-char-p that return nil with accentated characters.
-  ;; For further informations, on a clx-translate-function, see the clx-man.
   (declare (type sequence src)
 	   (type xlib:array-index src-start src-end dst-start)
 	   (type (or null xlib:font) afont)
 	   (type vector dst))
-  #+cmucl(declare (xlib::clx-values integer
-				    (or null integer xlib:font)
-				    (or null integer)))
+  ;; FIXME: what if AFONT is null?
   (let ((min-char-index (xlib:font-min-char afont))
 	(max-char-index (xlib:font-max-char afont)))
-    afont
     (if (stringp src)
 	(do ((i src-start (xlib::index+ i 1))
 	     (j dst-start (xlib::index+ j 1))
 	     (char))
 	    ((xlib::index>= i src-end)
 	     i)
-	    (declare (type xlib:array-index i j))
-	    (setq char (xlib:char->card8 (char src i)))
-	    (if (or (< char min-char-index) (> char max-char-index))
-		(return i)
-	        (setf (aref dst j) char)))
+          (declare (type xlib:array-index i j))
+          (setq char (char-code (char src i)))
+          (if (or (< char min-char-index) (> char max-char-index))
+              (progn
+                (warn "Character ~S not representable in font ~S" 
+                      (char src i) afont)
+                (return i))
+              (setf (aref dst j) char)))
         (do ((i src-start (xlib::index+ i 1))
 	     (j dst-start (xlib::index+ j 1))
 	     (elt))
 	    ((xlib::index>= i src-end)
 	     i)
-	    (declare (type xlib:array-index i j))
-	    (setq elt (elt src i))
-	    (when (characterp elt) (setq elt (xlib:char->card8 elt)))
-	    (if (or (not (integerp elt)) 
-		    (< elt min-char-index)
-		    (> elt max-char-index))
-		(return i)
-	        (setf (aref dst j) elt))))))
+          (declare (type xlib:array-index i j))
+          (setq elt (elt src i))
+          (when (characterp elt) 
+            (setq elt (char-code elt)))
+          (if (or (not (integerp elt)) 
+                  (< elt min-char-index)
+                  (> elt max-char-index))
+              (progn
+                (warn "Thing ~S not representable in font ~S"
+                      (elt src i) afont)
+                (return i))
+              (setf (aref dst j) elt))))))
 
 (defmethod text-size ((medium clx-medium) string &key text-style (start 0) end)
   (when (characterp string)