--- a/lisp/x11/x-font-menu.el	Mon Aug 13 09:08:31 2007 +0200
+++ b/lisp/x11/x-font-menu.el	Mon Aug 13 09:09:02 2007 +0200
@@ -2,9 +2,11 @@
 
 ;; Copyright (C) 1994 Free Software Foundation, Inc.
 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
+;; Copyright (C) 1997 Sun Microsystems
 
 ;; Author: Jamie Zawinski <jwz@lucid.com>
 ;; Restructured by: Jonathan Stigelman <Stig@hackvan.com>
+;; Mule-ized by: Martin Buchholz
 
 ;; This file is part of XEmacs.
 
@@ -62,9 +64,9 @@
 ;;; `reset-device-font-menus' to rebuild the menus from all currently
 ;;; available fonts.
 ;;;
-;;; There is knowledge here about the regexp match numbers in `x-font-regexp',
-;;; `x-font-regexp-foundry-and-family', and
-;;; `x-font-regexp-registry-and-encoding' defined in x-faces.el.
+;;; There is knowledge here about the regexp match numbers in
+;;; `x-font-regexp' and `x-font-regexp-foundry-and-family' defined in
+;;; x-faces.el.
 ;;;
 ;;; There are at least three kinds of fonts under X11r5:
 ;;;
@@ -97,7 +99,7 @@
 ;;;	(font-properties (face-font 'default))
 ;;; - The values of the following variables after making a selection:
 ;;;	font-menu-preferred-resolution
-;;;	font-menu-preferred-registry
+;;;	font-menu-registry-encoding
 ;;;
 ;;; There is a common misconception that "*-courier-medium-r-*-11-*", also
 ;;; known as "-adobe-courier-medium-r-normal--11-80-100-100-m-60-iso8859-1",
@@ -105,6 +107,21 @@
 ;;; which is an 8-point font (the number after -11- is the size in tenths
 ;;; of points).  So if you expect to be seeing an "11" entry in the "Size"
 ;;; menu and are not, this may be why.
+;;;
+;;; In the real world (aka Solaris), one has to deal with fonts that
+;;; appear to be medium-i but are really light-r, and fonts that
+;;; resolve to different resolutions depending on the charset:
+;;;
+;;; (font-instance-truename
+;;;  (make-font-instance "-*-mincho-medium-i-normal-*-*-*-*-*-*-*-jisx0201*-*"))
+;;; ==>
+;;; "-morisawa-ryumin light kl-light-r-normal--10-100-72-72-m-50-jisx0201.1976-0"
+;;;
+;;; (list-fonts "-dt-interface user-medium-r-normal-s*-*-*-*-*-*-*-*-*")
+;;; ==>
+;;; ("-dt-interface user-medium-r-normal-s sans-12-120-72-72-m-70-iso8859-1"
+;;;  "-dt-interface user-medium-r-normal-s-14-120-75-75-m-120-jisx0208.1983-0"
+;;;  "-dt-interface user-medium-r-normal-s-14-120-75-75-m-60-jisx0201.1976-0")
 
 ;;; Code:
 
@@ -126,10 +143,13 @@
 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)
 (defvar device-fonts-cache nil)
 
-(defconst font-menu-preferred-registry nil) 
-(defconst font-menu-preferred-resolution nil)
+(defvar font-menu-registry-encoding nil
+  "Registry and encoding to use with font menu fonts.")
 
-(defconst fonts-menu-junk-families
+(defvar font-menu-preferred-resolution "*-*"
+  "Preferred horizontal and vertical font menu resolution (e.g. \"75-75\").")
+
+(defvar fonts-menu-junk-families
   (purecopy
    (mapconcat
     #'identity
@@ -143,6 +163,11 @@
     "\\|"))
   "A regexp matching font families which are uninteresting (e.g. cursor fonts).")
 
+(eval-when-compile
+  (defsubst device-fonts-cache ()
+    (or (cdr (assq (selected-device) device-fonts-cache))
+	(reset-device-font-menus (selected-device)))))
+
 (defun hack-font-truename (fn)
   "Filter the output of `font-instance-truename' to deal with Japanese fontsets."
   (if (string-match "," (font-instance-truename fn))
@@ -161,8 +186,8 @@
 (fset 'install-font-menus 'reset-device-font-menus)
 (make-obsolete 'install-font-menus 'reset-device-font-menus)
 
-(defvar x-font-regexp-ja nil
-  "This is used to filter out fonts that don't work in the locale.
+(defvar x-font-regexp-ascii nil
+  "This is used to filter out font families that can't display ASCII text.
 It must be set at run-time.")
 
 (defun vassoc (key valist)
@@ -191,30 +216,20 @@
 	  (not (or device (setq device (selected-device))))
 	  (not (eq (device-type device) 'x)))
       nil
-    (if (and (getenv "LANG")
-	     (string-match "^\\(ja\\|japanese\\)$"
-			   (getenv "LANG")))
-	;; #### - this is questionable behavior left over from the I18N4 code.
-	(setq x-font-regexp-ja "jisx[^-]*-[^-]*$"
-	      font-menu-preferred-registry '("*" . "*")
-	      font-menu-preferred-resolution '("*" . "*")))
-    (let ((all-fonts nil)
-	  (case-fold-search t)
-	  name family size weight entry monospaced-p
-	  dev-cache
-	  (cache nil)
-	  (families nil)
-	  (sizes nil)
-	  (weights nil))
-      (cond ((stringp debug)		; kludge
-	     (setq all-fonts (split-string debug "\n")))
-	    (t
-	     (setq all-fonts
-		   (or debug
-		       (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device)))))
-      (while (setq name (pop all-fonts))
-	(when (and (or (not x-font-regexp-ja)
-		       (string-match x-font-regexp-ja name))
+    (unless x-font-regexp-ascii
+      (setq x-font-regexp-ascii (if (fboundp 'charset-registry)
+				    (charset-registry 'ascii)
+				  "iso8859-1")))
+    (setq font-menu-registry-encoding
+	  (if (featurep 'mule) "*-*" "iso8859-1"))
+    (let ((case-fold-search t)
+	  family size weight entry monospaced-p
+	  dev-cache cache families sizes weights)
+      (dolist (name (cond ((null debug)	; debugging kludge
+			   (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device))
+			  ((stringp debug) (split-string debug "\n"))
+			  (t debug)))
+	(when (and (string-match x-font-regexp-ascii name)
 		   (string-match x-font-regexp name))
 	  (setq weight (capitalize (match-string 1 name))
 		size   (string-to-int (match-string 6 name)))
@@ -229,18 +244,12 @@
 			    (car (setq cache
 				       (cons (vector family nil nil t)
 					     cache)))))
-	    (or (member family families)
-		(setq families (cons family families)))
-	    (or (member weight weights)
-		(setq weights (cons weight weights)))
-	    (or (member weight (aref entry 1))
-		(aset entry 1 (cons weight (aref entry 1))))
-	    (or (member size sizes)
-		(setq sizes (cons size sizes)))
-	    (or (member size (aref entry 2))
-		(aset entry 2 (cons size (aref entry 2))))
-	    (aset entry 3 (and (aref entry 3) monospaced-p))
-	    )))
+	    (or (member family families) (push family families))
+	    (or (member weight weights)  (push weight weights))
+	    (or (member size   sizes)    (push size   sizes))
+	    (or (member weight (aref entry 1)) (push weight (aref entry 1)))
+	    (or (member size   (aref entry 2)) (push size   (aref entry 2)))
+	    (aset entry 3 (and (aref entry 3) monospaced-p)))))
       ;;
       ;; Hack scalable fonts.
       ;; Some fonts come only in scalable versions (the only size is 0)
@@ -267,181 +276,178 @@
 	    (setq sizes (delq 0 sizes))))
 
       (setq families (sort families 'string-lessp)
-	    weights (sort weights 'string-lessp)
-	    sizes (sort sizes '<))
+	    weights  (sort weights 'string-lessp)
+	    sizes    (sort sizes '<))
 
-      (let ((rest cache))
-	(while rest
-	  (aset (car rest) 1 (sort (aref (car rest) 1) 'string-lessp))
-	  (aset (car rest) 2 (sort (aref (car rest) 2) '<))
-	  (setq rest (cdr rest))))
+      (dolist (entry cache)
+	  (aset entry 1 (sort (aref entry 1) 'string-lessp))
+	  (aset entry 2 (sort (aref entry 2) '<)))
 
       (message "Getting list of fonts from server... done.")
 
       (setq dev-cache (assq device device-fonts-cache))
       (or dev-cache
 	  (setq dev-cache (car (push (list device) device-fonts-cache))))
-      (setcdr dev-cache
-	      (vector
-	       cache
-	       (mapcar #'(lambda (x)
-			   (vector x
-				   (list 'font-menu-set-font x nil nil)
-				   ':style 'radio ':active nil ':selected nil))
-		       families)
-	       (mapcar #'(lambda (x)
-			   (vector (if (/= 0 (% x 10))
-				       ;; works with no LISP_FLOAT_TYPE
-				       (concat (int-to-string (/ x 10)) "."
-					       (int-to-string (% x 10)))
-				     (int-to-string (/ x 10)))
-				   (list 'font-menu-set-font nil nil x)
-				   ':style 'radio ':active nil ':selected nil))
-		       sizes)
-	       (mapcar #'(lambda (x)
-			   (vector x
-				   (list 'font-menu-set-font nil x nil)
-				   ':style 'radio ':active nil ':selected nil))
-		       weights)))
+      (setcdr
+       dev-cache
+       (vector
+	cache
+	(mapcar (lambda (x)
+		  (vector x
+			  (list 'font-menu-set-font x nil nil)
+			  ':style 'radio ':active nil ':selected nil))
+		families)
+	(mapcar (lambda (x)
+		  (vector (if (/= 0 (% x 10))
+			      ;; works with no LISP_FLOAT_TYPE
+			      (concat (int-to-string (/ x 10)) "."
+				      (int-to-string (% x 10)))
+			    (int-to-string (/ x 10)))
+			  (list 'font-menu-set-font nil nil x)
+			  ':style 'radio ':active nil ':selected nil))
+		sizes)
+	(mapcar (lambda (x)
+		  (vector x
+			  (list 'font-menu-set-font nil x nil)
+			  ':style 'radio ':active nil ':selected nil))
+		weights)))
       (cdr dev-cache))))
 
-(defsubst font-menu-truename (face)
-  (hack-font-truename
-   (if (featurep 'mule)
-       (face-font-instance face nil 'ascii)
-     (face-font-instance face))))
+;; Extract font information from a face.  We examine both the
+;; user-specified font name and the canonical (`true') font name.
+;; These can appear to have totally different properties.
+;; For examples, see the prolog above.
 
-;;; Extract a font family from a face.
-;;; Use the user-specified one if possible.
-;;; If the user didn't specify one (with "*", for example)
-;;; get the truename and use the guaranteed family from that.
-(defun font-menu-family (face)
-  (let ((dcache (cdr (assq (selected-device) device-fonts-cache)))
-	(name (font-instance-name (face-font-instance face)))
-	(family nil))
+;; We use the user-specified one if possible, else use the truename.
+;; If the user didn't specify one (with "-dt-*-*", for example)
+;; get the truename and use the possibly suboptimal data from that.
+(defun* font-menu-font-data (face dcache)
+  (let* ((case-fold-search t)
+	 (domain (if font-menu-this-frame-only-p
+				  (selected-frame)
+				(selected-device)))
+	 (name (font-instance-name (face-font-instance face domain)))
+	 (truename (font-instance-truename
+		    (face-font-instance face domain
+					(if (featurep 'mule) 'ascii))))
+	 family size weight entry slant)
     (when (string-match x-font-regexp-foundry-and-family name)
-      (setq family (capitalize (match-string 1 name))))
-    (when (not (and family (vassoc family (aref dcache 0))))
-      (setq name (font-menu-truename face))
-      (string-match x-font-regexp-foundry-and-family name)
-      (setq family (capitalize (match-string 1 name))))
-    family))
+      (setq family (capitalize (match-string 1 name)))
+      (setq entry (vassoc family (aref dcache 0))))
+    (when (and (null entry)
+	       (string-match x-font-regexp-foundry-and-family truename))
+      (setq family (capitalize (match-string 1 truename)))
+      (setq entry  (vassoc family (aref dcache 0))))
+    (when (null entry)
+      (return-from font-menu-font-data (make-vector 5 nil)))
+    
+    (when (string-match x-font-regexp name)
+      (setq weight (capitalize    (match-string 1 name)))
+      (setq size   (string-to-int (match-string 6 name))))
+      
+    (when (string-match x-font-regexp truename)
+      (when (not (member weight (aref entry 1)))
+	(setq weight (capitalize (match-string 1 truename))))
+      (when (not (member size   (aref entry 2)))
+	(setq size (string-to-int (match-string 6 truename))))
+      (setq slant (capitalize (match-string 2 truename))))
+      
+    (vector entry family size weight slant)))
 
 ;;;###autoload
 (defun font-menu-family-constructor (ignored)
-  ;; by Stig@hackvan.com
-  (if (not (eq 'x (device-type (selected-device))))
-      '(["Cannot parse current font" ding nil])
-    (let* ((dcache (cdr (assq (selected-device) device-fonts-cache)))
-	   (name (font-menu-truename 'default))
-	   (case-fold-search t)
-	   family weight size		; parsed from current font
-	   entry			; font cache entry
+  (catch 'menu
+    (unless (eq 'x (device-type (selected-device)))
+      (throw 'menu '(["Cannot parse current font" ding nil])))
+    (let* ((dcache (device-fonts-cache))
+	   (font-data (font-menu-font-data 'default dcache))
+	   (entry  (aref font-data 0))
+	   (family (aref font-data 1))
+	   (size   (aref font-data 2))
+	   (weight (aref font-data 3))
 	   f)
-      (or dcache
-	  (setq dcache (reset-device-font-menus (selected-device))))
-      (if (not (string-match x-font-regexp name))
-	  ;; couldn't parse current font
-	  '(["Cannot parse current font" ding nil])
-	(setq weight (capitalize (match-string 1 name)))
-	(setq size (string-to-number (match-string 6 name)))
-	(setq family (font-menu-family 'default))
-	(setq entry (vassoc family (aref dcache 0)))
-	(mapcar #'(lambda (item)
-		    ;;
-		    ;; Items on the Font menu are enabled iff that font
-		    ;; exists in the same size and weight as the current
-		    ;; font (scalable fonts exist in every size).  Only the
-		    ;; current font is marked as selected.
-		    ;;
-		    (setq f (aref item 0)
-			  entry (vassoc f (aref dcache 0)))
-		    (if (and (member weight (aref entry 1))
-			     (or (member size (aref entry 2))
-				 (and (not font-menu-ignore-scaled-fonts)
-				      (member 0 (aref entry 2)))))
-			(enable-menu-item item)
-		      (disable-menu-item item))
-		    (if (equal family f)
-			(select-toggle-menu-item item)
-		      (deselect-toggle-menu-item item))
-		    item)
-		(aref dcache 1)))
-      )))
+      (unless family
+	(throw 'menu '(["Cannot parse current font" ding nil])))
+      ;; Items on the Font menu are enabled iff that font exists in
+      ;; the same size and weight as the current font (scalable fonts
+      ;; exist in every size).  Only the current font is marked as
+      ;; selected.
+      (mapcar
+       (lambda (item)
+	 (setq f (aref item 0)
+	       entry (vassoc f (aref dcache 0)))
+	 (if (and (member weight (aref entry 1))
+		  (or (member size (aref entry 2))
+		      (and (not font-menu-ignore-scaled-fonts)
+			   (member 0 (aref entry 2)))))
+	     (enable-menu-item item)
+	   (disable-menu-item item))
+	 (if (string-equal family f)
+	     (select-toggle-menu-item item)
+	   (deselect-toggle-menu-item item))
+	 item)
+       (aref dcache 1)))))
 
 ;;;###autoload
 (defun font-menu-size-constructor (ignored)
-  ;; by Stig@hackvan.com
-  (if (not (eq 'x (device-type (selected-device))))
-      '(["Cannot parse current font" ding nil])
-    (let ((dcache (cdr (assq (selected-device) device-fonts-cache)))
-	  (name (font-menu-truename 'default))
-	  (case-fold-search t)
-	  family size			; parsed from current font
-	  entry				; font cache entry
-	  s)
-      (or dcache
-	  (setq dcache (reset-device-font-menus (selected-device))))
-      (if (not (string-match x-font-regexp name))
-	  ;; couldn't parse current font
-	  '(["Cannot parse current font" ding nil])
-	(setq size (string-to-number (match-string 6 name)))
-	(setq family (font-menu-family 'default))
-	(setq entry (vassoc family (aref dcache 0)))
-	(mapcar
-         (lambda (item)
-           ;;
-           ;; Items on the Size menu are enabled iff current font has
-           ;; that size.  Only the size of the current font is
-           ;; selected.  (If the current font comes in size 0, it is
-           ;; scalable, and thus has every size.)
-           ;;
-           (setq s (nth 3 (aref item 1)))
-           (if (or (member s (aref entry 2))
-                   (and (not font-menu-ignore-scaled-fonts)
-                        (member 0 (aref entry 2))))
-               (enable-menu-item item)
-             (disable-menu-item item))
-           (if (eq size s)
-               (select-toggle-menu-item item)
-             (deselect-toggle-menu-item item))
-           item)
-         (aref dcache 2)))
-      )))
+  (catch 'menu
+    (unless (eq 'x (device-type (selected-device)))
+      (throw 'menu '(["Cannot parse current font" ding nil])))
+    (let* ((dcache (device-fonts-cache))
+	   (font-data (font-menu-font-data 'default dcache))
+	   (entry  (aref font-data 0))
+	   (family (aref font-data 1))
+	   (size   (aref font-data 2))
+	   ;;(weight (aref font-data 3))
+	   s)
+      (unless family
+	(throw 'menu '(["Cannot parse current font" ding nil])))
+      ;; Items on the Size menu are enabled iff current font has
+      ;; that size.  Only the size of the current font is selected.
+      ;; (If the current font comes in size 0, it is scalable, and
+      ;; thus has every size.)
+      (mapcar
+       (lambda (item)
+	 (setq s (nth 3 (aref item 1)))
+	 (if (or (member s (aref entry 2))
+		 (and (not font-menu-ignore-scaled-fonts)
+		      (member 0 (aref entry 2))))
+	     (enable-menu-item item)
+	   (disable-menu-item item))
+	 (if (eq size s)
+	     (select-toggle-menu-item item)
+	   (deselect-toggle-menu-item item))
+	 item)
+       (aref dcache 2)))))
 
 ;;;###autoload
 (defun font-menu-weight-constructor (ignored)
-  ;; by Stig@hackvan.com
-  (if (not (eq 'x (device-type (selected-device))))
-      '(["Cannot parse current font" ding nil])
-    (let ((dcache (cdr (assq (selected-device) device-fonts-cache)))
-	  (name (font-menu-truename 'default))
-	  (case-fold-search t)
-	  family weight			; parsed from current font
-	  entry				; font cache entry
-	  w)
-      (or dcache
-	  (setq dcache (reset-device-font-menus (selected-device))))
-      (if (not (string-match x-font-regexp name))
-	  ;; couldn't parse current font
-	  '(["Cannot parse current font" ding nil])
-	(setq weight (capitalize (match-string 1 name)))
-	(setq family (font-menu-family 'default))
-	(setq entry (vassoc family (aref dcache 0)))
-	(mapcar #'(lambda (item)
-		    ;; Items on the Weight menu are enabled iff current font
-		    ;; has that weight.  Only the weight of the current font
-		    ;; is selected.
-		    (setq w (aref item 0))
-		    (if (member w (aref entry 1))
-			(enable-menu-item item)
-		      (disable-menu-item item))
-		    (if (equal weight w)
-			(select-toggle-menu-item item)
-		      (deselect-toggle-menu-item item))
-		    item)
-		(aref dcache 3)))
-      )))
+  (catch 'menu
+    (unless (eq 'x (device-type (selected-device)))
+      (throw 'menu '(["Cannot parse current font" ding nil])))
+    (let* ((dcache (device-fonts-cache))
+	   (font-data (font-menu-font-data 'default dcache))
+	   (entry  (aref font-data 0))
+	   (family (aref font-data 1))
+	   ;;(size   (aref font-data 2))
+	   (weight (aref font-data 3))
+	   w)
+      (unless family
+	(throw 'menu '(["Cannot parse current font" ding nil])))
+      ;; Items on the Weight menu are enabled iff current font
+      ;; has that weight.  Only the weight of the current font
+      ;; is selected.
+      (mapcar
+       (lambda (item)
+	 (setq w (aref item 0))
+	 (if (member w (aref entry 1))
+	     (enable-menu-item item)
+	   (disable-menu-item item))
+	 (if (string-equal weight w)
+	     (select-toggle-menu-item item)
+	   (deselect-toggle-menu-item item))
+	 item)
+       (aref dcache 3)))))
 
 
 ;;; Changing font sizes
@@ -450,35 +456,31 @@
   ;; This is what gets run when an item is selected from any of the three
   ;; fonts menus.  It needs to be rather clever.
   ;; (size is measured in 10ths of points.)
-  (let ((faces (delq 'default (face-list)))
-	(default-name (font-menu-truename 'default))
-	(case-fold-search t)
-	new-default-face-font
-	from-family from-weight from-size)
-    ;;
-    ;; First, parse out the default face's font.
-    ;;
-    (setq from-family (font-menu-family 'default))
-    (or (string-match x-font-regexp default-name)
-	(signal 'error (list "couldn't parse font name" default-name)))
-    (setq from-weight (capitalize (match-string 1 default-name)))
-    (setq from-size (match-string 6 default-name))
+  (let* ((dcache (device-fonts-cache))
+	 (font-data (font-menu-font-data 'default dcache))
+	 (from-family (aref font-data 1))
+	 (from-size   (aref font-data 2))
+	 (from-weight (aref font-data 3))
+	 (from-slant  (aref font-data 4))
+	 new-default-face-font)
+    (unless from-family
+      (signal 'error '("couldn't parse font name for default face")))
     (setq new-default-face-font
 	  (font-menu-load-font (or family from-family)
 			       (or weight from-weight)
 			       (or size   from-size)
-			       default-name))
-    (while faces
-      (cond ((face-font-instance (car faces))
-	     (message "Changing font of `%s'..." (car faces))
-	     (condition-case c
-		 (font-menu-change-face (car faces)
-					from-family from-weight from-size
-					family weight size)
-	       (error
-		(display-error c nil)
-		(sit-for 1)))))
-      (setq faces (cdr faces)))
+			       from-slant
+			       font-menu-preferred-resolution))
+    (dolist (face (delq 'default (face-list)))
+      (when (face-font-instance face)
+	(message "Changing font of `%s'..." face)
+	(condition-case c
+	    (font-menu-change-face face
+				   from-family from-weight from-size
+				   family      weight      size)
+	  (error
+	   (display-error c nil)
+	   (sit-for 1)))))
     ;; Set the default face's font after hacking the other faces, so that
     ;; the frame size doesn't change until we are all done.
 
@@ -492,146 +494,58 @@
 			      from-family from-weight from-size
 			      to-family   to-weight   to-size)
   (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face)))
-  (let* ((name (font-menu-truename face))
-	 (case-fold-search t)
-	 face-family
-	 face-weight
-	 face-size)
-    ;; First, parse out the face's font.
-    (or (string-match x-font-regexp-foundry-and-family name)
-	(signal 'error (list "couldn't parse font name" name)))
-    (setq face-family (capitalize (match-string 1 name)))
-    (or (string-match x-font-regexp name)
-	(signal 'error (list "couldn't parse font name" name)))
-    (setq face-weight (match-string 1 name))
-    (setq face-size (match-string 6 name))
+  (let* ((dcache (device-fonts-cache))
+	 (font-data (font-menu-font-data face dcache))
+	 (face-family (aref font-data 1))
+	 (face-size   (aref font-data 2))
+	 (face-weight (aref font-data 3))
+	 (face-slant  (aref font-data 4)))
+
+    (or face-family
+	(signal 'error (list "couldn't parse font name for face" face)))
 
     ;; If this face matches the old default face in the attribute we
     ;; are changing, then change it to the new attribute along that
     ;; dimension.  Also, the face must have its own global attribute.
     ;; If its value is inherited, we don't touch it.  If any of this
     ;; is not true, we leave it alone.
-    (if (and (face-font face 'global)
-	     (cond 
-	      (to-family (equal face-family from-family))
-	      (to-weight (equal face-weight from-weight))
-	      (to-size   (equal face-size from-size))))
-	(set-face-font face
-		       (font-menu-load-font (or to-family face-family)
-					    (or to-weight face-weight)
-					    (or to-size   face-size)
-					    name)
-		       (and font-menu-this-frame-only-p
-			    (selected-frame)))
-      nil)))
-
-
-(defun font-menu-load-font (family weight size from-font)
-  (and (numberp size) (setq size (int-to-string size)))
-  (let ((case-fold-search t)
-	slant other-slant
-	registry encoding resx resy)
-    (or (string-match x-font-regexp-registry-and-encoding from-font)
-	(signal 'error (list "couldn't parse font name" from-font)))
-    (setq registry (match-string 1 from-font)
-	  encoding (match-string 2 from-font))
+    (when (and (face-font face 'global)
+	       (cond 
+		(to-family (string-equal face-family from-family))
+		(to-weight (string-equal face-weight from-weight))
+		(to-size   (=            face-size   from-size))))
+      (set-face-font face
+		     (font-menu-load-font (or to-family face-family)
+					  (or to-weight face-weight)
+					  (or to-size   face-size)
+					  face-slant
+					  font-menu-preferred-resolution)
+		     (and font-menu-this-frame-only-p
+			  (selected-frame))))))
 
-    (or (string-match x-font-regexp from-font)
-	(signal 'error (list "couldn't parse font name" from-font)))
-    (setq slant (capitalize (match-string 2 from-font))
-	  resx  (match-string 7 from-font)
-	  resy  (match-string 8 from-font))
-    (setq other-slant (cond ((equal slant "O") "I") ; oh, bite me.
-			    ((equal slant "I") "O")
-			    (t nil)))
-    ;;
-    ;; Remember these values for the first font we switch away from
-    ;; (the original default font).
-    ;;
-    (or font-menu-preferred-resolution
-	(setq font-menu-preferred-resolution (cons resx resy)))
-    (or font-menu-preferred-registry
-	(setq font-menu-preferred-registry (cons registry encoding)))
-    ;;
-    ;; Now we know all the interesting properties of the font we want.
-    ;; Let's see what we can actually *get*.
-    ;;
-    (or ;; First try the default resolution, registry, and encoding.
-        (make-font-instance
-	 (concat "-*-" family "-" weight "-" slant "-*-*-*-" size
-		 "-" (car font-menu-preferred-resolution)
-		 "-" (cdr font-menu-preferred-resolution)
-		 "-*-*-"
-		 (car font-menu-preferred-registry) "-"
-		 (cdr font-menu-preferred-registry))
-	 nil t)
-	;; Then try that in the other slant.
-	(and other-slant
-	     (make-font-instance
-	      (concat "-*-" family "-" weight "-" other-slant
-		      "-*-*-*-" size
-		      "-" (car font-menu-preferred-resolution)
-		      "-" (cdr font-menu-preferred-resolution)
-		      "-*-*-"
-		      (car font-menu-preferred-registry) "-"
-		      (cdr font-menu-preferred-registry))
-	      nil t))
-	;; Then try the default resolution and registry, any encoding.
-	(make-font-instance
-	 (concat "-*-" family "-" weight "-" slant "-*-*-*-" size
-		 "-" (car font-menu-preferred-resolution)
-		 "-" (cdr font-menu-preferred-resolution)
-		 "-*-*-"
-		 (car font-menu-preferred-registry) "-*")
-	 nil t)
-	;; Then try that in the other slant.
-	(and other-slant
-	     (make-font-instance
-	      (concat "-*-" family "-" weight "-" other-slant
-		      "-*-*-*-" size
-		      "-" (car font-menu-preferred-resolution)
-		      "-" (cdr font-menu-preferred-resolution)
-		      "-*-*-"
-		      (car font-menu-preferred-registry) "-*")
-	      nil t))
-	;; Then try the default registry and encoding, any resolution.
-	(make-font-instance
-	 (concat "-*-" family "-" weight "-" slant "-*-*-*-" size
-		 "-*-*-*-*-"
-		 (car font-menu-preferred-registry) "-"
-		 (cdr font-menu-preferred-registry))
-	 nil t)
-	;; Then try that in the other slant.
-	(and other-slant
-	     (make-font-instance
-	      (concat "-*-" family "-" weight "-" other-slant
-		      "-*-*-*-" size
-		      "-*-*-*-*-"
-		      (car font-menu-preferred-registry) "-"
-		      (cdr font-menu-preferred-registry))
-	      nil t))
-	;; Then try the default registry, any encoding or resolution.
-	(make-font-instance
-	 (concat "-*-" family "-" weight "-" slant "-*-*-*-" size
-		 "-*-*-*-*-"
-		 (car font-menu-preferred-registry) "-*")
-	 nil t)
-	;; Then try that in the other slant.
-	(and other-slant
-	     (make-font-instance
-	      (concat "-*-" family "-" weight "-" slant "-*-*-*-"
-		      size "-*-*-*-*-"
-		      (car font-menu-preferred-registry) "-*")
-	      nil t))
-	;; Then try anything in the same slant, and error if it fails...
-	(and other-slant
-	     (make-font-instance
-	      (concat "-*-" family "-" weight "-" slant "-*-*-*-"
-		      size "-*-*-*-*-*-*")))
-	(make-font-instance
-	 (concat "-*-" family "-" weight "-" (or other-slant slant)
-		 "-*-*-*-" size "-*-*-*-*-*-*"))
-	)))
+(defun font-menu-load-font (family weight size slant resolution)
+  "Try to load a font with the requested properties.
+The weight, slant and resolution are only hints."
+  (when (integerp size) (setq size (int-to-string size)))
+  (let (font)
+    (catch 'got-font
+      (dolist (weight (list weight "*"))
+	(dolist (slant
+		 (cond ((string-equal slant "O") '("O" "I" "*"))
+		       ((string-equal slant "I") '("I" "O" "*"))
+		       ((string-equal slant "*") '("*"))
+		       (t (list slant "*"))))
+	  (dolist (resolution
+		   (if (string-equal resolution "*-*")
+		       (list resolution)
+		     (list resolution "*-*")))
+	    (when (setq font
+			(make-font-instance
+			 (concat  "-*-" family "-" weight "-" slant "-*-*-*-"
+				  size "-" resolution "-*-*-"
+				  font-menu-registry-encoding)
+			 nil t))
+	      (throw 'got-font font))))))))
 
 (defun flush-device-fonts-cache (device)
   ;; by Stig@hackvan.com