(syntax-description-table): New variable.

(describe-char-after): New function.
(describe-font-internal): Adjusted for the change of font-info.
(describe-font): Likewise.
(print-fontset): Rewritten for the new fontset implementation.
(describe-fontset): Include fontset alias names in completion.
(list-fontsets): Adjusted for the change of print-fontset.

1 files changed, 174 insertions, 82 deletions

diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el
index 78178093921..715c98607b8 100644
--- a/lisp/international/mule-diag.el
+++ b/lisp/international/mule-diag.el
@@ -454,6 +454,99 @@ detailed meanings of these arguments."
             (t
              (error "Invalid charset %s" charset))))))
 
+
+;;;###autoload
+(defun describe-char-after (&optional pos)
+  "Display information of in current buffer at position POS.
+The information includes character code, charset and code points in it,
+syntax, category, how the character is encoded in a file,
+which font is being used for displaying the character."
+  (interactive)
+  (or pos
+      (setq pos (point)))
+  (if (>= pos (point-max))
+      (error "No character at point"))
+  (let* ((char (char-after pos))
+         (charset (char-charset char))
+         (composition (find-composition (point) nil nil t))
+         (composed (if composition (buffer-substring (car composition)
+                                                     (nth 1 composition))))
+         item-list max-width)
+    (unless (eq charset 'unknown)
+      (setq item-list
+            `(("character"
+               ,(format "%s (0%o, %d, 0x%x)" (if (< char 256)
+                                                 (single-key-description char)
+                                               (char-to-string char))
+                        char char char))
+              ("charset"
+               ,(symbol-name charset)
+               ,(format "(%s)" (charset-description charset)))
+              ("code point"
+               ,(let ((split (split-char char)))
+                  (if (= (charset-dimension charset) 1)
+                      (format "%d" (nth 1 split))
+                    (format "%d %d" (nth 1 split) (nth 2 split)))))
+              ("syntax"
+               ,(nth 2 (assq (char-syntax char) syntax-code-table)))
+              ("category"
+               ,@(let ((category-set (char-category-set char)))
+                   (if (not category-set)
+                       '("-- none --")
+                     (mapcar #'(lambda (x) (format "%c:%s  "
+                                                   x (category-docstring x)))
+                             (category-set-mnemonics category-set)))))
+              ("buffer code"
+               ,(encoded-string-description
+                 (string-as-unibyte (char-to-string char)) nil))
+              ("file code"
+               ,@(let* ((coding buffer-file-coding-system)
+                        (encoded (encode-coding-char char coding)))
+                   (if encoded
+                       (list (encoded-string-description encoded coding)
+                             (format "(encoded by coding system %S)" coding))
+                     (list "not encodable by coding system"
+                           (symbol-name coding)))))
+              ,(if window-system
+                   (list "font" (char-font (point)))
+                 (list "terminal code"
+                       (let* ((coding (terminal-coding-system))
+                              (encoded (encode-coding-char char coding)))
+                         (if encoded
+                             (encoded-string-description encoded coding)
+                           "not encodable"))))))
+      (setq max-width (apply #'max (mapcar #'(lambda (x) (length (car x)))
+                                           item-list)))
+      (with-output-to-temp-buffer "*Help*"
+        (save-excursion
+          (set-buffer standard-output)
+          (let ((formatter (format "%%%ds:" max-width)))
+            (dolist (elt item-list)
+              (insert (format formatter (car elt)))
+              (dolist (clm (cdr elt))
+                (when (>= (+ (current-column) (string-width clm) 1)
+                          (frame-width))
+                  (insert "\n")
+                  (indent-to (1+ max-width)))
+                (insert " " clm))
+              (insert "\n")))
+          (when composition
+            (insert "\nComposed with the following characerter(s) "
+                    (mapconcat (lambda (x) (format "`%c'" x))
+                               (substring composed 1)
+                               ", ")
+                    " to form `" composed "'")
+            (if (nth 3 composition)
+                (insert ".\n")
+              (insert "\nby the rule ("
+                      (mapconcat (lambda (x)
+                                   (format (if (consp x) "%S" "?%c") x))
+                                 (nth 2 composition)
+                                 " ")
+                      ").\n"
+                      "See the variable `reference-point-alist' for the meaning of the rule.\n")))
+          )))))
+
 
 ;;; CODING-SYSTEM
 
@@ -893,13 +986,10 @@ but still contains full information about each coding system."
 (defun describe-font-internal (font-info &optional verbose)
   (print-list "name (opened by):" (aref font-info 0))
   (print-list "       full name:" (aref font-info 1))
-  (let ((charset (aref font-info 2)))
-    (print-list "   charset:"
-                (format "%s (%s)" charset (charset-description charset))))
-  (print-list "            size:" (format "%d" (aref font-info 3)))
-  (print-list "          height:" (format "%d" (aref font-info 4)))
-  (print-list " baseline-offset:" (format "%d" (aref font-info 5)))
-  (print-list "relative-compose:" (format "%d" (aref font-info 6))))
+  (print-list "            size:" (format "%2d" (aref font-info 2)))
+  (print-list "          height:" (format "%2d" (aref font-info 3)))
+  (print-list " baseline-offset:" (format "%2d" (aref font-info 4)))
+  (print-list "relative-compose:" (format "%2d" (aref font-info 5))))
 
 ;;;###autoload
 (defun describe-font (fontname)
@@ -911,7 +1001,7 @@ but still contains full information about each coding system."
     (setq fontname (cdr (assq 'font (frame-parameters))))
     (if (query-fontset fontname)
         (setq fontname
-              (nth 2 (assq 'ascii (aref (fontset-info fontname) 2))))))
+              (nth 1 (assq 'ascii (fontset-info fontname))))))
   (let ((font-info (font-info fontname)))
     (if (null font-info)
         (message "No matching font")
@@ -919,93 +1009,95 @@ but still contains full information about each coding system."
         (describe-font-internal font-info 'verbose)))))
 
 ;; Print information of FONTSET.  If optional arg PRINT-FONTS is
-;; non-nil, print also names of all fonts in FONTSET.  This function
-;; actually INSERT such information in the current buffer.
+;; non-nil, print also names of all opened fonts for FONTSET.  This
+;; function actually INSERT such information in the current buffer.
 (defun print-fontset (fontset &optional print-fonts)
-  (let* ((fontset-info (fontset-info fontset))
-         (size (aref fontset-info 0))
-         (height (aref fontset-info 1))
-         (fonts (and print-fonts (aref fontset-info 2)))
-         (xlfd-fields (x-decompose-font-name fontset))
-         style)
-    (if xlfd-fields
-        (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
-              (slant  (aref xlfd-fields xlfd-regexp-slant-subnum)))
-          (if (string-match "^bold$\\|^demibold$" weight)
-              (setq style (concat weight " "))
-            (setq style "medium "))
-          (cond ((string-match "^i$" slant)
-                 (setq style (concat style "italic")))
-                ((string-match "^o$" slant)
-                 (setq style (concat style "slant")))
-                ((string-match "^ri$" slant)
-                 (setq style (concat style "reverse italic")))
-                ((string-match "^ro$" slant)
-                 (setq style (concat style "reverse slant")))))
-      (setq style " ? "))
+  (let ((tail (cdr (fontset-info fontset)))
+        elt chars font-spec opened prev-charset charset from to)
     (beginning-of-line)
-    (insert fontset)
-    (indent-to 58)
-    (insert (if (and size (> size 0)) (format "%2dx%d" size height) "  -"))
-    (indent-to 64)
-    (insert style "\n")
-    (when print-fonts
-      (insert "  O Charset / Fontname\n"
-              "  - ------------------\n")
-      (sort-charset-list)
-      (let ((l charset-list)
-            charset font-info opened fontname)
-        (while l
-          (setq charset (car l) l (cdr l))
-          (setq font-info (assq charset fonts))
-          (if (null font-info)
-              (setq opened ?? fontname "not specified")
-            (if (nth 2 font-info)
-                (if (stringp (nth 2 font-info))
-                    (setq opened ?o fontname (nth 2 font-info))
-                  (setq opened ?- fontname (nth 1 font-info)))
-              (setq opened ?x fontname (nth 1 font-info))))
-          (insert (format "  %c %s\n    %s\n"
-                          opened charset fontname)))))))
+    (insert "Fontset: " fontset "\n")
+    (insert "CHARSET or CHAR RANGE")
+    (indent-to 25)
+    (insert "FONT NAME\n")
+    (insert "---------------------")
+    (indent-to 25)
+    (insert "---------")
+    (insert "\n")
+    (while tail
+      (setq elt (car tail) tail (cdr tail))
+      (setq chars (car elt) font-spec (car (cdr elt)) opened (cdr (cdr elt)))
+      (if (symbolp chars)
+          (setq charset chars from nil to nil)
+        (if (integerp chars)
+            (setq charset (char-charset chars) from chars to chars)
+          (setq charset (char-charset (car chars))
+                from (car chars) to (cdr chars))))
+      (unless (eq charset prev-charset)
+        (insert (symbol-name charset))
+        (if from
+            (insert "\n")))
+      (when from
+        (let ((split (split-char from)))
+          (if (and (= (charset-dimension charset) 2)
+                   (= (nth 2 split) 0))
+              (setq from
+                    (make-char charset (nth 1 split)
+                               (if (= (charset-chars charset) 94) 33 32))))
+          (insert "  " from))
+        (when (/= from to)
+          (insert "-")
+          (let ((split (split-char to)))
+            (if (and (= (charset-dimension charset) 2)
+                     (= (nth 2 split) 0))
+                (setq to
+                      (make-char charset (nth 1 split)
+                                 (if (= (charset-chars charset) 94) 126 127))))
+            (insert to))))
+      (indent-to 25)
+      (if (stringp font-spec)
+          (insert font-spec)
+        (if (car font-spec)
+            (if (string-match "-" (car font-spec))
+                (insert "-" (car font-spec) "-")
+              (insert "-*-" (car font-spec) "-"))
+          (insert "-*-"))
+        (if (cdr font-spec)
+            (if (string-match "-" (cdr font-spec))
+                (insert (cdr font-spec))
+              (insert (cdr font-spec) "-*"))
+          (insert "*")))
+      (insert "\n")
+      (when print-fonts
+        (while opened
+          (indent-to 5)
+          (insert "[" (car opened) "]\n")
+          (setq opened (cdr opened))))
+      (setq prev-charset charset)
+      )))
 
 ;;;###autoload
 (defun describe-fontset (fontset)
   "Display information of FONTSET.
-This shows the name, size, and style of FONTSET, and the list of fonts
-contained in FONTSET.
-
-The column WDxHT contains width and height (pixels) of each fontset
-\(i.e. those of ASCII font in the fontset).  The letter `-' in this
-column means that the corresponding fontset is not yet used in any
-frame.
-
-The O column for each font contains one of the following letters:
- o -- font already opened
- - -- font not yet opened
- x -- font can't be opened
- ? -- no font specified
-
-The Charset column for each font contains a name of character set
-displayed (for this fontset) using that font."
+This shows which font is used for which character(s)."
   (interactive
    (if (not (and window-system (fboundp 'fontset-list)))
        (error "No fontsets being used")
-     (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list)))
+     (let ((fontset-list (append
+                          (mapcar '(lambda (x) (list x)) (fontset-list))
+                          (mapcar '(lambda (x) (list (cdr x)))
+                                  fontset-alias-alist)))
            (completion-ignore-case t))
        (list (completing-read
               "Fontset (default, used by the current frame): "
               fontset-list nil t)))))
   (if (= (length fontset) 0)
       (setq fontset (cdr (assq 'font (frame-parameters)))))
-  (if (not (query-fontset fontset))
+  (if (not (setq fontset (query-fontset fontset)))
       (error "Current frame is using font, not fontset"))
-  (let ((fontset-info (fontset-info fontset)))
-    (with-output-to-temp-buffer "*Help*"
-      (save-excursion
-        (set-buffer standard-output)
-        (insert "Fontset-Name\t\t\t\t\t\t  WDxHT Style\n")
-        (insert "------------\t\t\t\t\t\t  ----- -----\n")
-        (print-fontset fontset t)))))
+  (with-output-to-temp-buffer "*Help*"
+    (save-excursion
+      (set-buffer standard-output)
+      (print-fontset fontset t))))
 
 ;;;###autoload
 (defun list-fontsets (arg)
@@ -1020,15 +1112,15 @@ see the function `describe-fontset' for the format of the list."
       (save-excursion
         ;; This code is duplicated near the end of mule-diag.
         (set-buffer standard-output)
-        (insert "Fontset-Name\t\t\t\t\t\t  WDxHT Style\n")
-        (insert "------------\t\t\t\t\t\t  ----- -----\n")
         (let ((fontsets
                (sort (fontset-list)
                      (function (lambda (x y)
                                  (string< (fontset-plain-name x)
                                           (fontset-plain-name y)))))))
           (while fontsets
-            (print-fontset (car fontsets) arg)
+            (if arg
+                (print-fontset (car fontsets) nil)
+              (insert "Fontset: " (car fontsets) "\n"))
             (setq fontsets (cdr fontsets))))))))
 
 ;;;###autoload