diff --git a/ChangeLog.n b/ChangeLog.n
index 4fcbbdba9d3755c6422710e9fa38d4eebb4b9a62..149628e55c3d3f15eff27ef4a3f4a6111fd9b4df 100644
--- a/ChangeLog.n
+++ b/ChangeLog.n
@@ -1,3 +1,27 @@
+2007-12-11  Andreas Fuchs  <afuchs@franz.com>
+
+	* clim/text-formatting.lisp: Add filling-stream-conditional-newline,
+	  fix an off-by-1 bug for non-whitespace fill characters.
+	* misc/MyDrawingA.c: create clim drawing panes with an XIC.
+	* demo/japanese-graphics-editor.lisp: convert encoding to utf-8.
+	* aclpc/acl-widget.lisp: Fix the cursor-position code to report correct
+	  numbers for the end of the buffer and past newlines.
+	* silica/classes.lisp, silica/text-style.lisp, tk/font.lisp, tk/graphics.lisp,
+	  tk/resources.lisp, tk/widget.lisp, tk/xlib.lisp, tk/xm-defs.lisp,
+	  tk/xm-font-list.lisp, tk/xm-funs.lisp, tk/xm-widgets.lisp,
+	  tk/xt-defs.lisp, tk/xt-funs.lisp, tk-silica/xm-frames.lisp,
+	  tk-silica/xm-gadgets.lisp, tk-silica/xm-silica.lisp,
+	  tk-silica/xt-graphics.lisp, tk-silica/xt-silica.lisp, utils/lisp-utilities.lisp,
+	  xlib/xlib-defs.lisp, xlib/xlib-funs.lisp:
+	  Change the X/Motif backend to support international character input/output
+	  (in most places):
+	  * Use the locale-provided external format for string->foreign-octet conversion,
+	  * Use XmImMbLookupString to lookup key on key press events,
+	  * Use XmbStringDraw to display non-rotated multibyte text,
+	  * Search the installed fonts for encodings CLIM doesn't know about and add them
+	    to the default font set, and
+	  * Set up the Xt locale correctly.
+	
 2007-07-18  Kevin Layer  <layer@gemini.franz.com>
 
 	* tk-silica/xt-silica.lisp (restart-port): bug16740: fix badly
@@ -6190,4 +6214,4 @@ IGNORE JDI SPECIFIC CHANGES TO Makefile
 	Lots of other stuff
 
 *******************************************************************************
-$Revision: 2.36 $
+$Revision: 2.37 $
diff --git a/aclpc/acl-widget.lisp b/aclpc/acl-widget.lisp
index 3748177961c06f1e11b7b09b6c4c891aa1e30476..2c2127e6638db0d1516b3851b9184f6e2ccca7d5 100644
--- a/aclpc/acl-widget.lisp
+++ b/aclpc/acl-widget.lisp
@@ -17,7 +17,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: acl-widget.lisp,v 2.14 2007/04/25 20:29:26 layer Exp $
+;; $Id: acl-widget.lisp,v 2.15 2007/12/11 17:20:20 layer Exp $
 
 #|****************************************************************************
 *                                                                            *
@@ -289,7 +289,13 @@
 ;; the min height in a +text-field-view+ is zero.  At some
 ;; point, lets try modifying +text-field-view+ and 
 ;; +text-editor-view+ to supply better default sizes than zero.
-(defvar *min-text-field-width* 75)
+;;
+;; 2007-09-03/afuchs: This used to be *min-text-field-width. The
+;; minimum width was computed twice. So far, this didn't work too well
+;; for text boxes in accepting-values panes that should be smaller
+;; than 75 pixels. min-w seems to work better, so let's use that
+;; instead, and use 75 as a default width.
+(defvar *default-text-field-width* 75)
 (defvar *min-text-field-height* '(1 :line))
 
 (defmethod compose-space ((pane mswin-text-edit) &key width height)
@@ -313,14 +319,14 @@
 	       ;; This is where accepting-values views factors in.
 	       (setq w (max (process-width-specification 
 			     pane (space-requirement-width initial-space-requirement))
-			    *min-text-field-width*)))
+			    min-w)))
 	      (ncolumns
 	       (setq w (process-width-specification pane `(,ncolumns :character))))
 	      ((stringp value)
 	       (setq w (max (process-width-specification pane value)
-			    *min-text-field-width*)))
+			    min-w)))
 	      (t
-	       (setq w *min-text-field-width*)))
+	       (setq w *default-text-field-width*)))
 	(when (member scroll-mode '(:horizontal :both t :dynamic))
 	  ;; Allow for the vertical scrollbar
 	  (let ((wsty (win-scroll-thick :y)))
@@ -443,24 +449,29 @@
   (let ((mirror (sheet-direct-mirror pane)))
     (when mirror
       (let* ((val (slot-value pane 'value))
-	     (val-len (if val (length val) 0)))
-	;; For endpos = -1, means the end.
-	(when (= endpos -1)
-	  (setq endpos val-len))
-	;; Ensure the correct order.
-	(when (< endpos startpos)
-	  (let ((temp endpos))
-	    (setf endpos startpos
-		  startpos temp)))
-	;; Otherwise, trim to fit.
-	(when (< val-len endpos)
-	  (setq endpos val-len))
-	(when (< startpos 0) 
-	  (setq startpos 0))
-	(acl-clim::frame-send-message (pane-frame pane)
-				      mirror
-				      win:EM_SETSEL
-				      startpos endpos)))))
+           (val-len (if val
+                          (+ (length val)
+                             (count #\newline val))
+                          0)))
+                          ;; For endpos = -1, means the end.
+                          (when (= endpos -1)
+                            (setq endpos val-len))
+                            ;; Ensure the correct order.
+                            (when (< endpos startpos)
+                              (let ((temp endpos))
+                                  (setf endpos startpos
+                                          startpos temp)))
+                                          ;; Otherwise, trim to fit.
+        (when (< val-len endpos)
+          (setq endpos val-len))
+        (when (< val-len startpos)
+          (setq startpos val-len))
+          (when (< startpos 0)
+            (setq startpos 0))
+            (acl-clim::frame-send-message (pane-frame pane)
+                                          mirror
+                                          win:EM_SETSEL
+                                          startpos endpos)))))
 
 ;;; Retreive the start and end position of the
 ;;; selection in a mswin-text-edit gadget.
@@ -709,14 +720,14 @@
 	       ;; This is where accepting-values views factors in.
 	       (setq w (max (process-width-specification 
 			     pane (space-requirement-width initial-space-requirement))
-			    *min-text-field-width*)))
+			    min-w)))
 	      (ncolumns
 	       (setq w (process-width-specification pane `(,ncolumns :character))))
 	      ((stringp value)
 	       (setq w (max (process-width-specification pane value)
-			    *min-text-field-width*)))
+			    min-w)))
 	      (t
-	       (setq w (process-width-specification pane `(20 :character)))))
+	       (setq w *default-text-field-width*)))
 	(setq w (max w min-w))
 
 	;; HEIGHT
@@ -812,8 +823,10 @@
     ;; two characters (newline and return) for each
     ;; newline, so we need to correct the cursor.
     (let ((result 0))
-      (loop for c across text
-            with actual = 0
+      (loop with actual = 0
+            for c = (if (< result (length text))
+                        (char text result)
+                        #\Space)
             while (< actual windows-cursor)
             do (progn
                  (incf actual
@@ -821,7 +834,6 @@
                  (incf result)))
       result)))
 
-
 (defmethod (setf text-field-cursor) (cursor (text-field mswin-text-edit))
   (let* ((text (clim:gadget-value text-field))
          ;; Add 1 for each newline before the cursor.
diff --git a/clim/text-formatting.lisp b/clim/text-formatting.lisp
index c8a67486960861b4c8f966f62111b2a6d0a440c4..9641db4a12f872e93e97fc919bbda46537733e8a 100644
--- a/clim/text-formatting.lisp
+++ b/clim/text-formatting.lisp
@@ -17,7 +17,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: text-formatting.lisp,v 2.8 2007/04/17 21:45:51 layer Exp $
+;; $Id: text-formatting.lisp,v 2.9 2007/12/11 17:20:20 layer Exp $
 
 (in-package :clim-internals)
 
@@ -26,13 +26,14 @@
 ;;; Filling output
 
 (defclass filling-stream (standard-encapsulating-stream)
-    (fill-width
-     break-characters
-     prefix
-     prefix-width
-     current-width
-     old-buffers
-     (buffer :initarg :buffer)))
+     (fill-width
+      break-characters
+      prefix
+      prefix-width
+      current-width
+      old-buffers
+      on-fresh-line
+      (buffer :initarg :buffer)))
 
 (defun flush-buffer-to-stream/filling (stream buffer &optional start end)
   (setf start (or start 0)
@@ -55,6 +56,10 @@
       (write-string (first buffer-entry) s))
     (write-string (slot-value filling-stream 'buffer) s)))
 
+(defun break-character-predicate (stream)
+  (lambda (c)
+    (member c (slot-value stream 'break-characters))))
+
 (defun filling-stream-flush-continuations (filling-stream force-p)
   "Returns a list of continuations that, when invoked in order,
 will flush a filling-stream's buffer until the last break
@@ -71,84 +76,92 @@ the filling-stream's old-buffers list."
                (flush-buffer-to-stream/filling stream buffer start end))))) 
     (labels ((delete-buffer-entry (buffer-entry)
                (setf (slot-value filling-stream 'old-buffers)
-                     (delete buffer-entry (slot-value filling-stream 'old-buffers)))))
+                     (delete buffer-entry (slot-value filling-stream 'old-buffers))))
+             (buffer-flusher (buffer-entry &optional (length (length (first buffer-entry)))
+                                           (delete-p t))
+               (destructuring-bind (buffer stream continuation) buffer-entry
+                 (lambda ()
+                   (funcall continuation stream buffer 0 length)
+                   (when delete-p
+                     (delete-buffer-entry buffer-entry))))))
       ;; from youngest buffer entry to the oldest (i.e. right to left)
       ;; search for break-characters; if found, flush & remove all
       ;; earlier buffers, then flush that buffer until occurrence.
       (loop for (buffer-entry . rest) on (cons current-buffer-entry
                                                (slot-value filling-stream 'old-buffers))
-            for (buffer stream continuation) = buffer-entry
+            for (buffer) = buffer-entry
             for last-break-char-pos
               = (position-if #'(lambda (c) (member c break-characters))
                          buffer :from-end t)
             when (or last-break-char-pos force-p)
               do (return
                    (values
-                    (prog1
-                      (nreverse (cons   ; flush the found buffer last
-                                 (lambda ()
-                                   (funcall continuation
-                                            stream buffer
-                                            0
-                                            (if force-p (length buffer) last-break-char-pos))
-                                   (when (or force-p (zerop (length buffer)))
-                                     (delete-buffer-entry buffer-entry)))
-                                 ;; but first, flush the buffers before it.
-                                 (mapcar
-                                  (lambda (buffer-entry)
-                                    (destructuring-bind (buffer stream continuation)
-                                        buffer-entry
-                                      (lambda ()
-                                        (funcall continuation
-                                                 stream buffer 0 (length buffer))
-                                        (delete-buffer-entry buffer-entry))))
-                                  rest))))
+                    (nreverse (cons     ; flush the found buffer last
+                               (buffer-flusher buffer-entry
+                                               (if force-p
+                                                   (length buffer)
+                                                   (1+ last-break-char-pos))
+                                               (or force-p (zerop (length buffer))))
+                               ;; but first, flush the buffers before it.
+                               (mapcar
+                                (lambda (buffer-entry)
+                                  (buffer-flusher buffer-entry))
+                                rest)))
                     last-break-char-pos))))))
 
 (defmethod filling-stream-write-buffer ((filling-stream filling-stream) &optional force-p)
-  (with-slots (current-width) filling-stream
+  (with-slots (current-width on-fresh-line) filling-stream
      (let ((stream (slot-value filling-stream 'stream))
            (buffer (slot-value filling-stream 'buffer))
-           (old-buffers (slot-value filling-stream 'old-buffers))
            (fill-width (slot-value filling-stream 'fill-width))
-           (on-fresh-line nil))
-       
+           (should-be-finished-now nil))
        (labels ((break-line-now ()
                   (stream-terpri stream)
                   (filling-stream-handle-line-break filling-stream)
-                  (setq on-fresh-line t)))
+                  (setf on-fresh-line t)))
          (loop
-          (when (and (null old-buffers)
-                     (zerop (fill-pointer buffer))) ;Buffer empty and no delayed buffers.
-            (return-from filling-stream-write-buffer nil))
-          (unless (or (> current-width fill-width)
-                      force-p)        ;Haven't reached the fill column
-            (return-from filling-stream-write-buffer nil))
-          ;; We have a line that is larger than the fill column. it
-          ;; needs to be broken.
-          (multiple-value-bind (flush-continuations found-break-chars)
-              (filling-stream-flush-continuations filling-stream force-p)
-            ;; output the (possibly delayed) buffer contents until the break char.
-            (dolist (continuation flush-continuations)
-              (funcall continuation))
-
-            (cond ((and (not force-p) found-break-chars)
-                   ;; Found a break char that's just before the max width
-                   (break-line-now))
-                  (force-p
-                   ;; flush was forced. We should have written
-                   ;; everything now, so bail out.
-                   (return-from filling-stream-write-buffer nil))
-                  ((not force-p)
-                   ;; this line doesn't fit, and there are no break
-                   ;; chars.  write the line on a fresh line anyway,
-                   ;; and open a fresh line after that.
-                   (unless on-fresh-line
-                     (break-line-now))
-                   (let ((force-continuations (filling-stream-flush-continuations filling-stream t)))
-                     (dolist (continuation force-continuations)
-                       (funcall continuation)))
-                   (break-line-now)))))))))
+           (let ((old-buffers (slot-value filling-stream 'old-buffers)))
+             (when (and (null old-buffers)
+                        (zerop (fill-pointer buffer))) ;Buffer empty and no delayed buffers.
+               (return-from filling-stream-write-buffer nil))
+             (unless (or (> current-width fill-width)
+                         force-p)     ;Haven't reached the fill column
+               (return-from filling-stream-write-buffer nil))
+
+             (assert (not should-be-finished-now)
+                     (should-be-finished-now)
+                     "whoa, buffer is ~S, old-buffers ~S, fill-pointer at ~A"
+                     buffer old-buffers (fill-pointer buffer))
+                       
+             ;; We have a line that is larger than the fill column. it
+             ;; needs to be broken.
+             (multiple-value-bind (flush-continuations found-break-chars)
+                 (filling-stream-flush-continuations filling-stream
+                                                     force-p)
+               ;; output the (possibly delayed) buffer contents until the break char.
+               (dolist (continuation flush-continuations)
+                 (setf on-fresh-line nil)
+                 (funcall continuation))
+
+               (cond ((and (not force-p) found-break-chars)
+                      ;; Found a break char that's just before the max width
+                      (break-line-now))
+                     (force-p
+                      ;; flush was forced. We should have written
+                      ;; everything now, so bail out.
+                      (return-from filling-stream-write-buffer nil))
+                     ((not force-p)
+                      ;; this line doesn't fit, and there are no break
+                      ;; chars.  write the line on a fresh line anyway,
+                      ;; and open a fresh line after that.
+                      (unless on-fresh-line
+                        (break-line-now))
+                      (let ((force-continuations
+                             (filling-stream-flush-continuations filling-stream
+                                                                 t)))
+                        (dolist (continuation force-continuations)
+                          (setf on-fresh-line nil)
+                          (funcall continuation))))))))))))
 
 ;; Write the prefix string and then set the current width
 (defmethod filling-stream-handle-line-break ((filling-stream filling-stream))
@@ -178,61 +191,67 @@ the filling-stream's old-buffers list."
 
 (defmethod stream-write-char ((filling-stream filling-stream) char)
   (with-slots (current-width) filling-stream
-    (let ((stream (slot-value filling-stream 'stream))
-          (fill-width (slot-value filling-stream 'fill-width))
-          (buffer (slot-value filling-stream 'buffer)))
-      (cond ((or (eql char #\Newline)
-                 (eql char #\Return))
-             (stream-terpri filling-stream))
-            (t
-             (vector-push-extend char buffer)
-             (incf current-width (text-size stream char))
-             ;; FILLING-STREAM-WRITE-BUFFER will only do something if we
-             ;; are beyond the fill-width, so optimize calls to it
-             (when (> current-width fill-width)
-               (filling-stream-write-buffer filling-stream)))))))
+     (let* ((stream (slot-value filling-stream 'stream))
+            (fill-width (slot-value filling-stream 'fill-width))
+            (text-size (text-size stream char))
+            (break-chars (slot-value filling-stream 'break-characters))
+            (buffer (slot-value filling-stream 'buffer)))
+       (cond ((or (eql char #\Newline)
+                  (eql char #\Return))
+              (stream-terpri filling-stream))
+             ((and (> (+ current-width text-size) fill-width)
+                   (member char break-chars))
+              (stream-terpri filling-stream)
+              )
+             (t
+              (vector-push-extend char buffer)
+              (incf current-width text-size)
+              ;; FILLING-STREAM-WRITE-BUFFER will only do something if we
+              ;; are beyond the fill-width, so optimize calls to it
+              (when (> current-width fill-width)
+                (filling-stream-write-buffer filling-stream)))))))
 
 (defmethod stream-write-string ((filling-stream filling-stream) string
                                 &optional (start 0) end)
   (with-slots (current-width) filling-stream
-    (when (null end)
-      (setq end (length string)))
-    (let ((stream (slot-value filling-stream 'stream))
-          (fill-width (slot-value filling-stream 'fill-width))
-          (buffer (slot-value filling-stream 'buffer))
-          (break-characters (slot-value filling-stream 'break-characters)))
-      ;; The general scheme here is to find a break character,
-      ;; buffer the string up to the break character, then call
-      ;; STREAM-WRITE-CHAR on the break character to do the
-      ;; necessary bookkeeping
-      (loop
-        (let* ((break (position-if #'(lambda (char)
-                                       (or (eql char #\Newline)
-                                           (eql char #\Return)
-                                           (member char break-characters)))
-                                   string :start start :end end))
-               (width (text-size stream string
-                                 :start start :end (or break end))))
-          (when (or (null break) (> break 0))
-            (let* ((ofp (fill-pointer buffer))
-                   (nfp (+ ofp (- (or break end) start))))
-              (when (> nfp (array-dimension buffer 0))
-                (adjust-array buffer (+ nfp nfp)))
-              (setf (fill-pointer buffer) nfp)
-              (replace buffer string
-                       :start1 ofp
-                       :start2 start :end2 break)))
-          (incf current-width width)
-          ;; We might need to flush the buffer before we insert
-          ;; the next break character
-          (when (> current-width fill-width)
-            (filling-stream-write-buffer filling-stream))
-          (cond (break
-                 (stream-write-char filling-stream (aref string break))
-                 (setq start (1+ break))
-                 (when (>= start end)
-                   (return)))
-                (t (return))))))))
+     (when (null end)
+       (setq end (length string)))
+     (let ((stream (slot-value filling-stream 'stream))
+           (fill-width (slot-value filling-stream 'fill-width))
+           (buffer (slot-value filling-stream 'buffer))
+           (break-characters (slot-value filling-stream 'break-characters)))
+       ;; The general scheme here is to find a break character,
+       ;; buffer the string up to the break character, then call
+       ;; STREAM-WRITE-CHAR on the break character to do the
+       ;; necessary bookkeeping
+       (loop
+         (let* ((break (position-if #'(lambda (char)
+                                        (or (eql char #\Newline)
+                                            (eql char #\Return)
+                                            (member char break-characters)))
+                                    string :start start :end end))
+                (width (text-size stream string
+                        :start start :end (or break end))))
+           (when (or (null break) (> break 0))
+             (let* ((ofp (fill-pointer buffer))
+                    (nfp (+ ofp (- (or break end) start))))
+               (when (> nfp (array-dimension buffer 0))
+                 (adjust-array buffer (+ nfp nfp)))
+               (setf (fill-pointer buffer) nfp)
+               (replace buffer string
+                :start1 ofp
+                :start2 start :end2 break)))
+           (incf current-width width)
+           ;; We might need to flush the buffer before we insert
+           ;; the next break character
+           (when (> current-width fill-width)
+             (filling-stream-write-buffer filling-stream))
+           (cond (break
+                  (stream-write-char filling-stream (aref string break))
+                  (setq start (1+ break))
+                  (when (>= start end)
+                    (return)))
+                 (t (return))))))))
 
 (defmethod stream-force-output ((filling-stream filling-stream))
   (filling-stream-write-buffer filling-stream t))
@@ -274,16 +293,39 @@ the filling-stream's old-buffers list."
                             #'invoke-with-output-recording-options
                             continuation record draw))
 
-(defmethod stream-close-text-output-record ((filling-stream filling-stream)
-                                            &optional wrapped)
+(defmethod stream-close-text-output-record :around ((filling-stream filling-stream)
+                                                    &optional wrapped)
+  (filling-stream-write-buffer filling-stream t)
   (save-buffer-and-continue filling-stream filling-stream
                             #'stream-close-text-output-record wrapped))
 
+(defmethod invoke-with-new-output-record :around ((filling-stream filling-stream)
+                                                  function record-type
+                                                  constructor &rest initargs)
+  (declare (ignorable initargs constructor record-type function))
+  (filling-stream-write-buffer filling-stream t)
+  (call-next-method))
+
 (defun make-filling-stream-buffer ()
   (make-array 100 :element-type 'character
               :fill-pointer 0
               :adjustable t))
 
+;;; Explicit newline hints on the filling stream
+(defmethod filling-stream-conditional-newline (stream &key force &allow-other-keys)
+  (when force (terpri stream)))
+
+(defmethod filling-stream-conditional-newline ((stream filling-stream)
+                                               &key force (space-for "")
+                                               (text-face (text-style-face (medium-merged-text-style stream)))
+                                               (text-size (text-style-size (medium-merged-text-style stream)))
+                                               (text-family (text-style-family (medium-merged-text-style stream))))
+  (when (or force
+            (> (+ (text-size stream space-for :text-style (make-text-style text-family text-face text-size))
+                  (slot-value stream 'current-width))
+               (slot-value stream 'fill-width)))
+    (terpri stream)))
+
 (defresource filling-stream (stream fill-width break-characters prefix prefix-width)
   :constructor
     (make-instance 'filling-stream
@@ -301,7 +343,8 @@ the filling-stream's old-buffers list."
       (setf (fill-pointer (slot-value filling-stream 'buffer)) 0)
       (setf (slot-value filling-stream 'current-width)
         (stream-cursor-position stream))
-      (setf (slot-value filling-stream 'old-buffers) nil)))
+      (setf (slot-value filling-stream 'old-buffers) nil)
+      (setf (slot-value filling-stream 'on-fresh-line) t)))
 
 (defun invoke-filling-output (stream continuation
                               &key (fill-width '(80 :character))
diff --git a/demo/japanese-graphics-editor.lisp b/demo/japanese-graphics-editor.lisp
index 2f01b6681f3a346e944fb7905911b7d24e44aa85..e435a62588e3a424a3419d807656ba2ca0acbf2f 100644
--- a/demo/japanese-graphics-editor.lisp
+++ b/demo/japanese-graphics-editor.lisp
@@ -17,7 +17,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: japanese-graphics-editor.lisp,v 2.7 2007/04/17 21:45:51 layer Exp $
+;; $Id: japanese-graphics-editor.lisp,v 2.8 2007/12/11 17:20:20 layer Exp $
 
 (in-package :japanese-graphics-editor)
 
@@ -29,7 +29,7 @@
 ;;; with the correct external-format.
 (eval-when (compile)
   (when (streamp comp::*compile-file-stream*)
-    (setf (stream-external-format comp::*compile-file-stream*) :euc)))
+    (setf (stream-external-format comp::*compile-file-stream*) :utf8)))
 
 #-ics
 (eval-when (compile)
@@ -278,11 +278,11 @@
 (define-command-table graphics-editor-file-commands)
 
 (define-command-table graphics-editor-edit-commands
-    :menu (("���ä�" :command (com-deselect-object))
+    :menu (("取り消し" :command (com-deselect-object))
 	   ("divide1" :divider nil)
-	   ("���ꥢ��" :command (com-clear))
+	   ("クリアー" :command (com-clear))
 	   ("divide2" :divider nil)
-	   ("��ɽ��" :command (com-redisplay))))
+	   ("再表示" :command (com-redisplay))))
 
 (define-command-table graphics-editor-option-commands)
 
@@ -299,9 +299,9 @@
 				   graphics-editor-edit-commands
 				   graphics-editor-option-commands)
 		    :inherit-menu :keystrokes
-		    :menu (("�ե�����" :menu graphics-editor-file-commands :mnemonic #\F :documentation "�ե�����")
-			   ("�Խ�" :menu graphics-editor-edit-commands :mnemonic #\E )
-			   ("���ץ����" :menu graphics-editor-option-commands :mnemonic #\O))))
+		    :menu (("ファイル" :menu graphics-editor-file-commands :mnemonic #\F :documentation "ファイル")
+			   ("編集" :menu graphics-editor-edit-commands :mnemonic #\E )
+			   ("オプション" :menu graphics-editor-option-commands :mnemonic #\O))))
   (:pointer-documentation t)
   ;; Three panes: a display pane, and command menu, and a modeless
   ;; dialog containing the line style options
@@ -339,13 +339,13 @@
 	(:fill display)))))
 
 (defmethod frame-menu-translator-documentation ((frame graphics-editor))
-  "��˥塼")
+  "メニュー")
 
 (defmethod frame-pointer-button-documentation ((frame graphics-editor) button)
   (case button
-    (:left "��")
-    (:middle "��")
-    (:right "��")))
+    (:left "左")
+    (:middle "中")
+    (:right "右")))
 
 ;; Perhaps these need to be localized. At present this method is
 ;; identical to that on standard-application-frame.
@@ -371,7 +371,7 @@
 
 (define-presentation-method describe-presentation-type ((type line-thickness) stream plural-count)
   (declare (ignore plural-count))
-  (write-string  "����" stream))
+  (write-string  "太さ" stream))
 
 (defun present-line-thickness (object stream &key acceptably)
   (declare (ignore acceptably))
@@ -394,7 +394,7 @@
 
 (define-presentation-method describe-presentation-type ((type line-style-type) stream plural-count)
   (declare (ignore plural-count))
-  (write-string  "�饤�󥿥���" stream))
+  (write-string  "ラインタイプ" stream))
 
 (defun present-line-style (object stream &key acceptably)
   (declare (ignore acceptably))
@@ -423,7 +423,7 @@
 
 (define-presentation-method describe-presentation-type ((type object-shape) stream plural-count)
   (declare (ignore plural-count))
-  (write-string "��" stream))
+  (write-string "形" stream))
 
 (defun present-object-shape (object stream &key acceptably)
   (declare (ignore acceptably))
@@ -467,16 +467,16 @@
 		       (dashes (line-style-dashes style)))
 		   (multiple-value-bind (thickness thickness-changed)
 		       (accept stream 'line-thickness thickness
-			       "����" 'thickness)
+			       "太さ" 'thickness)
 		     (declare (ignore ignore))
 		     (multiple-value-bind (dashes dashes-changed)
 			 (accept stream 'line-style-type (if dashes :dashed :solid)
-				 "�饤�󥿥���" 'dashes)
+				 "ラインタイプ" 'dashes)
 		       (declare (ignore ignore))
 		       (setq dashes (eq dashes :dashed))
 		       (multiple-value-bind (new-shape shape-changed)
 			   (accept stream 'object-shape shape
-				   "��" 'shape)
+				   "形" 'shape)
 			 (when (or thickness-changed dashes-changed shape-changed)
 			   (setq style (make-line-style :thickness thickness
 							:dashes dashes))
@@ -498,7 +498,7 @@
   (dolist (object (slot-value frame 'objects))
     (draw-object object stream)))
 
-(define-graphics-editor-command (com-create-box :name "�ܥå���������")
+(define-graphics-editor-command (com-create-box :name "ボックスの成作")
     ((left 'integer)
      (top 'integer))
   (com-deselect-object)
@@ -507,7 +507,7 @@
 	(bottom top)
 	(rectangle-drawn nil)
 	(box nil)
-	(label (format nil "�ܥå��� ~D" (slot-value *application-frame* 'counter)))
+	(label (format nil "ボックス ~D" (slot-value *application-frame* 'counter)))
 	(last-box (slot-value *application-frame* 'last-box))
 	(style (slot-value *application-frame* 'style))
 	(shape (slot-value *application-frame* 'shape))
@@ -574,7 +574,7 @@
   (list x y))
 
 ;; Select an object by clicking "select" (Mouse-Left) on it.
-(define-graphics-editor-command (com-select-box :name "�ܥå���������")
+(define-graphics-editor-command (com-select-box :name "ボックスの選択")
     ((object 'box :gesture :select))
   (select-object *application-frame* object)
   (setf (slot-value *application-frame* 'style) (object-style object)
@@ -583,14 +583,14 @@
 ;; Deselect an object by clicking the Deselect menu button, or by
 ;; clicking over blank area without moving the mouse.
 (define-command (com-deselect-object :command-table graphics-editor-edit-commands
-				     :menu ("���ä�"
-					    :documentation "���򤷤��ܥå����򥭥�󥻥뤹�롣"))
+				     :menu ("取り消し"
+					    :documentation "選択したボックスをキャンセルする。"))
     ()
   (when (frame-selected-object *application-frame*)
     (deselect-object *application-frame* (frame-selected-object *application-frame*))))
 
 ;; Move an object by clicking Mouse-Middle on it and dragging the mouse.
-(define-graphics-editor-command (com-move-object :name "�ܥå����ΰ�ư")
+(define-graphics-editor-command (com-move-object :name "ボックスの移動")
     ((object 'box :gesture :describe))
   (let ((stream (get-frame-pane *application-frame* 'display)))
     (with-bounding-rectangle* (left top right bottom) object
@@ -624,7 +624,7 @@
     (setf (box-arrow-in box2) nil)))
 
 ;; Add a menu item that deletes the selected object
-(add-menu-item-to-command-table 'graphics-editor "���"
+(add-menu-item-to-command-table 'graphics-editor "削除"
   :function 'delete-selected-object
   :keystroke '(#\d :control))
 
@@ -648,8 +648,8 @@
 (define-command (com-clear :command-table
 			   graphics-editor-edit-commands
 			   :keystroke (#\\ :control)
-			   :menu ("���ꥢ��"
-				  :documentation "�����꡼��򥯥�䡼�ˤ��롣"))
+			   :menu ("クリアー"
+				  :documentation "スクリーンをクリヤーにする。"))
     ()
   (with-slots (objects selected-object last-box) *application-frame*
     (setq objects nil
@@ -661,22 +661,22 @@
 ;; it's only here for debugging.
 (define-command (com-redisplay :command-table graphics-editor-edit-commands
 			       :keystroke (:r :meta)
-			       :menu  ("��ɽ��"
+			       :menu  ("再表示"
 				       :documentation
-				       "�ܥå�����⤦����ɽ������"))
+				       "ボックスをもう一度表示する"))
 
     ()
   (redisplay-frame-pane *application-frame* 'display :force-p t))
 
 (define-command (com-quit :command-table graphics-editor-file-commands
 			  :keystroke (:x :meta)
-			  :menu ("�Ĥ���" :documentation "�ץ�������λ���ޤ���")) ()
+			  :menu ("閉じる" :documentation "プログラムを終了します。")) ()
   (frame-exit *application-frame*))
 
 (define-command (com-change-layout :command-table graphics-editor-option-commands
 				   :keystroke (:l :meta)
-				   :menu ("�쥤�����Ȥ�����"
-					  :documentation "�쥤�����Ȥ�����"))
+				   :menu ("レイアウトの選択"
+					  :documentation "レイアウトの選択"))
     ()
   (let ((layouts (frame-all-layouts *application-frame*)))
     (setf (frame-current-layout *application-frame*)
@@ -686,7 +686,7 @@
 
 
 
-(define-demo "������Խ�" graphics-editor
+(define-demo "グラフ編集" graphics-editor
   :left 100 :top 100 :width 800 :height 500)
 
 )) ;; ics-target-case
diff --git a/misc/MyDrawingA.c b/misc/MyDrawingA.c
index d7700cae8a8050b671fc27e835611b6a2d8f84ff..fd05f9542478773491f2e0561f3c1ce892bba25f 100644
--- a/misc/MyDrawingA.c
+++ b/misc/MyDrawingA.c
@@ -1,4 +1,4 @@
-/*				-[Tue Apr 17 14:44:44 2007 by layer]-
+/*				-[Tue Dec 11 09:11:40 2007 by layer]-
  *
  * copyright (c) 1992-2002 Franz Inc, Berkeley, CA  All rights reserved.
  * copyright (c) 2002-2007 Franz Inc, Oakland, CA - All rights reserved.
@@ -17,7 +17,7 @@
  * Commercial Software developed at private expense as specified in 
  * DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
  *
- * $Header: /repo/cvs.copy/clim2/misc/MyDrawingA.c,v 2.6 2007/04/17 21:45:51 layer Exp $
+ * $Header: /repo/cvs.copy/clim2/misc/MyDrawingA.c,v 2.7 2007/12/11 17:20:20 layer Exp $
  */
 
 #if defined(__alpha)
@@ -151,7 +151,10 @@ XmCreateMyDrawingArea(
 {
 /****************/
 
-    return( XtCreateWidget( name, xmMyDrawingAreaWidgetClass, p, args, n)) ;
+    Widget r = XtCreateWidget( name, xmMyDrawingAreaWidgetClass, p, args, n);
+    XmImRegister (r, 0);
+/*    XmImGetXIC (r, XmINHERIT_POLICY, NULL, 0); */
+    return r;
 }
 
 #if defined(__alpha)
diff --git a/postscript/postscript-medium.lisp b/postscript/postscript-medium.lisp
index 637c3eeebc6d76042a0a992dcee916f380ed1c34..308330455107a6b0e0c6be1d6bfaae4e13a34312 100644
--- a/postscript/postscript-medium.lisp
+++ b/postscript/postscript-medium.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $Id: postscript-medium.lisp,v 2.4 2003/12/15 18:35:14 layer Exp $
+;; $Id: postscript-medium.lisp,v 2.5 2007/12/11 17:20:20 layer Exp $
 
 (in-package :postscript-clim)
 
@@ -505,6 +505,7 @@
   (error "Obsolete"))
 
 (excl::without-package-locks
+;;; XXX: what the dis? Is this intentionally obfuscated?
 (defmacro with-postscript-glyph-for-character (&body body)
   `(macrolet ((port-glyph-for-character (port character style &optional our-font)
 		 `(multiple-value-bind (character-set index)
diff --git a/silica/classes.lisp b/silica/classes.lisp
index 002e441c5acda6b7fa3922bd366bb9a876305be3..ba9cca6b35cdf0b85a797502af9e67b93313897d 100644
--- a/silica/classes.lisp
+++ b/silica/classes.lisp
@@ -17,7 +17,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: classes.lisp,v 2.9 2007/04/17 21:45:52 layer Exp $
+;; $Id: classes.lisp,v 2.10 2007/12/11 17:20:20 layer Exp $
 
 (in-package :silica)
 
@@ -84,9 +84,9 @@
 #-(or aclpc acl86win32) 
 (defun mapping-table-initform ()
   (excl:ics-target-case
-   (:+ics (let ((v (make-array 4)))
+   (:+ics (let ((v (make-array 4 :adjustable t)))
 	    (dotimes (i 4)
-	      (setf (svref v i)
+	      (setf (aref v i)
 		(make-hash-table :test #'equal)))
 	    v))
    (:-ics (make-hash-table :test #'equal))))
@@ -94,9 +94,9 @@
 #-(or aclpc acl86win32) 
 (defun mapping-cache-initform ()
   (excl:ics-target-case
-   (:+ics (let ((v (make-array 4)))
+   (:+ics (let ((v (make-array 4 :adjustable t)))
 	    (dotimes (i 4)
-	      (setf (svref v i)
+	      (setf (aref v i)
 		(cons nil nil)))
 	    v))
    (:-ics (cons nil nil))))
diff --git a/silica/text-style.lisp b/silica/text-style.lisp
index 8228caf7b98bbef84ca3ab7b6f7bc047b7429561..1ca43cdd9842e71fe197e369c366242ce45732c2 100644
--- a/silica/text-style.lisp
+++ b/silica/text-style.lisp
@@ -17,7 +17,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: text-style.lisp,v 2.10 2007/04/17 21:45:52 layer Exp $
+;; $Id: text-style.lisp,v 2.11 2007/12/11 17:20:20 layer Exp $
 
 (in-package :silica)
 
@@ -151,27 +151,27 @@
 ;;; if we want.
 (defun make-text-style (family face size &aux changed-p original-face)
   (unless (numberp face)
-	(setf original-face face
-		  face (face->face-code face)))                ;"Intern" the face code.
+    (setf original-face face
+          face (face->face-code face))) ;"Intern" the face code.
   (loop
-	(let* ((family-stuff (assoc family *text-style-intern-table*))
-		   (face-stuff (and family-stuff (assoc face (cdr family-stuff))))
-		   (size-stuff (and face-stuff (assoc size (cdr face-stuff)))))
-	  (when size-stuff (return-from make-text-style (cdr size-stuff)))
-	  (multiple-value-setq (family face size changed-p original-face)
-						   (validate-text-style-components family face size original-face))
-	  (unless changed-p
-		(macrolet ((ensure-stuff (stuff thing from-stuff)
-								 `(unless ,stuff
-									(setf ,stuff (cons ,thing nil))
-									(with-lock-held (*text-style-lock* "Text style lock")
-									  (setf ,from-stuff (nconc ,from-stuff (cons ,stuff nil)))))))
-		  (ensure-stuff family-stuff family *text-style-intern-table*)
-		  (ensure-stuff face-stuff face family-stuff)
-		  (ensure-stuff size-stuff size face-stuff))
-		(let* ((new-style (make-text-style-1 family face size nil)))
-		  (setf (cdr size-stuff) new-style)
-		  (return-from make-text-style new-style))))))
+    (let* ((family-stuff (assoc family *text-style-intern-table*))
+           (face-stuff (and family-stuff (assoc face (cdr family-stuff))))
+           (size-stuff (and face-stuff (assoc size (cdr face-stuff)))))
+      (when size-stuff (return-from make-text-style (cdr size-stuff)))
+      (multiple-value-setq (family face size changed-p original-face)
+          (validate-text-style-components family face size original-face))
+      (unless changed-p
+        (macrolet ((ensure-stuff (stuff thing from-stuff)
+                     `(unless ,stuff
+                        (setf ,stuff (cons ,thing nil))
+                        (with-lock-held (*text-style-lock* "Text style lock")
+                          (setf ,from-stuff (nconc ,from-stuff (cons ,stuff nil)))))))
+          (ensure-stuff family-stuff family *text-style-intern-table*)
+          (ensure-stuff face-stuff face family-stuff)
+          (ensure-stuff size-stuff size face-stuff))
+        (let* ((new-style (make-text-style-1 family face size nil)))
+          (setf (cdr size-stuff) new-style)
+          (return-from make-text-style new-style))))))
 
 (defmethod text-style-index ((text-style standard-text-style))
   (let ((index (slot-value text-style 'index)))
@@ -628,56 +628,66 @@
 
 (defmethod port-mapping-table ((port basic-port) character-set)
   (with-slots (mapping-table) port
-    #+allegro
-    (excl:ics-target-case
-     (:-ics character-set mapping-table)
-     (:+ics (svref mapping-table character-set)))
-    #-allegro
-    mapping-table))
+     #+allegro
+     (excl:ics-target-case
+       (:-ics character-set mapping-table)
+       (:+ics (let ((old-length (length mapping-table)))
+                (when (>= character-set (length mapping-table))
+                  (setf mapping-table (adjust-array mapping-table (1+ character-set)))
+                  (dotimes (i (- (length mapping-table) old-length))
+                    (setf (aref mapping-table (+ i old-length)) (make-hash-table :test #'equal))))
+                (aref mapping-table character-set))))
+     #-allegro
+     mapping-table))
 
 (defmethod port-mapping-cache ((port basic-port) character-set)
   (with-slots (mapping-cache) port
-    #+allegro
-    (excl:ics-target-case
-     (:-ics character-set mapping-cache)
-     (:+ics (svref mapping-cache character-set)))
-    #-allegro
-    mapping-cache))
+     #+allegro
+     (excl:ics-target-case
+       (:-ics character-set mapping-cache)
+       (:+ics (let ((old-length (length mapping-cache)))
+                (when (>= character-set (length mapping-cache))
+                  (setf mapping-cache (adjust-array mapping-cache (1+ character-set)))
+                  (dotimes (i (- (length mapping-cache) old-length))
+                    (setf (aref mapping-cache (+ i old-length)) (cons nil nil))))
+                (aref mapping-cache character-set))))
+     #-allegro
+     mapping-cache))
 
 (defmethod (setf text-style-mapping) (mapping (port basic-port) style
-                                      &optional (character-set *standard-character-set*)
-                                                window)
+                                              &optional (character-set *standard-character-set*)
+                                              window)
   (declare (ignore window))
   (setq style (standardize-text-style port (parse-text-style style) character-set))
   (when (listp mapping)
     (assert (eq (first mapping) :style) ()
-      "Text style mappings must be atomic font names ~
+            "Text style mappings must be atomic font names ~
              or (:STYLE . (family face size))")
     (setf mapping (parse-text-style (cdr mapping))))
   (with-slots (allow-loose-text-style-size-mapping) port
-    (let ((mapping-table (port-mapping-table port character-set))
-          (mapping-cache (port-mapping-cache port character-set)))
-      (without-scheduling
-        (setf (car mapping-cache) nil
-              (cdr mapping-cache) nil))
-      (if allow-loose-text-style-size-mapping
-          (multiple-value-bind (family face size) (text-style-components style)
-            (declare (ignore size))
-            ;; NB: loose size mapping requires an EQUAL hash table!
-            (with-stack-list (key family face)
-              (let* ((fonts (gethash key mapping-table))
-                     (old (assoc style fonts)))
-                (cond (old
-                       (setf (second old) mapping))
-                      (t
-                       (push (list style mapping) fonts)
-                       (setq fonts (sort fonts #'(lambda (e1 e2)
-                                                   (< (text-style-size (first e1))
-                                                      (text-style-size (first e2))))))
-                       (setf (gethash (copy-list key) mapping-table)
-                         fonts)))
-                mapping)))
-        (setf (gethash style mapping-table) mapping)))))
+     (let ((mapping-table (port-mapping-table port character-set))
+           (mapping-cache (port-mapping-cache port character-set)))
+       (without-scheduling
+         (setf (car mapping-cache) nil
+               (cdr mapping-cache) nil))
+       (if allow-loose-text-style-size-mapping ; ### <----!!!
+           (multiple-value-bind (family face size) (text-style-components style)
+             (declare (ignore size))
+             ;; NB: loose size mapping requires an EQUAL hash table!
+             (with-stack-list (key family face)
+               (let* ((fonts (gethash key mapping-table))
+                      (old (assoc style fonts)))
+                 (cond (old
+                        (setf (second old) mapping))
+                       (t
+                        (push (list style mapping) fonts)
+                        (setq fonts (sort fonts #'(lambda (e1 e2)
+                                                    (< (text-style-size (first e1))
+                                                       (text-style-size (first e2))))))
+                        (setf (gethash (copy-list key) mapping-table)
+                              fonts)))
+                 mapping)))
+           (setf (gethash style mapping-table) mapping)))))
 
 (defmethod (setf text-style-mapping) (mapping (port basic-port) (style device-font)
 				      &optional (character-set *standard-character-set*)
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index 57107ae7916f2a0d11df273fad2c64a52fcf9a66..d2f49411484ae254f7b04ec8eba7d39741170837 100644
--- a/tk-silica/xm-frames.lisp
+++ b/tk-silica/xm-frames.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xm-frames.lisp,v 2.7 2007/04/17 21:45:54 layer Exp $
+;; $Id: xm-frames.lisp,v 2.8 2007/12/11 17:20:21 layer Exp $
 
 (in-package :xm-silica)
 
@@ -366,7 +366,6 @@
 ;;;    mirror))
 
 (defmethod realize-mirror :around ((port motif-port) (sheet motif-menu-bar))
-
   ;; This code fills the menu-bar. If top level items do not have
   ;; submenus then it creates one with a menu of its own
 
@@ -409,7 +408,7 @@
 	    port
 	    (if item-text-style
 		(merge-text-styles item-text-style menu-text-style)
-	      menu-text-style)
+                menu-text-style)
 	    *all-character-sets*)
 	   initargs)))
 
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index b6910ae2ddcc9c78f026dc5df0e7e6070f4b35d7..53865c7d58157e5385b08209f38769677226c287 100644
--- a/tk-silica/xm-gadgets.lisp
+++ b/tk-silica/xm-gadgets.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xm-gadgets.lisp,v 2.11 2007/04/17 21:45:54 layer Exp $
+;; $Id: xm-gadgets.lisp,v 2.12 2007/12/11 17:20:21 layer Exp $
 
 (in-package :xm-silica)
 
@@ -120,17 +120,17 @@
 	   (when (typep label 'pattern)
 	     (with-sheet-medium (medium sheet)
 	       (setq label
-		 (pixmap-from-pattern label medium :pixmap))))
+                     (pixmap-from-pattern label medium :pixmap))))
 	   (setf (getf initargs :label-pixmap) label)
 	   ;;-- Perhaps we need to stipple this?
 	   (setf (getf initargs :label-insensitive-pixmap) label)
 	   (setf (getf initargs :label-type) :pixmap))))
       (unless (getf initargs :alignment)
 	(setf (getf initargs :alignment)
-	  (ecase alignment
-	    ((:left nil) :beginning)
-	    (:center :center)
-	    (:right :end))))
+              (ecase alignment
+                ((:left nil) :beginning)
+                (:center :center)
+                (:right :end))))
       (setf (getf initargs :recompute-size) nil))
     initargs))
 
@@ -146,7 +146,7 @@
                                  ((:left nil) :beginning)
                                  (:center :center)
                                  (:right :end))
-		    :label-string (or (gadget-label sheet) ""))))
+                    :label-string (or (gadget-label sheet) ""))))
 
 ;;; Motif widgets that support the activate callback
 
@@ -1178,6 +1178,7 @@
 		      :resize-policy :none
 		      :scroll-bar-display-policy :static))
 
+
 ;;;
 
 (defclass motif-radio-box (motif-row-column-gadget-mixin
diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp
index 275c62863d59145f8ccf90cb31b0822e7d199881..ec8fb3ec0a3ef2ebe0caf7467d6d1befdf4e1ca0 100644
--- a/tk-silica/xm-silica.lisp
+++ b/tk-silica/xm-silica.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xm-silica.lisp,v 2.7 2007/04/17 21:45:54 layer Exp $
+;; $Id: xm-silica.lisp,v 2.8 2007/12/11 17:20:21 layer Exp $
 
 (in-package :xm-silica)
 
@@ -72,11 +72,12 @@
 		   (and (typep (pane-frame sheet)
 			       'clim-internals::menu-frame)
 			'(:override-redirect t))))
-	(call-next-method))
+          (call-next-method))
     (values class `(:keyboard-focus-policy
 		    ,(ecase (port-input-focus-selection port)
 		       (:click-to-select :explicit)
 		       (:sheet-under-pointer :pointer))
+                    :preedit-type "None"
 		    ,@initargs))))
 
 (defmethod enable-xt-widget ((parent tk::xm-dialog-shell) (mirror t))
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index c9026cdf1b1d8c6bd0b7d96e921444772ad33993..3ff7c5917c33edd1990ad3c73ce8c648a8c2dd29 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xt-graphics.lisp,v 2.7 2007/04/17 21:45:54 layer Exp $
+;; $Id: xt-graphics.lisp,v 2.8 2007/12/11 17:20:21 layer Exp $
 
 (in-package :tk-silica)
 
@@ -1500,12 +1500,12 @@
 			      string-or-char x y start end
 			      align-x align-y
 			      towards-x towards-y transform-glyphs)
+  (declare (ignorable transform-glyphs))
   (let* ((port (port medium))
 	 (sheet (medium-sheet medium))
 	 (transform (sheet-device-transformation sheet))
 	 (text-style (medium-merged-text-style medium))
 	 (string (string string-or-char)))
-
     ;;--rounding errors?
     (transform-positions transform x y)
     (when (and towards-x towards-y)
@@ -1541,73 +1541,56 @@
 	(:baseline nil)
 	(:top
 	 (when towards-y (incf towards-y baseline))
-	 (incf y baseline))))
-
-    (let ((y-factor 0)
-	  (x-factor 1))
-      (when (and towards-x towards-y)
-	(let ((xxx (- towards-x x))
-	      (yyy (- towards-y y)))
-	  (cond ((zerop yyy)
-		 (setq y-factor 0)
-		 (setq x-factor (if (minusp xxx) -1 1)))
-		((zerop xxx)
-		 (setq x-factor 0)
-		 (setq y-factor (if (minusp yyy) -1 1)))
-		(t
-		 ;; this branch is rather expensive.
-		 ;; avoid these calls if the calculation is trivial. jpm.
-		 (let ((alpha (atan yyy xxx)))
-		   (setq y-factor (sin alpha))
-		   (setq x-factor (cos alpha)))))))
-
-      (flet ((process-element (codeset start end)
-	       (let ((drawable (medium-drawable medium))
-		     (font (text-style-mapping port text-style codeset))
-		     (width (text-size sheet string :text-style text-style
-				       :start start :end end)))
-		 (when drawable
-		   (fix-coordinates x y)
-		   (discard-illegal-coordinates medium-draw-text* x y)
-		   (let ((gc (adjust-ink
-			      (decode-ink (medium-ink medium) medium)
-			      medium
-			      x
-			      (- y (tk::font-ascent font)))))
-		     (setf (tk::gcontext-font gc) font)
-		     (if (and towards-x towards-y)
-			 (if (tk::font-range font)
-			     (port-draw-rotated-text port drawable gc x y string start end
-						     font towards-x towards-y transform-glyphs)
-			   (let ((*error-output* excl:*initial-terminal-io*))
-			     (warn "Cannot rotate 16-bit font ~A" font)))
-		       (funcall
-			(excl:ics-target-case
-			 (:+ics 
-			  ;; bug12286/spr26334
-			  ;; The old function, tk::draw-string16,
-			  ;; does not properly handle "higher-numbered"
-			  ;; ascii characters.
-			  ;; The following is in analogy to
-			  ;; the similar operation in
-			  ;; convert-resource-out 'xm-string
-			  (ecase codeset
-			    ((0 2) 'tk::draw-string)
-			    ((1 3) 'tk::draw-string16))
-			  )
-			 (:-ics 'tk::draw-string))
-			drawable gc
-			x y
-			string start end))))
-		 (let ((dx (* width x-factor))
-		       (dy (* width y-factor)))
-		   (incf x dx)
-		   (incf y dy)
-		   (when towards-x (incf towards-x dx))
-		   (when towards-y (incf towards-y dy))))))
-	(declare (dynamic-extent #'process-element))
-	(tk::partition-compound-string string #'process-element
-				       :start start :end end)))))
+	 (incf y baseline)))
+
+      (let ((y-factor 0)
+            (x-factor 1))
+        (when (and towards-x towards-y)
+          (let ((xxx (- towards-x x))
+                (yyy (- towards-y y)))
+            (cond ((zerop yyy)
+                   (setq y-factor 0)
+                   (setq x-factor (if (minusp xxx) -1 1)))
+                  ((zerop xxx)
+                   (setq x-factor 0)
+                   (setq y-factor (if (minusp yyy) -1 1)))
+                  (t
+                   ;; this branch is rather expensive.
+                   ;; avoid these calls if the calculation is trivial. jpm.
+                   (let ((alpha (atan yyy xxx)))
+                     (setq y-factor (sin alpha))
+                     (setq x-factor (cos alpha)))))))
+        (let ((drawable (medium-drawable medium))
+              (font (text-style-mapping port text-style *all-character-sets*)))
+          (when drawable
+            (fix-coordinates x y)
+            (discard-illegal-coordinates medium-draw-text* x y)
+            (let ((gc (adjust-ink
+                       (decode-ink (medium-ink medium) medium)
+                       medium
+                       x
+                       (- y height))))
+              (if (and towards-x towards-y)
+                  (excl:ics-target-case
+                    (:+ics
+                     (let ((*error-output* excl:*initial-terminal-io*))
+                       (warn "Cannot rotate 16-bit font ~A" font)))
+                    (:-ics
+                     (port-draw-rotated-text port drawable gc x y string start end
+                                             font towards-x towards-y transform-glyphs)))
+                  (excl:ics-target-case
+                    (:+ics
+                     (tk::draw-multibyte-string drawable
+                                                (font-set-from-font-list port font)
+                                                gc x y string start end))
+                    (:-ics
+                     (tk::draw-string drawable gc x y string start end))))))
+          (let ((dx (* width x-factor))
+                (dy (* width y-factor)))
+            (incf x dx)
+            (incf y dy)
+            (when towards-x (incf towards-x dx))
+            (when towards-y (incf towards-y dy))))))))
 
 (defmethod medium-text-bounding-box ((medium xt-medium)
 				     string x y start end align-x
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index dcd494fdb437643fc3922ef6962967b2d225422f..e8c957ec5994912fa6f96a9793e773c88b7fdef4 100644
--- a/tk-silica/xt-silica.lisp
+++ b/tk-silica/xt-silica.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xt-silica.lisp,v 2.11 2007/07/18 18:00:13 layer Exp $
+;; $Id: xt-silica.lisp,v 2.12 2007/12/11 17:20:21 layer Exp $
 
 (in-package :xm-silica)
 
@@ -159,6 +159,43 @@
 	       '(:static-color :true-color :pseudo-color :direct-color))
        t))
 
+;;; SPR30362:
+
+(defvar *default-fallback-font* "fixed")
+
+(defun list-fonts-by-registry (display)
+  (let* ((fonts (tk::list-font-names display "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"))
+         (encoding-hash (make-hash-table :test #'equal)))
+    (dolist (font fonts)
+      (let ((font* (disassemble-x-font-name font)))
+        (push font (gethash (last font* 2) encoding-hash))))
+    encoding-hash))
+
+(defun find-font-with-properties (fonts weight slant)
+  (or (find (list weight slant) fonts
+            :test #'equal
+            :key (lambda (font)
+                   (let ((font* (disassemble-x-font-name font)))
+                     (list (nth 3 font*) (nth 4 font*)))))
+      (first fonts)))
+
+(defun font-name-of-aliased-font (display fontname)
+  (excl:with-native-string (nfn fontname)
+    (let ((font (x11:xloadqueryfont display nfn)))      
+      (unless (zerop font)
+        (unwind-protect
+            (loop for i from 0 below (x11:xfontstruct-n-properties font)
+                  for fontprop = (+ ;; this is horrible:
+                                  (* i 2 #-64bit 4 #+64bit 8)
+                                  (x11:xfontstruct-properties font))
+                  when (eql x11:xa-font (x11:xfontprop-name fontprop))
+                    do (return (values (excl:native-to-string 
+                                        (x11:xgetatomname display
+                                                          (x11:xfontprop-card32 fontprop))))))
+          (x11:xfreefont display font))))))
+
+;;; END SPR30362
+
 (defparameter *xt-font-families*
     `(
       ;; ascii
@@ -214,29 +251,77 @@
 	 (screen-pixels-per-inch
 	  (* 25.4 (/ (x11::xdisplayheight display screen)
 		     (x11:xdisplayheightmm display screen)))))
-    (flet ((font->text-style (font family)
-	     (flet ((parse-token (token)
-		      (if token
-			  (parse-integer token)
-			(return-from font->text-style nil))))
-	       (let* ((tokens (disassemble-x-font-name font))
-		      (italic (member (nth 4 tokens) '("i" "o") :test #'equalp))
-		      (bold (equalp (nth 3 tokens) "bold"))
-		      (face (if italic
-				(if bold '(:bold :italic) :italic)
-			      (if bold :bold :roman)))
-		      (pixel-size (parse-token (nth 7 tokens)))
-		      (point-size (parse-token (nth 8 tokens)))
-		      (y-resolution (parse-token (nth 10 tokens)))
-		      (average-width (parse-token (nth 12 tokens)))
-		      (corrected-point-size (* (float point-size)
-					       (/ y-resolution
-						  screen-pixels-per-inch))))
-		 (unless (and (not *use-scalable-fonts*)
-			      (or (eql pixel-size 0)
-				  (eql point-size 0)
-				  (eql average-width 0)))
-		   (make-text-style family face (/ corrected-point-size 10)))))))
+    (labels ((font->text-style (font family)
+               (flet ((parse-token (token)
+                        (if token
+                            (parse-integer token)
+                            (return-from font->text-style nil))))
+                 (let* ((tokens (disassemble-x-font-name font))
+                        (italic (member (nth 4 tokens) '("i" "o") :test #'equalp))
+                        (bold (equalp (nth 3 tokens) "bold"))
+                        (face (if italic
+                                  (if bold '(:bold :italic) :italic)
+                                  (if bold :bold :roman)))
+                        (pixel-size (parse-token (nth 7 tokens)))
+                        (point-size (parse-token (nth 8 tokens)))
+                        (y-resolution (parse-token (nth 10 tokens)))
+                        (average-width (parse-token (nth 12 tokens)))
+                        (corrected-point-size (* (float point-size)
+                                                 (/ y-resolution
+                                                    screen-pixels-per-inch))))
+                   (unless (and (not *use-scalable-fonts*)
+                                (or (eql pixel-size 0)
+                                    (eql point-size 0)
+                                    (eql average-width 0)))
+                     (make-text-style family face (/ corrected-point-size 10))))))
+             (load-1-charset (character-set fallback families)
+               (let* ((matchesp nil) ;do any non-fallback fonts match?
+                      (fallback-matches-p ;any fallback matches?
+                       (not (null (tk::list-font-names display fallback))))
+                      (fallback-loadable-p ;fallback actually loadable?
+                       (and fallback-matches-p
+                            (excl:with-native-string (nfn fallback)
+                              (let ((x (x11:xloadqueryfont display nfn)))
+                                (if (not (zerop x))
+                                    (progn
+                                      (x11:xfreefont display x)
+                                      t)
+                                    nil))))))
+                 (dolist (per-family families)
+                   (destructuring-bind (family &rest patterns) per-family
+                     (dolist (font-pattern patterns)
+                       (dolist (xfont (tk::list-font-names display font-pattern))
+                         ;; this hack overcomes a bug with hp's scalable fonts
+                         (unless (find #\* xfont)
+                           (setf matchesp t) ;there was at least one match
+                           (let ((text-style (font->text-style xfont family)))
+                             ;; prefer first font satisfying this text style, so
+                             ;; don't override if we've already defined one.
+                             (when text-style
+                               (unless (text-style-mapping-exists-p
+                                        port text-style character-set t)
+                                 (setf (text-style-mapping port text-style
+                                                           character-set)
+                                       xfont)))))))))
+                 ;; Set up the fallback if it looks like there is one, and
+                 ;; complain if things look bad.  Things look bad if there were
+                 ;; matches but the fallback is not loadable.  If there were
+                 ;; no matches then don't complain even if there appears to be
+                 ;; something wrong with the fallback, just silently don't load it
+                 ;; (and thus define no mappings for the character set).
+                 (cond
+                   (fallback-loadable-p	;all is well
+                    (setf (text-style-mapping port *undefined-text-style*
+                                              character-set)
+                          fallback))
+                   ((and matchesp fallback-matches-p)
+                    (warn "Fallback font ~A, for character set ~A, matches with XListFonts,
+but is not loadable by XLoadQueryFont.  Something may be wrong with the X font
+setup."
+                          fallback character-set))
+                   (matchesp
+                    (warn "Fallback font ~A not loadable for character set ~A."
+                          fallback character-set))))))
       ;; Setup font mappings.  This is made hairy by trying to deal
       ;; elegantly with possibly missing mappings and messed-up X font
       ;; setups.  It seems to be the case that XListFonts can return
@@ -249,55 +334,39 @@
       ;; with it, but otherwise don't check.  This should mean that if
       ;; this doesn't warn then things will basically run, as the
       ;; fallback exists for each character set, at least.
-      (dolist (per-charset *xt-font-families*)
-	(destructuring-bind (character-set fallback &rest families) per-charset
-	  (let* ((matchesp nil)		;do any non-fallback fonts match?
-		 (fallback-matches-p	;any fallback matches?
-		  (not (null (tk::list-font-names display fallback))))
-		 (fallback-loadable-p	;fallback actually loadable?
-		  (and fallback-matches-p
-		       (excl:with-native-string (nfn fallback)
-			 (let ((x (x11:xloadqueryfont display nfn)))
-			   (if (not (zerop x))
-			       (progn
-				 (x11:xfreefont display x)
-				 t)
-			       nil))))))
-	    (dolist (per-family families)
-	      (destructuring-bind (family &rest patterns) per-family
-		(dolist (font-pattern patterns)
-		  (dolist (xfont (tk::list-font-names display font-pattern))
-		    ;; this hack overcomes a bug with hp's scalable fonts
-		    (unless (find #\* xfont)
-		      (setf matchesp t) ;there was at least one match
-		      (let ((text-style (font->text-style xfont family)))
-			;; prefer first font satisfying this text style, so
-			;; don't override if we've already defined one.
-			(when text-style
-			  (unless (text-style-mapping-exists-p
-				   port text-style character-set t)
-			    (setf (text-style-mapping port text-style
-						      character-set)
-			      xfont)))))))))
-	    ;; Set up the fallback if it looks like there is one, and
-	    ;; complain if things look bad.  Things look bad if there were
-	    ;; matches but the fallback is not loadable.  If there were
-	    ;; no matches then don't complain even if there appears to be
-	    ;; something wrong with the fallback, just silently don't load it
-	    ;; (and thus define no mappings for the character set).
-	    (cond
-	     (fallback-loadable-p	;all is well
-	      (setf (text-style-mapping port *undefined-text-style*
-					character-set)
-		fallback))
-	     ((and matchesp fallback-matches-p)
-	      (warn "Fallback font ~A, for character set ~A, matches with XListFonts,
-but is not loadable by XLoadQueryFont.  Something may be wrong with the X font
-setup."
-		    fallback character-set))
-	     (matchesp
-	      (warn "Fallback font ~A not loadable for character set ~A."
-		    fallback character-set))))))))
+      (let ((charset-number 0)
+            (done-registries ()))
+        (dolist (per-charset *xt-font-families*)
+          (destructuring-bind (character-set fallback &rest families) per-charset
+            (load-1-charset character-set fallback families)
+            (setf charset-number (max charset-number character-set))
+            (dolist (family families)
+              (pushnew (last (disassemble-x-font-name (second family)) 2) done-registries
+                       :test #'equal))))
+        (format *debug-io* "done registries: ~A, last charset: ~A~%" done-registries charset-number)
+        ;; Now setup font mappings of fonts that the user has
+        ;; installed, but we don't know anything about (especially no
+        ;; convenient font aliases).
+        ;; Since we don't have any font alias names to rely on, we use
+        ;; the "fixed" alias to find out at least a sensible default
+        ;; weight and slant.
+        (let* ((default-fallback (disassemble-x-font-name (font-name-of-aliased-font display *default-fallback-font*)))
+               (weight (nth 3 default-fallback))
+               (slant (nth 4 default-fallback)))
+          (loop for character-set from (1+ charset-number) 
+                for encoding being the hash-keys of (list-fonts-by-registry display) using (hash-value fonts)
+                for fallback-font = (find-font-with-properties fonts weight slant)
+                for default-font-match-string = (format nil "-*-*-*-*-*-*-*-*-*-*-*-*-~A-~A" (first encoding) (second encoding))
+                do (format *debug-io* "~&registering installed font ~A for enc:~A~%" character-set encoding)
+                do (unless (member encoding done-registries :test #'equal)
+                     (vector-push-extend (excl:string-to-native
+                                          (format nil "~A-~A" (first encoding) (second encoding)))
+                                         tk::*font-list-tags*)
+                     (load-1-charset character-set fallback-font
+                                     `((:fix ,default-font-match-string)
+                                       (:sans-serif ,default-font-match-string)
+                                       (:serif ,default-font-match-string))))))
+        )))
   (setup-stipples port display))
 
 (defparameter *xt-logical-size-alist*
@@ -405,6 +474,7 @@ setup."
 	   nil)
 	  (:expose
 	   ;; This gets called only for an XmBulletinBoard widget.
+           ;; -- erm, no, that's a lie.
 	   (sheet-mirror-exposed-callback widget nil event sheet)
 	   nil)
 	  (:key-press
@@ -428,8 +498,10 @@ setup."
 			       (logior
 				(state->modifiers (x11::xkeyevent-state event))
 				keysym-shift-mask)))))
-	  (:key-release
+	  #+nil ; INTERNATIONAL: we must ignore key release events
+          (:key-release
 	   (multiple-value-bind (character keysym)
+               ;; TODO/international: don't call XmbLookupString for keyrelease events!
 	       (lookup-character-and-keysym sheet widget event)
 	     (let ((keysym-shift-mask
 		    (if (typep keysym 'modifier-keysym)
@@ -440,7 +512,7 @@ setup."
 			   ((:left-meta :right-meta) :meta)
 			   ((:left-super :right-super) :super)
 			   ((:left-hyper :right-hyper) :hyper)))
-		      0)))
+                        0)))
 	       (allocate-event 'key-release-event
 			       :sheet sheet
 			       :key-name keysym
@@ -620,7 +692,7 @@ setup."
   (let ((port (port sheet))
 	(event-key (tk::event-type event)))
     (ecase event-key
-      ((:key-press :key-release)
+      (:key-press
        (distribute-event
 	port
 	(multiple-value-bind (character keysym)
@@ -634,13 +706,10 @@ setup."
 			 ((:left-meta :right-meta) :meta)
 			 ((:left-super :right-super) :super)
 			 ((:left-hyper :right-hyper) :hyper)))
-		    0))
+                      0))
 		 (modifier-state
-		  (if (eq event-key :key-press)
-		      (logior (state->modifiers (x11::xkeyevent-state event))
-			      keysym-shift-mask)
-		    (logandc2 (state->modifiers (x11::xkeyevent-state event))
-			      keysym-shift-mask)))
+		  (logior (state->modifiers (x11::xkeyevent-state event))
+                          keysym-shift-mask))
 		 ;;-- Canonicalize the only interesting key right here.
 		 ;;--  If we get a key labelled "Return", we canonicalize it
 		 ;;-- into #\Newline.
@@ -653,13 +722,13 @@ setup."
 					  (make-modifier-state :shift))))
 			      #\Newline)
 			     (t character))))
-	    (allocate-event (if (eq event-key :key-press)
-				'key-press-event
-			      'key-release-event)
-			    :sheet sheet
-			    :key-name keysym
-			    :character char
-			    :modifier-state modifier-state)))))
+	    (allocate-event 'key-press-event
+                            :sheet sheet
+                            :key-name keysym
+                            :character char
+                            :modifier-state modifier-state)))))
+      (:key-release nil ; INTERNATIONAL: don't do anything for key releases
+                  )
       (:button-press
        (let ((button (x-button->silica-button
 		      (x11::xbuttonevent-button event)))
@@ -984,6 +1053,7 @@ setup."
   (with-slots (context) port
     (tk::process-one-event context mask reason)))
 
+#+gah-this-is-broken
 (defmethod port-glyph-for-character ((port xt-port)
 				     character text-style
 				     &optional our-font)
@@ -1020,6 +1090,38 @@ setup."
       (values index x-font escapement-x escapement-y
 	      origin-x origin-y bb-x bb-y))))
 
+(defun xrect-to-list (xr)
+  (list :x
+        (x11:xrectangle-x xr)
+        :y
+        (x11:xrectangle-y xr)
+        :width
+        ;; bounding box extents:
+        (x11:xrectangle-width xr)
+        :height
+        (x11:xrectangle-height xr)))
+
+(defmethod port-glyph-for-character ((port xt-port) character text-style &optional our-font)
+  (declare (ignore our-font))    ; We need the font set, not the font.
+  (multiple-value-bind (native-string length) (excl:string-to-native (string character))
+    (unwind-protect
+        (tk::with-xrectangle-array (ink-return 1)
+          (tk::with-xrectangle-array (logical-return 1)
+            (let* ((fonts (text-style-mapping port text-style *all-character-sets*))
+                   (font-set (font-set-from-font-list port fonts)))
+              (x11:xmbtextextents font-set native-string
+                                                     (1- length) ink-return
+                                                     logical-return)
+              (values (char-code character) font-set
+                      ;; escapement:
+                      (x11:xrectangle-width logical-return) 0
+                      ;; origin:
+                      0 (abs (x11:xrectangle-y logical-return))
+                      ;; bounding box:
+                      (x11:xrectangle-width logical-return)
+                      (x11:xrectangle-height logical-return)))))
+      (excl:aclfree native-string))))
+
 (defvar *trying-fallback* nil)
 
 (defmethod find-named-font ((port xt-port) name character-set)
@@ -1042,33 +1144,29 @@ setup."
 		   port *undefined-text-style* character-set)))))))))
 
 (excl:ics-target-case
-(:+ics
-
-(defconstant +codesets+ 4)
-
-(defmethod text-style-mapping :around
-	   ((port xt-port) text-style
-	    &optional (character-set *standard-character-set*) window)
-  (declare (ignore window))
-  (if character-set
-      (let ((mapping (call-next-method)))
-	(if (stringp mapping)
-	    (setf (text-style-mapping port text-style character-set)
-	      (find-named-font port mapping character-set))
-	  mapping))
-    (let ((mappings nil))
-      (dotimes (c +codesets+)
-	(let ((mapping (text-style-mapping port text-style c)))
-	  (when mapping
-	    (push (cons c mapping) mappings))))
-      (reverse mappings))))
+  (:+ics
+
+ (defmethod text-style-mapping :around
+   ((port xt-port) text-style
+    &optional (character-set *standard-character-set*) window)
+   (declare (ignore window))
+   (if character-set ; anything but *all-character-sets*
+       (let ((mapping (call-next-method)))
+         (if (stringp mapping)
+             (setf (text-style-mapping port text-style character-set)
+                   (find-named-font port mapping character-set))
+             mapping))
+       (let ((mappings nil))
+         (dotimes (c (length (slot-value port 'silica::mapping-table))) ; XXX: ugly. prettify.
+           (let ((mapping (text-style-mapping port text-style c)))
+             (when mapping
+               (push (cons c mapping) mappings))))
+         (reverse mappings))))
 
 (defmethod font-set-from-font-list ((port xt-port) font-list)
-  (let ((name ""))
-    (dolist (item font-list)
-      (setq name
-	(concatenate 'string
-	  (tk::font-name (cdr item)) "," name)))
+  (let ((name (format nil "~{~A~^,~}"
+                      (mapcar (lambda (font) (tk::font-name (cdr font)))
+                              font-list))))
     (with-slots (font-cache) port
       (setq font-list
 	(or (gethash name font-cache)
@@ -1382,48 +1480,46 @@ setup."
 
 ;;;
 (defun lookup-character-and-keysym (sheet mirror event)
-  (declare (ignore mirror)
-	   (optimize (speed 3) (safety 0)))
-  (let ((port (port sheet)))
-    (multiple-value-bind (character keysym)
-	(tk::lookup-string event
-			   (if port
-			       (port-compose-status port)
-			     0))
-      (setq character (and (= (length (the simple-string character)) 1)
-			   (aref (the simple-string character) 0)))
-      ;; This gets stuff wrong because for example to type-< you have to
-      ;; use the shift key and so instead for m-< you aget m-sh-<
-      ;; Perhaps there is a way of checking to see whether shifting
-      ;; makes sense given the keyboard layout!
-      (when character
-	(let ((x (state->modifiers
-		  (x11::xkeyevent-state event))))
-	  (setq character
-	     (if (and (<= (char-int character) 26)
-		      (not (member character
-				   '(#\return
-				     #\tab
-				     #\page
-				     #\backspace
-				     #\linefeed
-				     #\escape)
-				   :test #'eq)))
-		 (code-char
-		  (+ (char-code character)
-		     (1- (if (logtest x +shift-key+)
-			     (char-int #\A)
-			   (char-int #\a)))))
-	       character))
-	  (setq character
-	    (clim-make-char
-	     character
-	     (logior
-	      (if (logtest x +control-key+) 1 0)
-	      (if (logtest x +meta-key+)    2 0)
-	      (if (logtest x +super-key+)   4 0)
-	      (if (logtest x +hyper-key+)   8 0))))))
-      (values character (xt-keysym->keysym keysym)))))
+  (declare #+nil (optimize (speed 3) (safety 0))
+           (optimize (speed 0) (safety 3) (debug 3))
+           (ignore sheet))
+  (multiple-value-bind (character keysym)
+      (if (eql :key-press (tk::event-type event))
+          (tk::lookup-multibyte-string event mirror))
+    (setq character (and (= (length (the simple-string character)) 1)
+                         (aref (the simple-string character) 0)))
+    ;; This gets stuff wrong because for example to type-< you have to
+    ;; use the shift key and so instead for m-< you aget m-sh-<
+    ;; Perhaps there is a way of checking to see whether shifting
+    ;; makes sense given the keyboard layout!
+    (when character
+      (let ((x (state->modifiers
+                (x11::xkeyevent-state event))))
+        (setq character
+              (if (and (<= (char-int character) 26)
+                       (not (member character
+                                    '(#\return
+                                      #\tab
+                                      #\page
+                                      #\backspace
+                                      #\linefeed
+                                      #\escape)
+                                    :test #'eq)))
+                  (code-char
+                   (+ (char-code character)
+                      (1- (if (logtest x +shift-key+)
+                              (char-int #\A)
+                              (char-int #\a)))))
+                  character))
+        (setq character
+              (clim-make-char
+               character
+               (logior
+                (if (logtest x +control-key+) 1 0)
+                (if (logtest x +meta-key+)    2 0)
+                (if (logtest x +super-key+)   4 0)
+                (if (logtest x +hyper-key+)   8 0))))))
+    (values character (xt-keysym->keysym keysym))))
 
 (defun clim-make-char (character &optional (bits 0))
   ;; Like cltl1:make-char but prevents the need to (require :cltl1)
diff --git a/tk/font.lisp b/tk/font.lisp
index 934a903d345bdf9de9862babf5579bb407ff336c..af40fbb1d6668cc7e77d935b1dec618094e39603 100644
--- a/tk/font.lisp
+++ b/tk/font.lisp
@@ -17,7 +17,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: font.lisp,v 2.9 2007/04/17 21:45:53 layer Exp $
+;; $Id: font.lisp,v 2.10 2007/12/11 17:20:20 layer Exp $
 
 (in-package :tk)
 
@@ -184,6 +184,15 @@
 	      (unless (zerop def-string)
 		(excl:native-to-string def-string))))))
 
+(define-condition charsets-missing-from-fontset (warning)
+  ((charsets :initarg :charsets :accessor charsets-missing-from-fontset-charsets)
+   (created-for :initarg :created-for :accessor charsets-missing-from-fontset-created))
+  (:report (lambda (stream c)
+             (format stream
+                     "Missing charsets:~{ ~A,~} creating fontset for ~A"
+                     (charsets-missing-from-fontset-charsets c)
+                     (charsets-missing-from-fontset-created c)))))
+
 (defmethod initialize-instance :after ((fs font-set) &key
 						     foreign-address display base-names)
   (unless foreign-address
@@ -191,8 +200,9 @@
 	(create-font-set display base-names)
       (when missing
 	(let ((*error-output* excl:*initial-terminal-io*))
-	  (warn "Missing charsets:~{ ~A,~} creating fontset for ~A"
-		missing base-names)))
+	  (warn 'charsets-missing-from-fontset
+                :charsets missing
+                :created-for base-names)))
       (when (zerop x) (error "Cannot create fontset for ~S" base-names))
       (setf (foreign-pointer-address fs) x)
       (register-address fs))))
diff --git a/tk/graphics.lisp b/tk/graphics.lisp
index 55f28520f50aca4773fe3b808ad97df5733177f9..2d86c4578aabe8125069916d9ebdc723b78a0830 100644
--- a/tk/graphics.lisp
+++ b/tk/graphics.lisp
@@ -17,7 +17,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: graphics.lisp,v 2.7 2007/04/17 21:45:53 layer Exp $
+;; $Id: graphics.lisp,v 2.8 2007/12/11 17:20:20 layer Exp $
 
 (in-package :tk)
 
@@ -163,6 +163,20 @@
 		  (+ start (clim-utils:string-to-foreign sequence))
 		  (- end start)))
 
+(defun draw-multibyte-string (drawable font-set gc x y string
+                              &optional start end)
+  (setf start (or start 0)
+        end (or end (length string)))
+  (multiple-value-bind (native-string nbytes)
+      (excl:string-to-native string :start start :end end)
+    (x11:xmbdrawstring
+     (object-display drawable)
+     drawable
+     font-set
+     gc
+     x y
+     native-string (1- nbytes))
+    (excl:aclfree native-string)))
 
 (defun draw-string (drawable gc x y string &optional (start 0) end)
   (unless start (setq start 0))
diff --git a/tk/resources.lisp b/tk/resources.lisp
index 8cd9bac3e9c07be12e93a50c036516f17a8c4060..96817258dd5cac0f8d003356bc1526a9bf139920 100644
--- a/tk/resources.lisp
+++ b/tk/resources.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: resources.lisp,v 2.9 2007/04/17 21:45:53 layer Exp $
+;; $Id: resources.lisp,v 2.10 2007/12/11 17:20:20 layer Exp $
 
 (in-package :tk)
 
@@ -690,10 +690,7 @@
 
 (defmethod convert-resource-in ((parent t) (type (eql 'string)) value)
   (unless (zerop value)
-    (excl:ics-target-case
-     (:+ics (let ((euc (excl:native-to-octets value)))
-	      (excl:euc-to-string euc)))
-     (:-ics (values (excl:native-to-string value))))))
+    (excl:native-to-string value)))
 
 (defmethod convert-resource-in ((parent t) (type (eql 'boolean)) value)
   (not (zerop value)))
@@ -825,3 +822,14 @@
   (make-instance 'font
 		 :display (widget-display parent)
 		 :foreign-address value))
+
+
+;;; Visual info
+
+(defmethod convert-resource-out (parent (type (eql 'visual)) value)
+  (declare (ignore parent))
+  value)
+
+(defmethod convert-resource-out (parent (type (eql 'depth)) value)
+  (declare (ignore parent))
+  value)
diff --git a/tk/widget.lisp b/tk/widget.lisp
index 85c6c6499d03c037028d40a9dfdc2b29dff2ffd3..16d77950163ed5daf21ed0bfef5fad38d0f38ee7 100644
--- a/tk/widget.lisp
+++ b/tk/widget.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: widget.lisp,v 2.9 2007/04/17 21:45:53 layer Exp $
+;; $Id: widget.lisp,v 2.10 2007/12/11 17:20:20 layer Exp $
 
 (in-package :tk)
 
@@ -360,6 +360,39 @@
 	 (:+ics '("clim*xnlLanguage: japanese"))))
   "A list of resource specification strings")
 
+(defparameter *external-formats-to-locale-charset-alist*
+              `((,(excl:find-external-format "UTF-8") . "UTF-8")
+                (,(excl:find-external-format "LATIN1") . "ISO-8859-1")))
+
+(defun try-setting-x-locale (locale)
+  (format *debug-io* "Trying locale ~A~%" locale)
+  (setlocale lc-all locale)
+  (let ((supported (x-supports-locale)))
+    (unless (zerop supported)
+      (x-set-locale-modifiers "")
+      (format *debug-io* "X supports locale!~%")
+      locale)))
+
+(defun set-supported-x-locale ()
+  (labels ((ef-name (ef)
+             (if (excl:composed-external-format-p ef)
+                 (or (ef-name (excl:ef-composer-ef ef))
+                     (ef-name (excl:ef-composee-ef ef)))
+                 (cdr (assoc ef *external-formats-to-locale-charset-alist*)))))
+    (let ((locale (excl:locale-name excl:*locale*))
+          (encoding (ef-name (excl:locale-external-format excl:*locale*))))
+      (or (if encoding
+              (try-setting-x-locale (format nil "~A.~A" locale encoding))
+              (warn "Couldn't determine unix encoding of locale ~A's external format. Falling back to default encoding for locale." excl:*locale*))
+          (try-setting-x-locale (format nil "~A" locale))
+          ;; didn't find any locale.
+          (try-setting-x-locale "C")))))
+
+(ff:defun-foreign-callable xt-current-locale-for-acl ((display (* :void)) (xnl (* :char)) (client-data (* :void)))
+  (declare (:convention :c)
+           (ignore display client-data xnl))
+  (set-supported-x-locale))
+
 ;; note that this is different from xt-initialize which calls
 ;; XtToolkitInitialize. This is closer to XtAppInitialize
 
@@ -372,11 +405,15 @@
 	 (with-*-array (v (1+ n))
 	   (dotimes (i n)
 	     (setf (*-array v i)
-	       (clim-utils:string-to-foreign (nth i *fallback-resources*))))
+                   (clim-utils:string-to-foreign (nth i *fallback-resources*))))
 	   (setf (*-array v n) 0)
 	   v))))
-    #+ignore (excl:ics-target-case
-	      (:+ics (xt_set_language_proc context 0 0)))
+    (excl:ics-target-case
+      (:+ics
+       (xt_set_language_proc 0 (register-foreign-callable
+                                'xt-current-locale-for-acl :reuse t)
+                             0)
+       (set-supported-x-locale)))
     (let* ((display (apply #'make-instance 'display
 			   :context context
 			   args))
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index 1c7d6953ee003e02f683154fdf4514e5e2bd8e51..60a8dbe56811b91ee6dec7f0629e29e48987453e 100644
--- a/tk/xlib.lisp
+++ b/tk/xlib.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xlib.lisp,v 2.10 2007/04/17 21:45:53 layer Exp $
+;; $Id: xlib.lisp,v 2.11 2007/12/11 17:20:20 layer Exp $
 
 (in-package :tk)
 
@@ -331,17 +331,17 @@
 
 (define-window-accessor colormap ())
 
-(defun create-colormap (display &optional (screen (display-screen-number display)))
+(defun create-colormap (display &key (screen (display-screen-number display)))
   (intern-object-xid
-   (x11:xcreatecolormap
-    display
-    (x11:xrootwindow display screen)
-    (x11:xdefaultvisual display screen)
-    x11:allocnone)
+   (x11:xcreatecolormap  display
+                         (x11:xrootwindow display screen)
+                         (x11:xdefaultvisual display screen)
+                         x11:allocnone)
    'colormap
    display
    :display display))
 
+
 (defun default-colormap (display &optional (screen (display-screen-number display)))
   (intern-object-xid
    (x11:xdefaultcolormap display screen)
@@ -678,27 +678,6 @@
 	       (ash 1 x)
 	     (error "cannot encode event-mask ~S" mask))))))
 
-
-(defvar *lookup-string-buffers* nil)
-
-(defun lookup-string (event &optional (compose-status 0))
-  (declare (optimize (speed 3) (safety 0)))
-  (let ((buffer (or (excl:without-interrupts (pop *lookup-string-buffers*))
-		    (excl::malloc 256))))
-    (declare (type (unsigned-byte 8) buffer))
-    ;; we assume the Xid type is the same as a pointer
-    (with-ref-par ((keysym 0 :unsigned-long))
-      (let* ((nchars (x11:xlookupstring event buffer 256 &keysym compose-status))
-	     (result (make-string nchars)))
-	(declare (fixnum nchars)
-		 (simple-string result))
-	(dotimes (i nchars)
-	  (declare (fixnum i))
-	  (setf (schar result i)
-	    (code-char (sys:memref-int buffer 0 i :unsigned-byte))))
-	(excl:without-interrupts (push buffer *lookup-string-buffers*))
-	(values result keysym)))))
-
 ;; image support
 
 (defclass image (display-object)
diff --git a/tk/xm-defs.lisp b/tk/xm-defs.lisp
index e38a68df462ce99e42d1f0b4a0f5bec49bb9951c..fc791e31820b5cd900f327156410b6e025a6bc6c 100644
--- a/tk/xm-defs.lisp
+++ b/tk/xm-defs.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xm-defs.lisp,v 2.10 2007/04/17 21:45:53 layer Exp $
+;; $Id: xm-defs.lisp,v 2.11 2007/12/11 17:20:20 layer Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -82,3 +82,10 @@
 (def-c-type (xm-selected-position-array :no-defuns :no-constructor) 1 :int)
 
 (def-c-type (xm-string-table :no-defuns :no-constructor) 1 * :char)
+
+;;; string constants from Xm.h
+(x11::def-exported-constant XmRColormap		"Colormap")
+(x11::def-exported-constant XmRVisual		"Visual")
+(x11::def-exported-constant XmRInt		"Int")
+
+(x11::def-exported-constant XmMULTIBYTE_TEXT    1)
diff --git a/tk/xm-font-list.lisp b/tk/xm-font-list.lisp
index 3deecf669ce4c11eaff95d9e8b973310f8146814..80004f18782ca08f11a720c148e5bdd64812713e 100644
--- a/tk/xm-font-list.lisp
+++ b/tk/xm-font-list.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xm-font-list.lisp,v 2.9 2007/04/17 21:45:53 layer Exp $
+;; $Id: xm-font-list.lisp,v 2.10 2007/12/11 17:20:20 layer Exp $
 
 (in-package :tk)
 
@@ -60,49 +60,50 @@
 (excl:ics-target-case
  (:+ics
   (defvar *font-list-tags*
-      (vector 
+      (make-array 4 :adjustable t :fill-pointer t
+                  :initial-contents
+                  (list
+                   ;; bug13059/spr27144 - we want these strings to
+                   ;; survive a dumplisp       
+                   (excl:string-to-native "ascii")
+                   (excl:string-to-native "kanji")
+                   (excl:string-to-native "katakana")
+                   (excl:string-to-native "gaiji"))
        
-       ;; bug13059/spr27144 - we want these strings to survive a dumplisp
-       
-       (excl:string-to-native "ascii")
-       (excl:string-to-native "kanji")
-       (excl:string-to-native "katakana")
-       (excl:string-to-native "gaiji")
-       
-       ))))
+                  ))))
 
 
 (defun export-font-list (value)
   (when (atom value)
     (setq value (list value)))
-    (flet ((create-font-list-entry (font)
-	     (note-malloced-object
-	      (excl:ics-target-case
-	       (:+ics
-		(let ((tag ""))
-		  (when (consp font)
-		    (setq tag (svref *font-list-tags* (car font))
-			  font (cdr font)))
-		  (xm_font_list_entry_create tag
-					     (etypecase font
-					       (font xm-font-is-font)
-					       (font-set xm-font-is-fontset))
-					     font)))
-	       (:-ics
-		;; perhaps this should be xm-font-list-default-tag
-	        (xm_font_list_entry_create ""
-					   xm-font-is-font
-					   font))))))
-      (let ((font-list
-	     (xm_font_list_append_entry
-	      0				; old entry
-	      (create-font-list-entry (car value)))))
-	(dolist (font (cdr value))
-	  (setq font-list
-	    (xm_font_list_append_entry font-list
-				       (create-font-list-entry font))))
-	(note-malloced-object font-list
-			      #'free-font-list))))
+  (flet ((create-font-list-entry (font)
+           (note-malloced-object
+            (excl:ics-target-case
+              (:+ics
+               (let ((tag ""))
+                 (when (consp font)
+                   (setq tag (aref *font-list-tags* (car font))
+                         font (cdr font)))
+                 (xm_font_list_entry_create tag
+                                            (etypecase font
+                                              (font xm-font-is-font)
+                                              (font-set xm-font-is-fontset))
+                                            font)))
+              (:-ics
+               ;; perhaps this should be xm-font-list-default-tag
+               (xm_font_list_entry_create ""
+                                          xm-font-is-font
+                                          font))))))
+    (let ((font-list
+           (xm_font_list_append_entry
+            0				; old entry
+            (create-font-list-entry (car value)))))
+      (dolist (font (cdr value))
+        (setq font-list
+              (xm_font_list_append_entry font-list
+                                         (create-font-list-entry font))))
+      (note-malloced-object font-list
+                            #'free-font-list))))
 
 #+:dec3100
 (defmethod convert-resource-out ((parent t) (type (eql 'xm-font-list)) value)
diff --git a/tk/xm-funs.lisp b/tk/xm-funs.lisp
index dc07e7526ce85c231a613b6382cc9c0349ba533f..adede18305ee0924140476a8417d4ac674012deb 100644
--- a/tk/xm-funs.lisp
+++ b/tk/xm-funs.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xm-funs.lisp,v 2.7 2007/04/17 21:45:53 layer Exp $
+;; $Id: xm-funs.lisp,v 2.8 2007/12/11 17:20:20 layer Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -24,6 +24,11 @@
 
 (in-package :tk)
 
+(def-foreign-call (xm_string_create_localized "XmStringCreateLocalized")
+    ((text :foreign-address))
+  :returning :foreign-address
+  :call-direct t)
+
 (def-foreign-call (xm_string_create_l_to_r "XmStringCreateLtoR")
     ((x :foreign-address) (y :foreign-address))
   :returning :foreign-address
@@ -94,6 +99,17 @@
   :call-direct t
   :arg-checking nil)
 
+(def-foreign-call (xm_im_mb_lookup_string "XmImMbLookupString")
+    ((widget :foreign-address)
+     (event :foreign-address)
+     (buffer :foreign-address)
+     (bytes-in-buffer :int fixnum)
+     (keysym :foreign-address)
+     (status-return :foreign-address))
+  :returning :int
+  :call-direct t
+  :arg-checking nil)
+
 (def-foreign-call (xm_add_protocol_callback "XmAddProtocolCallback")
     ((v :foreign-address) w x (y :foreign-address) (z :foreign-address))
   :returning :void
diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp
index a66177e800b3337bbf498a8da769eae8319e237b..c7061ef27278ecc5eeae3c62f93352a653e644f7 100644
--- a/tk/xm-widgets.lisp
+++ b/tk/xm-widgets.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xm-widgets.lisp,v 2.9 2007/04/17 21:45:53 layer Exp $
+;; $Id: xm-widgets.lisp,v 2.10 2007/12/11 17:20:20 layer Exp $
 
 (in-package :tk)
 
@@ -62,6 +62,12 @@
 					  (excl:string-to-native
 					   "keyboardFocusPolicy")))
 
+(tk::add-resource-to-class (find-class 'vendor-shell)
+                           (make-instance 'resource
+                              :name :preedit-type
+                              :type 'string
+                              :original-name (excl:string-to-native
+                                              "preeditType")))
 
 (tk::add-resource-to-class (find-class 'xm-cascade-button-gadget)
 			   (make-instance 'resource
@@ -126,64 +132,68 @@
 
 (excl:ics-target-case
  (:+ics
+  
+  (defvar *empty-compound-string* nil)
+
+  (eval-when (compile) (declaim (special *font-list-tags*)))
+  
   (defun partition-compound-string (s f &key (start 0) (end (length s)))
     (unless (eql (length s) 0)
       (let ((c 0)
-	    (index start))
-	(loop
-	  (setq c (clim-utils:char-character-set-and-index (char s index)))
-	  (let* ((break (position-if-not
-			 #'(lambda (x)
-			     (eq (clim-utils:char-character-set-and-index x) c))
-			 s :start index :end end)))
-	    (funcall f c index (or break end))
-	    (if break
-		(setq index break)
-	      (return-from partition-compound-string))))))))
-
- (:-ics
-  (defun partition-compound-string (s f &key (start 0) (end (length s)))
-    ;;(declare (ignore s))
-    (funcall f nil start end))))
-
-
-(excl:ics-target-case
- (:+ics
-
-  (defvar *empty-compound-string* nil)
+            (index start))
+        (loop
+          (setq c (clim-utils:char-character-set-and-index (char s index)))
+          (let* ((break (position-if-not
+                         #'(lambda (x)
+                             (eq (clim-utils:char-character-set-and-index x) c))
+                         s :start index :end end)))
+            (funcall f c index (or break end))
+            (if break
+                (setq index break)
+                (return-from partition-compound-string)))))))
   
-  (eval-when (compile) (declaim (special *font-list-tags*)))
-
   (defmethod convert-resource-out ((parent t) (type (eql 'xm-string)) value)
     (let ((result nil))
       (flet ((extract-element (codeset start end)
-	       (let* ((substring (subseq value start end))
-		      (element (xm_string_create_l_to_r
-				(ecase codeset
-				  ((0 2) (lisp-string-to-string8 substring))
-				  ((1 3) (lisp-string-to-string16 substring)))
-				(svref *font-list-tags* codeset))))
-		 (tk::add-widget-cleanup-function parent
-						  #'destroy-generated-xm-string
-						  element)
-		 (let ((temp (if result
-				 (xm_string_concat result element)
-			       (xm_string_copy element))))
-		   (tk::add-widget-cleanup-function parent
-						    #'destroy-generated-xm-string
-						    temp)
-		   (setq result temp)))))
-	(declare (dynamic-extent #'extract))
-	(partition-compound-string value #'extract-element)
-	(or result
-	    *empty-compound-string*
-	    (setq *empty-compound-string*
-	      (xm_string_create_l_to_r (clim-utils:string-to-foreign "")
-				       (clim-utils:string-to-foreign 
-					xm-font-list-default-tag))))))
-    ))
+               (let* ((substring (subseq value start end))
+                      (element (xm_string_create_l_to_r
+                                (ecase codeset
+                                  ((0 2) (lisp-string-to-string8 substring))
+                                  ((1 3) (lisp-string-to-string16 substring)))
+                                (aref *font-list-tags* codeset))))
+                 (tk::add-widget-cleanup-function parent
+                                                  #'destroy-generated-xm-string
+                                                  element)
+                 (let ((temp (if result
+                                 (xm_string_concat result element)
+                                 (xm_string_copy element))))
+                   (tk::add-widget-cleanup-function parent
+                                                    #'destroy-generated-xm-string
+                                                    temp)
+                   (setq result temp)))))
+        (declare (dynamic-extent #'extract))
+        (partition-compound-string value #'extract-element)
+        (or result
+            *empty-compound-string*
+            (setq *empty-compound-string*
+                  (xm_string_create_l_to_r (clim-utils:string-to-foreign "")
+                                           (clim-utils:string-to-foreign 
+                                            xm-font-list-default-tag))))))
+    ;; this would be nice instead, but isn't happening anytime soon (spr30362):
+    #+xm-string-supports-utf-8 
+    (let ((native-string (clim-utils:string-to-foreign value)))
+      (let ((xm-string (xm_string_create_localized native-string)))
+        (tk::add-widget-cleanup-function parent #'destroy-generated-xm-string
+                                         xm-string)
+        xm-string)
+      )))
 
  (:-ics
+
+  (defun partition-compound-string (s f &key (start 0) (end (length s)))
+    ;;(declare (ignore s))
+    (funcall f nil start end))
+
   (defmethod convert-resource-out ((parent t) (type (eql 'xm-string)) value)
     (let ((s1 (clim-utils:string-to-foreign value))
 	  (s2 (clim-utils:string-to-foreign "")))
@@ -200,8 +210,7 @@
 					 #'destroy-generated-xm-string
 					 temp) 
 	temp))
-    ))
- )
+    )))
 
 (defmethod convert-resource-out ((parent t) (type (eql 'xm-background-pixmap)) value)
   (etypecase value
@@ -306,3 +315,44 @@
   (error 'foo)
   value)
 
+(defvar *lookup-string-buffers* nil)
+
+(defvar *lookup-string-buffer-size* 256)
+
+(defmacro with-lookup-string-buffer ((var) &body body)
+  `(let ((,var (or (excl:without-interrupts (pop *lookup-string-buffers*))
+                   (excl::malloc *lookup-string-buffer-size*))))
+     (declare (type (unsigned-byte 8) buffer)) ; HUH??? an 8-bit word??
+     (multiple-value-prog1
+       (progn ,@body)
+       (excl:without-interrupts (push buffer *lookup-string-buffers*)))))
+
+(defun lookup-multibyte-string (event widget)
+  (declare (optimize (speed 0) (safety 3) (debug 3)))
+  (with-lookup-string-buffer (buffer)
+    (with-ref-par ((keysym 0 :unsigned-long)
+                   (status 0 :int))
+      (let* ((nbytes (xm_im_mb_lookup_string widget event buffer
+                                             *lookup-string-buffer-size*
+                                             &keysym &status)))
+        (declare (fixnum nbytes))
+        (format *debug-io* "Done looking up mb string: nc=~A/status=~A/event-t=~A~%"
+                nbytes status (event-type event))
+        (force-output *debug-io*)
+        (cond
+          ((= status x11::XBufferOverflow)
+           (warn "Too small buffer looking up the key event at size ~A."
+                 *lookup-string-buffer-size*)
+           (let ((*lookup-string-buffer-size* nbytes))
+             (lookup-multibyte-string event widget)))
+          ((= status x11::XLookupNone)
+           (values nil nil))
+          (t
+           (format *debug-io* "buffer=~A~%"
+                   (excl:native-to-octets buffer :length nbytes))
+           (let ((keysymp (or (= status x11::XLookupKeyBoth)
+                              (= status x11::XLookupKeySym)))
+                 (charsp (or (= status x11::XLookupKeyBoth)
+                             (= status x11::XLookupChars))))
+             (values (and charsp (excl:native-to-string buffer :length nbytes))
+                     (and keysymp keysym)))))))))
diff --git a/tk/xt-defs.lisp b/tk/xt-defs.lisp
index ca55fc02e808cf9b5af286bd4d8fe35f518c644f..e98769761fc23dab6cd63e8106a24e2acb276435 100644
--- a/tk/xt-defs.lisp
+++ b/tk/xt-defs.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xt-defs.lisp,v 2.9 2007/04/17 21:45:53 layer Exp $
+;; $Id: xt-defs.lisp,v 2.10 2007/12/11 17:20:21 layer Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -147,3 +147,5 @@
 
 (def-c-type (pointer-array :no-defuns :no-constructor) 1 * char)
 
+(x11::def-exported-constant lc-ctype 0)
+(x11::def-exported-constant lc-all 6)
diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp
index 9462bfc747e2719336cbe0e4032746b31f312869..a819809c7aad0a7cb30fe29ae7c604824e3d71ea 100644
--- a/tk/xt-funs.lisp
+++ b/tk/xt-funs.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xt-funs.lisp,v 2.10 2007/04/17 21:45:53 layer Exp $
+;; $Id: xt-funs.lisp,v 2.11 2007/12/11 17:20:21 layer Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -396,6 +396,18 @@
   :call-direct t
   :arg-checking nil)
 
+(def-foreign-call (x-supports-locale "XSupportsLocale")
+    ()
+  :returning (:int fixnum)
+  :strings-convert nil
+  :arg-checking nil)
+
+(def-foreign-call (x-set-locale-modifiers "XSetLocaleModifiers")
+    ((x :foreign-address))
+  :call-direct t
+  :returning :foreign-address
+  :arg-checking nil)
+
 #+debug
 (progn
 
diff --git a/utils/excl-verification.lisp b/utils/excl-verification.lisp
index f6b49004b542e37838c6b57c3e19b172e17894c1..3d8307ba92aafb8bbbc45096eab268f55349da01 100644
--- a/utils/excl-verification.lisp
+++ b/utils/excl-verification.lisp
@@ -1,3 +1,10 @@
+#+(version= 8 1)
+(sys:defpatch #+mswindows "climnt" #-mswindows "climxm"
+    1
+  "v1: full international font support"
+  :type :clim
+  :post-loadable t)
+
 ;; copyright (c) 1985,1986 Franz Inc, Alameda, Ca.
 ;; copyright (c) 1986-2005 Franz Inc, Berkeley, CA  - All rights reserved.
 ;; copyright (c) 2002-2007 Franz Inc, Oakland, CA - All rights reserved.
@@ -16,7 +23,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: excl-verification.lisp,v 2.7 2007/04/17 21:45:54 layer Exp $
+;; $Id: excl-verification.lisp,v 2.8 2007/12/11 17:20:21 layer Exp $
 
 (in-package :sys)
 
diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp
index 165f5987e33846f5eee3e9ad84740ff8d31e5300..385fbb80b36ac7badf96c617f332258492edd33c 100644
--- a/utils/lisp-utilities.lisp
+++ b/utils/lisp-utilities.lisp
@@ -17,7 +17,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: lisp-utilities.lisp,v 2.9 2007/04/17 21:45:54 layer Exp $
+;; $Id: lisp-utilities.lisp,v 2.10 2007/12/11 17:20:21 layer Exp $
 
 (in-package :clim-utils)
 
@@ -1699,23 +1699,35 @@
 	(setf (sys:memref-int pointer i 0 :unsigned-natural) 0)))
     pointer))
 
-;; Adapted from FF:STRING-TO-CHAR*.
-;;; We aren't using FF:STRING-TO-CHAR* because it uses excl:aclmalloc.
+;;; We aren't using excl:string-to-native by default because it uses
+;;; excl:aclmalloc.
+;; This now uses the slightly slower (locale-correct) way of
+;; converting to octets first, then copying to foreign space.
 (defun string-to-foreign (string &optional address)
   "Convert a Lisp string to a C string, by copying."
   (declare (optimize (speed 3))
-	   (type string string)
-	   (type integer address))
+                (type string string)
+                (type integer address))
   (unless (stringp string)
     (excl::.type-error string 'string))
-  (let* ((length (length string)))
-    (declare (optimize (safety 0))
-	     (type fixnum length))
-    (unless address
-      (setq address (_malloc (1+ length))))
-    (dotimes (i length)
-      (declare (fixnum i))
-      (setf (sys:memref-int address 0 i :unsigned-byte)
-	(char-code (char string i))))
-    (setf (sys:memref-int address 0 length :unsigned-byte) 0)
-    address))
+  (if address
+      (excl:string-to-native string :address address)
+      (let* ((octets (excl:string-to-octets string :null-terminate t))
+             (length (length octets)))
+        (declare (optimize (safety 0))
+                      (type fixnum length))
+        (setf address (_malloc length))
+        (dotimes (i length)
+          (declare (fixnum i))
+          (setf (sys:memref-int address 0 i :unsigned-byte)
+                (aref octets i)))
+        #+clim-utils::extra-careful(let ((re-char-ed (excl:octets-to-string octets)))
+          (assert (equal re-char-ed string)
+                  (re-char-ed string)
+                  "string isn't equal to re-chared octets~%~S~%~S!" string re-char-ed))))
+  
+  #+clim-utils::extra-careful(let ((re-lisped (excl:native-to-string address)))
+    (assert (equal re-lisped string)
+            (re-lisped string)
+            "string isn't equal to re-chared foreign mem ~%~S~%~S!" string re-lisped))
+  address)
diff --git a/xlib/xlib-defs.lisp b/xlib/xlib-defs.lisp
index 0163323c9962e081d51c80285dc3a75e1d77aefd..ac563ce5674bea226cc28cda979bbf338b69be7e 100644
--- a/xlib/xlib-defs.lisp
+++ b/xlib/xlib-defs.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xlib-defs.lisp,v 2.9 2007/04/17 21:45:54 layer Exp $
+;; $Id: xlib-defs.lisp,v 2.10 2007/12/11 17:20:21 layer Exp $
 
 ;;; (c) Copyright  1990 Sun Microsystems, Inc.  All Rights Reserved.
 ;;      (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design
@@ -1433,6 +1433,23 @@ typedef union { Display *display;
 (def-exported-foreign-synonym-type xim int)
 (def-exported-foreign-synonym-type xic int)
 
+(defconstant XNInputStyle "inputStyle")
+(defconstant XNClientWindow "clientWindow")
+(defconstant XNFocusWindow "focusWindow")
+(defconstant XNPreeditState "preeditState")
+(defconstant XIMPreeditNothing #x8)
+(defconstant XIMPreeditPosition #x4)
+(defconstant XIMStatusNothing #x400)
+(defconstant XIMStatusNone #x800)
+
+(defconstant XIMPreeditEnable #x1)
+
+(defconstant XBufferOverflow -1)
+(defconstant XLookupNone 1)
+(defconstant XLookupChars 2)
+(defconstant XLookupKeySym 3)
+(defconstant XLookupKeyBoth 4)
+
 
 (defconstant XrmoptionNoArg 0)
 (defconstant XrmoptionIsArg 1)
diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp
index 80e64f7f7ccf267191133a0e1575a908894ff65a..0e1ae6b377f21aa0c60a91e7503b400b24a01915 100644
--- a/xlib/xlib-funs.lisp
+++ b/xlib/xlib-funs.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xlib-funs.lisp,v 2.9 2007/06/06 17:15:06 layer Exp $
+;; $Id: xlib-funs.lisp,v 2.10 2007/12/11 17:20:21 layer Exp $
 
 ;;; (c) Copyright  1990 Sun Microsystems, Inc.  All Rights Reserved.
 ;;      (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design
@@ -1779,6 +1779,16 @@
    (string (:pointer char))
    (length fixnum-int))
 
+(def-exported-foreign-function (xmbdrawstring (:name "XmbDrawString"))
+   (dpy (:pointer display))
+   (d fixnum-drawable)
+   (font-set xfontset)
+   (gc gc)
+   (x fixnum-int)
+   (y fixnum-int)
+   (string (:pointer char))
+   (length fixnum-int))
+
 (def-exported-foreign-function (xdrawstring16 (:name "XDrawString16"))
    (dpy (:pointer display))
    (d fixnum-drawable)
@@ -2010,9 +2020,14 @@
   (window window)
   (context xcontext))
 
+(def-exported-foreign-function (xfilterevent (:return-type fixnum-int)
+                                             (:name "XFilterEvent"))
+  (event (:pointer xevent))
+  (window window))
+
 (def-exported-foreign-function (xlookupstring (:return-type fixnum-int)
 					      (:name "XLookupString"))
-  (event-struct  (:pointer xkeyevent))
+    (event-struct  (:pointer xkeyevent))
   (buffer-return (:pointer char))
   (bytes-buffer	int)
   (keysym-return (:pointer keysym))
@@ -2066,3 +2081,9 @@
 						  (:name "_XGetBitsPerPixel"))
     (dpy (:pointer display))
     (depth int))
+
+(def-exported-foreign-function (xmbtextescapement (:return-type int)
+                                                  (:name "XmbTextEscapement"))
+    (font-set xfontset)
+    (string (:pointer char))
+    (num-bytes int))