From afd31f9e62e551a3f286d1d581a56ef1de33ee94 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Sat, 17 Oct 2020 20:55:04 +0200 Subject: [PATCH] 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 8d0d9c42704..2996581f943 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 05b0814c475..704b89eeecc 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); -- 2.39.2