scratch/substitute-command-keys afd31f9 2/8: Translate describe_map_tree to Lisp

[Stefan Kangas]

branch: scratch/substitute-command-keys
commit afd31f9e62e551a3f286d1d581a56ef1de33ee94
Author: Stefan Kangas <stefan@marxist.se>
Commit: Stefan Kangas <stefan@marxist.se>

    Translate describe_map_tree to Lisp
    
    This is the second step in converting substitute-command-keys to Lisp.
    
    * lisp/help.el (describe-map-tree): New Lisp version of
    describe_map_tree.
    (substitute-command-keys): Update to use above function.
    * src/keymap.c (Fdescribe_map): New defun to expose describe_map to
    Lisp.
    * src/keymap.c (syms_of_keymap): New variable 'help--keymaps-seen'; a
    temporary kludge planned for removal.  New defsubr for Fdescribe_map.
---
 lisp/help.el | 90 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
 src/keymap.c | 30 ++++++++++++++++++--
 2 files changed, 116 insertions(+), 4 deletions(-)

diff --git a/lisp/help.el b/lisp/help.el
index 8d0d9c4..2996581 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1013,7 +1013,8 @@ Otherwise, return a new string (without any text 
properties)."
         (insert string)
         (goto-char (point-min))
         (while (< (point) (point-max))
-          (let ((orig-point (point))
+          (let ((standard-output (current-buffer))
+                (orig-point (point))
                 end-point active-maps
                 close generate-summary)
             (cond
@@ -1101,7 +1102,7 @@ Otherwise, return a new string (without any text 
properties)."
                     ;; If this one's not active, get nil.
                     (let ((earlier-maps (cdr (memq this-keymap (reverse 
active-maps)))))
                       (describe-map-tree this-keymap t (nreverse earlier-maps)
-                                         nil nil t nil nil))))))))
+                                         nil nil t nil nil t))))))))
              ;; 2. Handle quotes.
              ((and (eq (get-quoting-style) 'curve)
                    (or (and (= (following-char) ?\`)
@@ -1117,6 +1118,91 @@ Otherwise, return a new string (without any text 
properties)."
              (t (forward-char 1)))))
         (buffer-string)))))
 
+(defun describe-map-tree (startmap partial shadow prefix title no-menu
+                                   transl always-title mention-shadow)
+  "Insert a description of the key bindings in STARTMAP.
+This is followed by the key bindings of all maps reachable
+through STARTMAP.
+
+If PARTIAL is non-nil, omit certain uninteresting commands
+\(such as `undefined').
+
+If SHADOW is non-nil, it is a list of maps; don't mention keys
+which would be shadowed by any of them.
+
+If PREFIX is non-nil, mention only keys that start with PREFIX.
+
+If TITLE is non-nil, is a string to insert at the beginning.
+TITLE should not end with a colon or a newline; we supply that.
+
+If NOMENU is non-nil, then omit menu-bar commands.
+
+If TRANSL is non-nil, the definitions are actually key
+translations so print strings and vectors differently.
+
+If ALWAYS_TITLE is non-nil, print the title even if there are no
+maps to look through.
+
+If MENTION_SHADOW is non-nil, then when something is shadowed by
+SHADOW, don't omit it; instead, mention it but say it is
+shadowed.
+
+Any inserted text ends in two newlines (used by
+`help-make-xrefs')."
+  (let* ((amaps (accessible-keymaps startmap prefix))
+         (orig-maps (if no-menu
+                        (progn
+                          ;; Delete from MAPS each element that is for
+                          ;; the menu bar.
+                          (let* ((tail amaps)
+                                 result)
+                            (while tail
+                              (let ((elem (car tail)))
+                                (when (not (and (>= (length (car elem)) 1)
+                                                (eq (elt (car elem) 0) 
'menu-bar)))
+                                  (setq result (append result (list elem)))))
+                              (setq tail (cdr tail)))
+                            result))
+                      amaps))
+         (maps orig-maps)
+         (print-title (or maps always-title)))
+    ;; Print title.
+    (when print-title
+      (princ (concat (if title
+                         (concat title
+                                 (if prefix
+                                     (concat " Starting With "
+                                             (key-description prefix)))
+                                 ":\n"))
+                     "key             binding\n"
+                     "---             -------\n")))
+    ;; Describe key bindings.
+    (setq help--keymaps-seen nil)
+    (while (consp maps)
+      (let* ((elt (car maps))
+             (elt-prefix (car elt))
+             (sub-shadows (lookup-key shadow elt-prefix t)))
+        (when (if (natnump sub-shadows)
+                  (prog1 t (setq sub-shadows nil))
+                ;; Describe this map iff elt_prefix is bound to a
+                ;; keymap, since otherwise it completely shadows this
+                ;; map.
+                (or (keymapp sub-shadows)
+                    (null sub-shadows)
+                    (consp sub-shadows)
+                    (not (keymapp (car sub-shadows)))))
+          ;; Maps we have already listed in this loop shadow this map.
+          (let ((tail orig-maps))
+            (while (not (equal tail maps))
+              (when (equal (car (car tail)) elt-prefix)
+                (setq sub-shadows (cons (cdr (car tail)) sub-shadows)))
+              (setq tail (cdr tail))))
+          (describe-map (cdr elt) elt-prefix transl partial
+                        sub-shadows no-menu mention-shadow)))
+      (setq maps (cdr maps)))
+    (when print-title
+      (princ "\n"))))
+
 
 (declare-function x-display-pixel-height "xfns.c" (&optional terminal))
 (declare-function x-display-pixel-width "xfns.c" (&optional terminal))
diff --git a/src/keymap.c b/src/keymap.c
index 05b0814..704b89e 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -2915,7 +2915,7 @@ You type        Translation\n\
 
    Any inserted text ends in two newlines (used by `help-make-xrefs').  */
 
-DEFUN ("describe-map-tree", Fdescribe_map_tree, Sdescribe_map_tree, 1, 8, 0,
+DEFUN ("describe-map-tree-old", Fdescribe_map_tree_old, 
Sdescribe_map_tree_old, 1, 8, 0,
        doc: /* This is just temporary.  */)
   (Lisp_Object startmap, Lisp_Object partial, Lisp_Object shadow,
    Lisp_Object prefix, Lisp_Object title, Lisp_Object nomenu,
@@ -3131,6 +3131,27 @@ describe_map_compare (const void *aa, const void *bb)
   return 0;
 }
 
+DEFUN ("describe-map", Fdescribe_map, Sdescribe_map, 1, 7, 0,
+       doc: /* This is a temporary definition preparing the transition
+of this function to Lisp.  */)
+  (Lisp_Object map, Lisp_Object prefix,
+   Lisp_Object transl, Lisp_Object partial, Lisp_Object shadow,
+   Lisp_Object nomenu, Lisp_Object mention_shadow)
+{
+  ptrdiff_t count = SPECPDL_INDEX ();
+
+  bool b_transl = NILP(transl) ? false : true;
+  bool b_partial = NILP (partial) ? false : true;
+  bool b_nomenu = NILP (nomenu) ? false : true;
+  bool b_mention_shadow = NILP (mention_shadow) ? false : true;
+  describe_map (map, prefix,
+               b_transl ? describe_translation : describe_command,
+               b_partial, shadow, &Vhelp__keymaps_seen,
+               b_nomenu, b_mention_shadow);
+
+  return unbind_to (count, Qnil);
+}
+
 /* Describe the contents of map MAP, assuming that this map itself is
    reached by the sequence of prefix keys PREFIX (a string or vector).
    PARTIAL, SHADOW, NOMENU are as in `describe_map_tree' above.  */
@@ -3685,6 +3706,10 @@ exists, bindings using keys without modifiers (or only 
with meta) will
 be preferred.  */);
   Vwhere_is_preferred_modifier = Qnil;
   where_is_preferred_modifier = 0;
+  DEFVAR_LISP ("help--keymaps-seen", Vhelp__keymaps_seen,
+              doc: /* List of seen keymaps.
+This is used for internal purposes only.  */);
+  Vhelp__keymaps_seen = Qnil;
 
   DEFSYM (Qmenu_bar, "menu-bar");
   DEFSYM (Qmode_line, "mode-line");
@@ -3739,7 +3764,8 @@ be preferred.  */);
   defsubr (&Scurrent_active_maps);
   defsubr (&Saccessible_keymaps);
   defsubr (&Skey_description);
-  defsubr (&Sdescribe_map_tree);
+  defsubr (&Sdescribe_map_tree_old);
+  defsubr (&Sdescribe_map);
   defsubr (&Sdescribe_vector);
   defsubr (&Ssingle_key_description);
   defsubr (&Stext_char_description);