diff --git a/ChangeLog.n b/ChangeLog.n
index 6777933f1b0c727411b730fdbf1675ff2cb2b9ee..92a1025289a48f5e73a69948fe3db00fe44dc97f 100644
--- a/ChangeLog.n
+++ b/ChangeLog.n
@@ -1,3 +1,26 @@
+*******************************************************************************
+join from trunk_afuchs2 to trunk
+    changes from:
+	2007-03-28  Andreas Fuchs  <afuchs@franz.com>
+
+*******************************************************************************
+2007-03-28  Andreas Fuchs  <afuchs@franz.com>
+
+	* silica/classes.lisp: Back out experimental code.
+        * silica/text-style.lisp: Back out experimental code.
+        * tk/font.lisp: Back out experimental code.
+        * tk/resources.lisp: Back out experimental code.
+        * tk/widget.lisp: Back out experimental code.
+        * tk/xlib.lisp: Back out experimental code.
+        * tk/xm-defs.lisp: Back out experimental code.
+        * tk/xm-font-list.lisp: Back out experimental code.
+        * tk/xm-widgets.lisp: Back out experimental code.
+        * tk/xt-defs.lisp: Back out experimental code.
+        * tk/xt-funs.lisp: Back out experimental code.
+        * tk-silica/xt-silica.lisp: Back out experimental code.
+        * utils/lisp-utilities.lisp: Back out experimental code.
+        * xlib/xlib-defs.lisp: Back out experimental code.
+
 2007-03-15    <layer@HOBART>
 
 	* aclpc/acl-class.lisp: remove warning due to bogus decl
@@ -6121,4 +6144,4 @@ IGNORE JDI SPECIFIC CHANGES TO Makefile
 	Lots of other stuff
 
 *******************************************************************************
-$Revision: 2.29 $
+$Revision: 2.30 $
diff --git a/silica/classes.lisp b/silica/classes.lisp
index 8c6f9bde9cdd17ecfc4e3e626b1dbfab2f4d9a85..d7330b1f5b5f898b088bf1b5dfadfb27559ff9a6 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.7 2006/10/10 18:05:08 layer Exp $
+;; $Id: classes.lisp,v 2.8 2007/04/02 18:07:42 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 :adjustable t)))
+   (:+ics (let ((v (make-array 4)))
 	    (dotimes (i 4)
-	      (setf (aref v i)
+	      (setf (svref 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 :adjustable t)))
+   (:+ics (let ((v (make-array 4)))
 	    (dotimes (i 4)
-	      (setf (aref v i)
+	      (setf (svref v i)
 		(cons nil nil)))
 	    v))
    (:-ics (cons nil nil))))
diff --git a/silica/text-style.lisp b/silica/text-style.lisp
index d63382da83275a9f7fbdbe14cbec30c7d18d436d..64e6c1b80c985b98c88439e8e7b87ad39ca11ead 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.8 2006/10/11 16:16:30 layer Exp $
+;; $Id: text-style.lisp,v 2.9 2007/04/02 18:07:42 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,66 +628,56 @@
 
 (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 (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))
+    #+allegro
+    (excl:ics-target-case
+     (:-ics character-set mapping-table)
+     (:+ics (svref 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 (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))
+    #+allegro
+    (excl:ics-target-case
+     (:-ics character-set mapping-cache)
+     (:+ics (svref 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/xt-silica.lisp b/tk-silica/xt-silica.lisp
index a9142d53e46a501dfaa551f1bf4c97a8d9dabf56..08aa87b139a339e8d5ae38b1c16c445ad5c1e4e8 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.7 2006/10/10 18:05:08 layer Exp $
+;; $Id: xt-silica.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $
 
 (in-package :xm-silica)
 
@@ -37,7 +37,6 @@
      (rotated-string-cache :initform nil :accessor port-rotated-string-cache)
      (depth :accessor port-depth)
      (visual-class :accessor port-visual-class)
-     (visual :accessor port-visual)
      (cursor-font :initform nil)
      (cursor-cache :initform nil)
      (font-cache :initform (make-hash-table :test #'equal))
@@ -62,20 +61,16 @@
 
 ;; access to port-copy-gc should be within a without-scheduling
 
-(defun make-pixmap (display depth)
-  (make-instance 'tk::pixmap
-     :drawable
-     (tk::display-root-window display)
-     :depth depth :width 1 :height 1))
-
 (defmethod port-copy-gc ((port xt-port))
   ;;-- Assume 1-1 port-graft mapping?
-  (with-slots (copy-gc display depth) port
+  (with-slots (copy-gc display) port
     (or copy-gc
 	(setf copy-gc
 	  (make-instance 'tk::gcontext
-	    :drawable (make-pixmap display depth)
-	    :graphics-exposures :on)))))
+	    :display display
+	    :graphics-exposures :on
+	    :foreign-address (x11:screen-default-gc
+ 			      (x11:xdefaultscreenofdisplay display)))))))
 
 ;;--- I don't know of a better way of getting a depth 1 drawable
 ;;other than by making a dummy depth 1 pixmap
@@ -83,7 +78,10 @@
   ;;-- Assume 1-1 port-graft mapping?
   (with-slots (copy-gc-depth-1 display) port
     (or copy-gc-depth-1
-	(let ((pixmap (make-pixmap display 1)))
+	(let ((pixmap (make-instance 'tk::pixmap
+				     :drawable
+				     (tk::display-root-window display)
+				     :depth 1 :width 1 :height 1)))
 	  (prog1
 	      (setf copy-gc-depth-1
 		(make-instance 'tk::gcontext :drawable pixmap))
@@ -98,9 +96,7 @@
       (mp:process-run-function
        (list :name (format nil "CLIM Event Dispatcher for ~A"
 			   (port-server-path port))
-	     :priority 1000
-             :initial-bindings `((excl:*locale* . ',excl:*locale*)
-                                 ,@excl:*cl-default-special-bindings*))
+	     :priority 1000)
        #'port-event-loop port))
     (setf (getf (mp:process-property-list process) :no-interrupts) t)
     (setf (port-process port) process)))
@@ -114,95 +110,36 @@
 (defmethod initialize-instance :after ((port xt-port) &key server-path)
   (setq tk::*x-io-error-hook* #'xt-fatal-error-handler)
   (destructuring-bind
-        (&key (display nil display-p)
-              (application-name nil application-name-p)
-              (application-class nil application-class-p)
-              (color-depth nil)
-              (visual-class nil))
+      (&key (display nil display-p)
+	    (application-name nil application-name-p)
+	    (application-class nil application-class-p))
       (cdr server-path)
     (let ((args nil))
       (when display-p (setf (getf args :host) display))
       (when application-name-p (setf (getf args :application-name) application-name))
       (when application-class-p (setf (getf args :application-class) application-class))
       (multiple-value-bind (context display application-shell)
-          (apply #'tk::initialize-toolkit args)
-        (setf (slot-value port 'application-shell) application-shell
-              (slot-value port 'context) context
-              (slot-value port 'display) display)
-        (initialize-port-visual-info port display application-shell color-depth visual-class)
-        (let* ((screen (x11:xdefaultscreenofdisplay display))
-               (bs-p (not (zerop (x11::screen-backing-store screen))))
-               (su-p (not (zerop (x11::screen-save-unders screen))))
-               (vendor (excl:native-to-string (x11::display-vendor display))))
-          (if (and bs-p su-p
-                   (notany #'(lambda (x) (search x vendor)) *unreliable-server-vendors*))
-              (setf (slot-value port 'safe-backing-store) t)))
-        (initialize-xlib-port port display)))))
- 
- 
-(defparameter *visual-classes*
-  '((0 :static-gray)
-    (1 :gray-scale)
-    (2 :static-color)
-    (3 :pseudo-color)
-    (4 :true-color)
-    (5 :direct-color)))
- 
-(defun initialize-port-visual-info (port display application-shell color-depth visual-class)
-  "Initializes the port's color-depth, visual-class and palette."
- 
-  ;; Make sure that we have a visual-class that makes sense.
-  (let ((default-visual-class (tk::screen-root-visual-class (tk::default-screen display))))
-    (if visual-class
-        (unless (member visual-class *visual-classes* :key #'second)
-          (cerror "Use the default visual-class instead."
-                  "The port's visual-class must be one of the following:~% ~{~S~^, ~}"
-                  (mapcar #'second *visual-classes*))
-          (setq visual-class default-visual-class))
-        ;; Use default if no visual-class was specified.
-        (setq visual-class default-visual-class))
- 
-    ;; Use default color-depth if none was specified.
-    (let ((default-depth (x11:xdefaultdepth display
-                                            (tk::display-screen-number display))))
-      (unless color-depth
-        (setq color-depth default-depth))
- 
-      ;; Try to find a visual of the specified color-depth and visual class.
-      ;; If we find one, use it. Otherwise, fall back to default settings.
-      (let* ((visual (find-visual display color-depth visual-class))
-             (colormap (if visual
-                           (tk::create-colormap display :visual visual)
-                           (tk::default-colormap display))))
-        (if (null visual)
-            (warn "Can't find ~A visual of color depth ~D.  Using default visual instead."
-                  visual-class color-depth))
-        (when visual-class
-          (format *debug-io* "~&setting non-default visual ~A~%" visual)
-          (tk::set-values application-shell
-                          :visual visual
-                          :depth color-depth
-                          :colormap colormap))
-        (setf (port-depth port) (if visual color-depth default-depth)
-              (port-visual port) (when visual visual)
-              (port-visual-class port) (if visual visual-class default-visual-class))
-        (setf (slot-value port 'silica::default-palette)
-              (make-palette port :colormap colormap))))))
-
-(defun find-visual (display depth class)
-  (let ((screen (tk::display-screen-number display))
-        (class-nr (first (find class *visual-classes* :key #'second)))
-        (visual-info (tk::note-malloced-object
-                      (clim-utils::allocate-cstruct 'x11::visual-info :initialize t))))
-    (let ((return-code (x11:xmatchvisualinfo display screen depth class-nr visual-info)))
-      (if (zerop return-code)
-          nil
-          (x11::visual-info-visual visual-info)))))
-
+	  (apply #'tk::initialize-toolkit args)
+	(setf (slot-value port 'application-shell) application-shell
+	      (slot-value port 'context) context
+	      (slot-value port 'display) display
+	      (port-depth port) (x11:xdefaultdepth display (tk::display-screen-number display))
+	      (port-visual-class port) (tk::screen-root-visual-class (tk::default-screen display))
+	      (slot-value port 'silica::default-palette)
+	      (make-palette port :colormap
+			    (tk::default-colormap (port-display port))))
+	(let* ((screen (x11:xdefaultscreenofdisplay display))
+	       (bs-p (not (zerop (x11::screen-backing-store screen))))
+	       (su-p (not (zerop (x11::screen-save-unders screen))))
+	       (vendor (excl:native-to-string (x11::display-vendor display))))
+	  (if (and bs-p su-p
+		   ;; An amazing crock.  XXX
+		   (notany #'(lambda (x) (search x vendor)) *unreliable-server-vendors*))
+	      (setf (slot-value port 'safe-backing-store) t)))
+	(initialize-xlib-port port display)))))
 
 (defun xt-fatal-error-handler (d)
   (excl:without-interrupts
-    (break)
     (let* ((display (tk::find-object-from-address d))
 	   (context (tk::display-context display)))
       (block done
@@ -221,43 +158,6 @@
 	       '(: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
@@ -313,77 +213,29 @@
 	 (screen-pixels-per-inch
 	  (* 25.4 (/ (x11::xdisplayheight display screen)
 		     (x11:xdisplayheightmm display screen)))))
-    (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))))))
+    (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)))))))
       ;; 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
@@ -396,39 +248,55 @@ setup."
       ;; 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.
-      (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))))))
-        )))
+      (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))))))))
   (setup-stipples port display))
 
 (defparameter *xt-logical-size-alist*
@@ -1175,6 +1043,8 @@ setup."
 (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)
@@ -1186,16 +1056,18 @@ setup."
 	      (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)))
+      (dotimes (c +codesets+)
+	(let ((mapping (text-style-mapping port text-style c)))
 	  (when mapping
-            (push (cons c mapping) mappings))))
+	    (push (cons c mapping) mappings))))
       (reverse mappings))))
 
 (defmethod font-set-from-font-list ((port xt-port) font-list)
-  (let ((name (format nil "~{~A~^,~}"
-                      (mapcar (lambda (font) (tk::font-name (cdr font)))
-                              font-list))))
+  (let ((name ""))
+    (dolist (item font-list)
+      (setq name
+	(concatenate 'string
+	  (tk::font-name (cdr item)) "," name)))
     (with-slots (font-cache) port
       (setq font-list
 	(or (gethash name font-cache)
diff --git a/tk/font.lisp b/tk/font.lisp
index 03d4b049396776603a0ef15cafff37ab830b542e..90a7e6ddde18654a355762bda435ba120b6fee8a 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.7 2006/10/10 18:05:08 layer Exp $
+;; $Id: font.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $
 
 (in-package :tk)
 
@@ -184,15 +184,6 @@
 	      (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
@@ -200,9 +191,8 @@
 	(create-font-set display base-names)
       (when missing
 	(let ((*error-output* excl:*initial-terminal-io*))
-	  (warn 'charsets-missing-from-fontset
-                :charsets missing
-                :created-for base-names)))
+	  (warn "Missing charsets:~{ ~A,~} creating fontset for ~A"
+		missing 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/resources.lisp b/tk/resources.lisp
index 961043b5106adffa7ca2be267efa3a7fe32e4742..c4d93bb94fcaeeaf14b204da72722a33c9781879 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.7 2006/10/10 18:05:08 layer Exp $
+;; $Id: resources.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $
 
 (in-package :tk)
 
@@ -825,14 +825,3 @@
   (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)
\ No newline at end of file
diff --git a/tk/widget.lisp b/tk/widget.lisp
index 1abfca0c8ae610d32b4482e13fcf32a5f66b5f9a..059cc427d5c24e3290d789486361c8f03208f7df 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.7 2006/10/10 18:05:08 layer Exp $
+;; $Id: widget.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $
 
 (in-package :tk)
 
@@ -360,36 +360,6 @@
 	 (:+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")))
-
-(ff:defun-foreign-callable xt-current-locale-for-acl ((display (* :void)) (xnl (* :char)) (client-data (* :void)))
-  (declare (:convention :c)
-           (ignore display client-data xnl))
-  
-  (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*))))
-           (try-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))))
-    (let ((locale (excl:locale-name excl:*locale*))
-          (encoding (ef-name (excl:locale-external-format excl:*locale*))))
-      (or (if encoding
-              (try-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-locale (format nil "~A" locale))
-          ;; didn't find any locale.
-          (try-locale "C")))))
-
 ;; note that this is different from xt-initialize which calls
 ;; XtToolkitInitialize. This is closer to XtAppInitialize
 
@@ -402,11 +372,11 @@
 	 (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))))
-    (excl:ics-target-case
-      (:+ics (xt_set_language_proc 0 (register-foreign-callable 'xt-current-locale-for-acl :reuse t) 0)))
+    #+ignore (excl:ics-target-case
+	      (:+ics (xt_set_language_proc context 0 0)))
     (let* ((display (apply #'make-instance 'display
 			   :context context
 			   args))
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index ce201fae1f3c47a9168b2336c6947e30357d506f..1e04b3cf408137a10c8bd03978a8bf6235dc35cd 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.8 2007/01/25 21:19:29 layer Exp $
+;; $Id: xlib.lisp,v 2.9 2007/04/02 18:07:42 layer Exp $
 
 (in-package :tk)
 
@@ -214,18 +214,6 @@
 	     (error "Unknown resource type: ~A" type)))
 	   type))))))
 
-(defun put-resource (db specifier xrm-type type value)
-  (let ((xrmvalue (make-xrmvalue)))
-     (setf (x11:xrmvalue-size xrmvalue) (ff:sizeof-fobject type)
-           (x11:xrmvalue-addr xrmvalue) value)
-     (format *trace-output* "putting resource in db ~S spec:~S xrmval:~S xrmtype:~S type:~S value:~S~%" db specifier xrmvalue xrm-type type value)
-     (x11:xrmputresource db
-                         (lisp-string-to-string8 specifier)
-                         (lisp-string-to-string8 xrm-type)
-                         xrmvalue)
-     (format *trace-output* "done.~%")))
-   
-
 (defun convert-string (widget string to-type)
   (let ((from (make-xrmvalue))
 	(to-in-out (make-xrmvalue)))
@@ -343,19 +331,17 @@
 
 (define-window-accessor colormap ())
 
-(defun create-colormap (display &key
-                        (screen (display-screen-number display))
-                        (visual (x11:xdefaultvisual display screen)))
+(defun create-colormap (display &optional (screen (display-screen-number display)))
   (intern-object-xid
-   (x11:xcreatecolormap  display
-                         (x11:xrootwindow display screen)
-                         visual
-                         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)
diff --git a/tk/xm-defs.lisp b/tk/xm-defs.lisp
index 7768f3d9f5fe4b807e4b47be7500275f62b288a7..2ff515bdc791c21d155535a6d1ffc6e2a6869736 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.8 2006/10/10 18:05:08 layer Exp $
+;; $Id: xm-defs.lisp,v 2.9 2007/04/02 18:07:42 layer Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -82,8 +82,3 @@
 (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")
diff --git a/tk/xm-font-list.lisp b/tk/xm-font-list.lisp
index 7f33117858c96ee8b9c37735591876eea37d7c3e..231c6daff351c941671426e094997b2125ff6daa 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.7 2006/10/10 18:05:08 layer Exp $
+;; $Id: xm-font-list.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $
 
 (in-package :tk)
 
@@ -60,50 +60,49 @@
 (excl:ics-target-case
  (:+ics
   (defvar *font-list-tags*
-      (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"))
+      (vector 
        
-                  ))))
+       ;; 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 (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))))
+    (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))))
 
 #+:dec3100
 (defmethod convert-resource-out ((parent t) (type (eql 'xm-font-list)) value)
diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp
index 049ffa2119661df0791aeb60a1db72a86590f292..3f941e2fae4a49e2a31d73ad720a59e9774973d6 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.7 2006/10/10 18:05:08 layer Exp $
+;; $Id: xm-widgets.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $
 
 (in-package :tk)
 
@@ -162,7 +162,7 @@
 				(ecase codeset
 				  ((0 2) (lisp-string-to-string8 substring))
 				  ((1 3) (lisp-string-to-string16 substring)))
-				(aref *font-list-tags* codeset))))
+				(svref *font-list-tags* codeset))))
 		 (tk::add-widget-cleanup-function parent
 						  #'destroy-generated-xm-string
 						  element)
diff --git a/tk/xt-defs.lisp b/tk/xt-defs.lisp
index 811367f3319c37e1f28009c4ff7a16e38822a866..3799c45460e11641da91f0db65e02cce1edcfa12 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.7 2006/10/10 18:05:08 layer Exp $
+;; $Id: xt-defs.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -147,5 +147,3 @@
 
 (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)
\ No newline at end of file
diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp
index 79f03b438f2a5428fdb6044f104599b891fb0e2d..1d03880dda02afc3c6d7280b86cbc0dc165cb9b4 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.8 2006/10/11 16:16:30 layer Exp $
+;; $Id: xt-funs.lisp,v 2.9 2007/04/02 18:07:42 layer Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -396,18 +396,6 @@
   :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/lisp-utilities.lisp b/utils/lisp-utilities.lisp
index 5824d608e799f7f398374215eb5cf8898d59d38a..296ddd73573961c67274e3d1d9253ec0c22f978b 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.7 2006/10/10 18:05:08 layer Exp $
+;; $Id: lisp-utilities.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $
 
 (in-package :clim-utils)
 
@@ -1699,35 +1699,23 @@
 	(setf (sys:memref-int pointer i 0 :unsigned-natural) 0)))
     pointer))
 
-;;; 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.
+;; Adapted from FF:STRING-TO-CHAR*.
+;;; We aren't using FF:STRING-TO-CHAR* because it uses excl:aclmalloc.
 (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))
-  (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)
+  (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))
diff --git a/xlib/xlib-defs.lisp b/xlib/xlib-defs.lisp
index d29d9cc536020f798690e05ce31974de1ac1e0dc..333aeafbb1dd917f6eb3da1fa9cd5c9c83d7dcf0 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.7 2006/10/10 18:05:09 layer Exp $
+;; $Id: xlib-defs.lisp,v 2.8 2007/04/02 18:07:42 layer Exp $
 
 ;;; (c) Copyright  1990 Sun Microsystems, Inc.  All Rights Reserved.
 ;;      (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design
@@ -707,18 +707,6 @@
   (bits-per-rgb :type int)
   (map-entries :type int))
 
-(def-exported-foreign-struct visual-info
-  (visual :type (:pointer visual))
-  (visual-id :type visualid)
-  (screen :type int)
-  (depth :type unsigned-int)
-  (class :type int)
-  (red-mask :type unsigned-long)
-  (green-mask :type unsigned-long)
-  (blue-mask :type unsigned-long)
-  (colormap-size :type int)
-  (bits-per-rgb :type int))
-
 (def-exported-foreign-struct depth
   (depth :type int)
   (nvisuals :type int)