Merge from emacs--devo--0

[bpt/emacs.git] / lisp / international / mule-diag.el

diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el
index a67b021..75bf45f 100644 (file)
--- a/lisp/international/mule-diag.el
+++ b/lisp/international/mule-diag.el
@@ -1,9 +1,9 @@
 ;;; mule-diag.el --- show diagnosis of multilingual environment (Mule)
 
 ;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006  Free Software Foundation, Inc.
+;;   2005, 2006, 2007  Free Software Foundation, Inc.
 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006
+;;   2005, 2006, 2007
 ;;   National Institute of Advanced Industrial Science and Technology (AIST)
 ;;   Registration Number H14PRO021
 ;; Copyright (C) 2003
@@ -16,7 +16,7 @@
 
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
 ;; any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
@@ -184,21 +184,19 @@ SORT-KEY should be `name' or `iso-spec' (default `name')."
 ##     CHARSET-SYMBOL-NAME,
 ##     DIMENSION (1 or 2)
 ##     CHARS (94 or 96)
-##     WIDTH (occupied column numbers: 1 or 2),
-##     DIRECTION (0:left-to-right, 1:right-to-left),
 ##     ISO-FINAL-CHAR (character code of ISO-2022's final character)
-##     ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR)
+##             -1 means that no final character is assigned.
 ##     DESCRIPTION (describing string of the charset)
 ")
   (let ((l charset-list)
        charset)
     (while l
       (setq charset (car l) l (cdr l))
-      (princ (format "%s:%d:%d:%d:%d:%s\n"
+      (princ (format "%s:%d:%d:%d:%s\n"
                     charset
                     (charset-dimension charset)
                     (charset-chars charset)
-                    (aref char-width-table (make-char charset))
+;;;                 (char-width (make-char charset))
 ;;;                 (charset-direction charset)
                     (charset-iso-final-char charset)
 ;;;                 (charset-iso-graphic-plane charset)
@@ -879,21 +877,36 @@ The font must be already used by Emacs."
       (let ((requested (car elt)))
        (if (stringp requested)
            (insert "\n    " requested)
-         (let ((family (aref requested 0))
-               (registry (aref requested 5)))
+         (let (family registry weight slant width adstyle)
+           (if (and (fboundp 'fontp) (fontp requested))
+               (setq family (font-get requested :family)
+                     registry (font-get requested :registry)
+                     weight (font-get requested :weight)
+                     slant (font-get requested :slant)
+                     width (font-get requested :width)
+                     adstyle (font-get requested :adstyle))
+             (setq family (aref requested 0)
+                   registry (aref requested 5)
+                   weight (aref requested 1)
+                   slant (aref requested 2)
+                   width (aref requested 3)
+                   adstyle (aref requested 4)))
            (if (not family)
                (setq family "*-*")
+             (if (symbolp family)
+                 (setq family (symbol-name family)))
              (or (string-match "-" family)
                  (setq family (concat "*-" family))))
-           (or (string-match "-" registry)
-               (= (aref registry (1- (length registry))) ?*)
-               (setq registry (concat registry "*")))
-           (insert "\n    -" family
-                   ?- (or (aref requested 1) ?*) ; weight
-                   ?- (or (aref requested 2) ?*) ; slant
-                   ?- (or (aref requested 3) ?*) ; width
-                   ?- (or (aref requested 4) ?*) ; adstyle
-                   "-*-*-*-*-*-*-" registry))))
+           (if (not registry)
+               (setq registry "*-*")
+             (if (symbolp registry)
+                 (setq registry (symbol-name registry)))
+             (or (string-match "-" registry)
+                 (= (aref registry (1- (length registry))) ?*)
+                 (setq registry (concat registry "*"))))
+           (insert (format"\n    -%s-%s-%s-%s-%s-*-*-*-*-*-*-%s"
+                          family (or weight "*") (or slant "*") (or width "*")
+                          (or adstyle "*") registry)))))
 
       ;; Insert opened font names (if any).
       (if (and (boundp 'print-opened) (symbol-value 'print-opened))