* src/doc.c (Fsubstitute_command_keys_old): Remove.
(syms_of_doc): Remove defsubr for Fsubstitute_command_keys_old.
* src/keymap.c (describe_map, describe_map_tree)
(describe_map_compare, describe_map_elt): Remove.
* src/keymap.h: Remove 'describe_map_tree'.
* test/lisp/help-tests.el (with-substitute-command-keys-test)
(help-tests-substitute-command-keys/compare)
(help-tests-substitute-command-keys/compare-all):
Don't test the C version of 'substitute-command-keys' removed
above.
}
}
-DEFUN ("substitute-command-keys-old", Fsubstitute_command_keys_old,
- Ssubstitute_command_keys_old, 1, 1, 0,
- doc: /* Substitute key descriptions for command names in STRING.
-Each substring of the form \\=\\[COMMAND] is replaced by either a
-keystroke sequence that invokes COMMAND, or "M-x COMMAND" if COMMAND
-is not on any keys.
-
-Each substring of the form \\=\\{MAPVAR} is replaced by a summary of
-the value of MAPVAR as a keymap. This summary is similar to the one
-produced by `describe-bindings'. The summary ends in two newlines
-\(used by the helper function `help-make-xrefs' to find the end of the
-summary).
-
-Each substring of the form \\=\\<MAPVAR> specifies the use of MAPVAR
-as the keymap for future \\=\\[COMMAND] substrings.
-
-Each grave accent \\=` is replaced by left quote, and each apostrophe \\='
-is replaced by right quote. Left and right quote characters are
-specified by `text-quoting-style'.
-
-\\=\\= quotes the following character and is discarded; thus, \\=\\=\\=\\= puts \\=\\=
-into the output, \\=\\=\\=\\[ puts \\=\\[ into the output, and \\=\\=\\=` puts \\=` into the
-output.
-
-Return the original STRING if no substitutions are made.
-Otherwise, return a new string (without any text properties). */)
- (Lisp_Object string)
-{
- char *buf;
- bool changed = false;
- bool nonquotes_changed = false;
- unsigned char *strp;
- char *bufp;
- ptrdiff_t idx;
- ptrdiff_t bsize;
- Lisp_Object tem;
- Lisp_Object keymap;
- unsigned char const *start;
- ptrdiff_t length, length_byte;
- Lisp_Object name;
- ptrdiff_t nchars;
-
- if (NILP (string))
- return Qnil;
-
- /* If STRING contains non-ASCII unibyte data, process its
- properly-encoded multibyte equivalent instead. This simplifies
- the implementation and is OK since substitute-command-keys is
- intended for use only on text strings. Keep STRING around, since
- it will be returned if no changes occur. */
- Lisp_Object str = Fstring_make_multibyte (string);
-
- enum text_quoting_style quoting_style = text_quoting_style ();
-
- nchars = 0;
-
- /* KEYMAP is either nil (which means search all the active keymaps)
- or a specified local map (which means search just that and the
- global map). If non-nil, it might come from Voverriding_local_map,
- or from a \\<mapname> construct in STRING itself.. */
- keymap = Voverriding_local_map;
-
- ptrdiff_t strbytes = SBYTES (str);
- bsize = strbytes;
-
- /* Fixed-size stack buffer. */
- char sbuf[MAX_ALLOCA];
-
- /* Heap-allocated buffer, if any. */
- char *abuf;
-
- /* Extra room for expansion due to replacing ‘\[]’ with ‘M-x ’. */
- enum { EXTRA_ROOM = sizeof "M-x " - sizeof "\\[]" };
-
- ptrdiff_t count = SPECPDL_INDEX ();
-
- if (bsize <= sizeof sbuf - EXTRA_ROOM)
- {
- abuf = NULL;
- buf = sbuf;
- bsize = sizeof sbuf;
- }
- else
- {
- buf = abuf = xpalloc (NULL, &bsize, EXTRA_ROOM, STRING_BYTES_BOUND, 1);
- record_unwind_protect_ptr (xfree, abuf);
- }
- bufp = buf;
-
- strp = SDATA (str);
- while (strp < SDATA (str) + strbytes)
- {
- unsigned char *close_bracket;
-
- if (strp[0] == '\\' && strp[1] == '='
- && strp + 2 < SDATA (str) + strbytes)
- {
- /* \= quotes the next character;
- thus, to put in \[ without its special meaning, use \=\[. */
- changed = nonquotes_changed = true;
- strp += 2;
- /* Fall through to copy one char. */
- }
- else if (strp[0] == '\\' && strp[1] == '['
- && (close_bracket
- = memchr (strp + 2, ']',
- SDATA (str) + strbytes - (strp + 2))))
- {
- bool follow_remap = 1;
-
- start = strp + 2;
- length_byte = close_bracket - start;
- idx = close_bracket + 1 - SDATA (str);
-
- name = Fintern (make_string ((char *) start, length_byte), Qnil);
-
- do_remap:
- tem = Fwhere_is_internal (name, keymap, Qt, Qnil, Qnil);
-
- if (VECTORP (tem) && ASIZE (tem) > 1
- && EQ (AREF (tem, 0), Qremap) && SYMBOLP (AREF (tem, 1))
- && follow_remap)
- {
- name = AREF (tem, 1);
- follow_remap = 0;
- goto do_remap;
- }
-
- /* Fwhere_is_internal can GC, so take relocation of string
- contents into account. */
- strp = SDATA (str) + idx;
- start = strp - length_byte - 1;
-
- if (NILP (tem)) /* but not on any keys */
- {
- memcpy (bufp, "M-x ", 4);
- bufp += 4;
- nchars += 4;
- length = multibyte_chars_in_text (start, length_byte);
- goto subst;
- }
- else
- { /* function is on a key */
- tem = Fkey_description (tem, Qnil);
- goto subst_string;
- }
- }
- /* \{foo} is replaced with a summary of the keymap (symbol-value foo).
- \<foo> just sets the keymap used for \[cmd]. */
- else if (strp[0] == '\\' && (strp[1] == '{' || strp[1] == '<')
- && (close_bracket
- = memchr (strp + 2, strp[1] == '{' ? '}' : '>',
- SDATA (str) + strbytes - (strp + 2))))
- {
- {
- bool generate_summary = strp[1] == '{';
- /* This is for computing the SHADOWS arg for describe_map_tree. */
- Lisp_Object active_maps = Fcurrent_active_maps (Qnil, Qnil);
- ptrdiff_t count = SPECPDL_INDEX ();
-
- start = strp + 2;
- length_byte = close_bracket - start;
- idx = close_bracket + 1 - SDATA (str);
-
- /* Get the value of the keymap in TEM, or nil if undefined.
- Do this while still in the user's current buffer
- in case it is a local variable. */
- name = Fintern (make_string ((char *) start, length_byte), Qnil);
- tem = Fboundp (name);
- if (! NILP (tem))
- {
- tem = Fsymbol_value (name);
- if (! NILP (tem))
- tem = get_keymap (tem, 0, 1);
- }
-
- /* Now switch to a temp buffer. */
- struct buffer *oldbuf = current_buffer;
- set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
- /* This is for an unusual case where some after-change
- function uses 'format' or 'prin1' or something else that
- will thrash Vprin1_to_string_buffer we are using. */
- specbind (Qinhibit_modification_hooks, Qt);
-
- if (NILP (tem))
- {
- name = Fsymbol_name (name);
- AUTO_STRING (msg_prefix, "\nUses keymap `");
- insert1 (Fsubstitute_command_keys_old (msg_prefix));
- insert_from_string (name, 0, 0,
- SCHARS (name),
- SBYTES (name), 1);
- AUTO_STRING (msg_suffix, "', which is not currently defined.\n");
- insert1 (Fsubstitute_command_keys_old (msg_suffix));
- if (!generate_summary)
- keymap = Qnil;
- }
- else if (!generate_summary)
- keymap = tem;
- else
- {
- /* Get the list of active keymaps that precede this one.
- If this one's not active, get nil. */
- Lisp_Object earlier_maps
- = Fcdr (Fmemq (tem, Freverse (active_maps)));
- describe_map_tree (tem, 1, Fnreverse (earlier_maps),
- Qnil, 0, 1, 0, 0, 1);
- }
- tem = Fbuffer_string ();
- Ferase_buffer ();
- set_buffer_internal (oldbuf);
- unbind_to (count, Qnil);
- }
-
- subst_string:
- /* Convert non-ASCII unibyte data to properly-encoded multibyte,
- for the same reason STRING was converted to STR. */
- tem = Fstring_make_multibyte (tem);
- start = SDATA (tem);
- length = SCHARS (tem);
- length_byte = SBYTES (tem);
- subst:
- nonquotes_changed = true;
- subst_quote:
- changed = true;
- {
- ptrdiff_t offset = bufp - buf;
- ptrdiff_t avail = bsize - offset;
- ptrdiff_t need = strbytes - idx;
- if (INT_ADD_WRAPV (need, length_byte + EXTRA_ROOM, &need))
- string_overflow ();
- if (avail < need)
- {
- abuf = xpalloc (abuf, &bsize, need - avail,
- STRING_BYTES_BOUND, 1);
- if (buf == sbuf)
- {
- record_unwind_protect_ptr (xfree, abuf);
- memcpy (abuf, sbuf, offset);
- }
- else
- set_unwind_protect_ptr (count, xfree, abuf);
- buf = abuf;
- bufp = buf + offset;
- }
- memcpy (bufp, start, length_byte);
- bufp += length_byte;
- nchars += length;
-
- /* Some of the previous code can GC, so take relocation of
- string contents into account. */
- strp = SDATA (str) + idx;
-
- continue;
- }
- }
- else if ((strp[0] == '`' || strp[0] == '\'')
- && quoting_style == CURVE_QUOTING_STYLE)
- {
- start = (unsigned char const *) (strp[0] == '`' ? uLSQM : uRSQM);
- length = 1;
- length_byte = sizeof uLSQM - 1;
- idx = strp - SDATA (str) + 1;
- goto subst_quote;
- }
- else if (strp[0] == '`' && quoting_style == STRAIGHT_QUOTING_STYLE)
- {
- *bufp++ = '\'';
- strp++;
- nchars++;
- changed = true;
- continue;
- }
-
- /* Copy one char. */
- do
- *bufp++ = *strp++;
- while (! CHAR_HEAD_P (*strp));
- nchars++;
- }
-
- if (changed) /* don't bother if nothing substituted */
- {
- tem = make_string_from_bytes (buf, nchars, bufp - buf);
- if (!nonquotes_changed)
- {
- /* Nothing has changed other than quoting, so copy the string’s
- text properties. FIXME: Text properties should survive other
- changes too; see bug#17052. */
- INTERVAL interval_copy = copy_intervals (string_intervals (string),
- 0, SCHARS (string));
- if (interval_copy)
- {
- set_interval_object (interval_copy, tem);
- set_string_intervals (tem, interval_copy);
- }
- }
- }
- else
- tem = string;
- return unbind_to (count, tem);
-}
\f
void
syms_of_doc (void)
defsubr (&Sdocumentation_property);
defsubr (&Ssnarf_documentation);
defsubr (&Sget_quoting_style);
- defsubr (&Ssubstitute_command_keys_old);
}
static Lisp_Object define_as_prefix (Lisp_Object, Lisp_Object);
static void describe_command (Lisp_Object, Lisp_Object);
static void describe_translation (Lisp_Object, Lisp_Object);
-static void describe_map (Lisp_Object, Lisp_Object,
- void (*) (Lisp_Object, Lisp_Object),
- bool, Lisp_Object, Lisp_Object *, bool, bool);
static void describe_vector (Lisp_Object, Lisp_Object, Lisp_Object,
void (*) (Lisp_Object, Lisp_Object), bool,
Lisp_Object, Lisp_Object, bool, bool);
return Qnil;
}
-/* Insert a description of the key bindings in STARTMAP,
- followed by those of all maps reachable through STARTMAP.
- If PARTIAL, 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.
- PREFIX, if non-nil, says mention only keys that start with PREFIX.
- TITLE, if not 0, is a string to insert at the beginning.
- TITLE should not end with a colon or a newline; we supply that.
- If NOMENU, then omit menu-bar commands.
-
- If TRANSL, the definitions are actually key translations
- so print strings and vectors differently.
-
- If ALWAYS_TITLE, print the title even if there are no maps
- to look through.
-
- If MENTION_SHADOW, 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'). */
-
-void
-describe_map_tree (Lisp_Object startmap, bool partial, Lisp_Object shadow,
- Lisp_Object prefix, const char *title, bool nomenu,
- bool transl, bool always_title, bool mention_shadow)
-{
- Lisp_Object maps, orig_maps, seen, sub_shadows;
- bool something = 0;
- const char *key_heading
- = "\
-key binding\n\
---- -------\n";
-
- orig_maps = maps = Faccessible_keymaps (startmap, prefix);
- seen = Qnil;
- sub_shadows = Qnil;
-
- if (nomenu)
- {
- Lisp_Object list;
-
- /* Delete from MAPS each element that is for the menu bar. */
- for (list = maps; CONSP (list); list = XCDR (list))
- {
- Lisp_Object elt, elt_prefix, tem;
-
- elt = XCAR (list);
- elt_prefix = Fcar (elt);
- if (ASIZE (elt_prefix) >= 1)
- {
- tem = Faref (elt_prefix, make_fixnum (0));
- if (EQ (tem, Qmenu_bar))
- maps = Fdelq (elt, maps);
- }
- }
- }
-
- if (!NILP (maps) || always_title)
- {
- if (title)
- {
- insert_string (title);
- if (!NILP (prefix))
- {
- insert_string (" Starting With ");
- insert1 (Fkey_description (prefix, Qnil));
- }
- insert_string (":\n");
- }
- insert_string (key_heading);
- something = 1;
- }
-
- for (; CONSP (maps); maps = XCDR (maps))
- {
- register Lisp_Object elt, elt_prefix, tail;
-
- elt = XCAR (maps);
- elt_prefix = Fcar (elt);
-
- sub_shadows = Flookup_key (shadow, elt_prefix, Qt);
- if (FIXNATP (sub_shadows))
- sub_shadows = Qnil;
- else if (!KEYMAPP (sub_shadows)
- && !NILP (sub_shadows)
- && !(CONSP (sub_shadows)
- && KEYMAPP (XCAR (sub_shadows))))
- /* If elt_prefix is bound to something that's not a keymap,
- it completely shadows this map, so don't
- describe this map at all. */
- goto skip;
-
- /* Maps we have already listed in this loop shadow this map. */
- for (tail = orig_maps; !EQ (tail, maps); tail = XCDR (tail))
- {
- Lisp_Object tem;
- tem = Fequal (Fcar (XCAR (tail)), elt_prefix);
- if (!NILP (tem))
- sub_shadows = Fcons (XCDR (XCAR (tail)), sub_shadows);
- }
-
- describe_map (Fcdr (elt), elt_prefix,
- transl ? describe_translation : describe_command,
- partial, sub_shadows, &seen, nomenu, mention_shadow);
-
- skip: ;
- }
-
- if (something)
- insert_string ("\n");
-}
-
static int previous_description_column;
static void
insert_string ("??\n");
}
-/* describe_map puts all the usable elements of a sparse keymap
- into an array of `struct describe_map_elt',
- then sorts them by the events. */
-
-struct describe_map_elt
-{
- Lisp_Object event;
- Lisp_Object definition;
- bool shadowed;
-};
-
-/* qsort comparison function for sorting `struct describe_map_elt' by
- the event field. */
-
-static int
-describe_map_compare (const void *aa, const void *bb)
-{
- const struct describe_map_elt *a = aa, *b = bb;
- if (FIXNUMP (a->event) && FIXNUMP (b->event))
- return ((XFIXNUM (a->event) > XFIXNUM (b->event))
- - (XFIXNUM (a->event) < XFIXNUM (b->event)));
- if (!FIXNUMP (a->event) && FIXNUMP (b->event))
- return 1;
- if (FIXNUMP (a->event) && !FIXNUMP (b->event))
- return -1;
- if (SYMBOLP (a->event) && SYMBOLP (b->event))
- /* Sort the keystroke names in the "natural" way, with (for
- instance) "<f2>" coming between "<f1>" and "<f11>". */
- return string_version_cmp (SYMBOL_NAME (a->event), SYMBOL_NAME (b->event));
- return 0;
-}
-
-/* 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. */
-
-static void
-describe_map (Lisp_Object map, Lisp_Object prefix,
- void (*elt_describer) (Lisp_Object, Lisp_Object),
- bool partial, Lisp_Object shadow,
- Lisp_Object *seen, bool nomenu, bool mention_shadow)
-{
- Lisp_Object tail, definition, event;
- Lisp_Object tem;
- Lisp_Object suppress;
- Lisp_Object kludge;
- bool first = 1;
-
- /* These accumulate the values from sparse keymap bindings,
- so we can sort them and handle them in order. */
- ptrdiff_t length_needed = 0;
- struct describe_map_elt *vect;
- ptrdiff_t slots_used = 0;
- ptrdiff_t i;
-
- suppress = Qnil;
-
- if (partial)
- suppress = intern ("suppress-keymap");
-
- /* This vector gets used to present single keys to Flookup_key. Since
- that is done once per keymap element, we don't want to cons up a
- fresh vector every time. */
- kludge = make_nil_vector (1);
- definition = Qnil;
-
- map = call1 (Qkeymap_canonicalize, map);
-
- for (tail = map; CONSP (tail); tail = XCDR (tail))
- length_needed++;
-
- USE_SAFE_ALLOCA;
- SAFE_NALLOCA (vect, 1, length_needed);
-
- for (tail = map; CONSP (tail); tail = XCDR (tail))
- {
- maybe_quit ();
-
- if (VECTORP (XCAR (tail))
- || CHAR_TABLE_P (XCAR (tail)))
- describe_vector (XCAR (tail),
- prefix, Qnil, elt_describer, partial, shadow, map,
- 1, mention_shadow);
- else if (CONSP (XCAR (tail)))
- {
- bool this_shadowed = 0;
-
- event = XCAR (XCAR (tail));
-
- /* Ignore bindings whose "prefix" are not really valid events.
- (We get these in the frames and buffers menu.) */
- if (!(SYMBOLP (event) || FIXNUMP (event)))
- continue;
-
- if (nomenu && EQ (event, Qmenu_bar))
- continue;
-
- definition = get_keyelt (XCDR (XCAR (tail)), 0);
-
- /* Don't show undefined commands or suppressed commands. */
- if (NILP (definition)) continue;
- if (SYMBOLP (definition) && partial)
- {
- tem = Fget (definition, suppress);
- if (!NILP (tem))
- continue;
- }
-
- /* Don't show a command that isn't really visible
- because a local definition of the same key shadows it. */
-
- ASET (kludge, 0, event);
- if (!NILP (shadow))
- {
- tem = shadow_lookup (shadow, kludge, Qt, 0);
- if (!NILP (tem))
- {
- /* If both bindings are keymaps, this key is a prefix key,
- so don't say it is shadowed. */
- if (KEYMAPP (definition) && KEYMAPP (tem))
- ;
- /* Avoid generating duplicate entries if the
- shadowed binding has the same definition. */
- else if (mention_shadow && !EQ (tem, definition))
- this_shadowed = 1;
- else
- continue;
- }
- }
-
- tem = Flookup_key (map, kludge, Qt);
- if (!EQ (tem, definition)) continue;
-
- vect[slots_used].event = event;
- vect[slots_used].definition = definition;
- vect[slots_used].shadowed = this_shadowed;
- slots_used++;
- }
- else if (EQ (XCAR (tail), Qkeymap))
- {
- /* The same keymap might be in the structure twice, if we're
- using an inherited keymap. So skip anything we've already
- encountered. */
- tem = Fassq (tail, *seen);
- if (CONSP (tem) && !NILP (Fequal (XCAR (tem), prefix)))
- break;
- *seen = Fcons (Fcons (tail, prefix), *seen);
- }
- }
-
- /* If we found some sparse map events, sort them. */
-
- qsort (vect, slots_used, sizeof (struct describe_map_elt),
- describe_map_compare);
-
- /* Now output them in sorted order. */
-
- for (i = 0; i < slots_used; i++)
- {
- Lisp_Object start, end;
-
- if (first)
- {
- previous_description_column = 0;
- insert ("\n", 1);
- first = 0;
- }
-
- ASET (kludge, 0, vect[i].event);
- start = vect[i].event;
- end = start;
-
- definition = vect[i].definition;
-
- /* Find consecutive chars that are identically defined. */
- if (FIXNUMP (vect[i].event))
- {
- while (i + 1 < slots_used
- && EQ (vect[i+1].event, make_fixnum (XFIXNUM (vect[i].event) + 1))
- && !NILP (Fequal (vect[i + 1].definition, definition))
- && vect[i].shadowed == vect[i + 1].shadowed)
- i++;
- end = vect[i].event;
- }
-
- /* Now START .. END is the range to describe next. */
-
- /* Insert the string to describe the event START. */
- insert1 (Fkey_description (kludge, prefix));
-
- if (!EQ (start, end))
- {
- insert (" .. ", 4);
-
- ASET (kludge, 0, end);
- /* Insert the string to describe the character END. */
- insert1 (Fkey_description (kludge, prefix));
- }
-
- /* Print a description of the definition of this character.
- elt_describer will take care of spacing out far enough
- for alignment purposes. */
- (*elt_describer) (vect[i].definition, Qnil);
-
- if (vect[i].shadowed)
- {
- ptrdiff_t pt = max (PT - 1, BEG);
-
- SET_PT (pt);
- insert_string ("\n (this binding is currently shadowed)");
- pt = min (PT + 1, Z);
- SET_PT (pt);
- }
- }
-
- SAFE_FREE ();
-}
-
static void
describe_vector_princ (Lisp_Object elt, Lisp_Object fun)
{
extern char *push_key_description (EMACS_INT, char *);
extern Lisp_Object access_keymap (Lisp_Object, Lisp_Object, bool, bool, bool);
extern Lisp_Object get_keymap (Lisp_Object, bool, bool);
-extern void describe_map_tree (Lisp_Object, bool, Lisp_Object, Lisp_Object,
- const char *, bool, bool, bool, bool);
extern ptrdiff_t current_minor_maps (Lisp_Object **, Lisp_Object **);
extern void initial_define_key (Lisp_Object, int, const char *);
extern void initial_define_lispy_key (Lisp_Object, const char *, const char *);
;;; substitute-command-keys
(defmacro with-substitute-command-keys-test (&rest body)
- `(cl-flet* ((should-be-same-as-c-version
- ;; TODO: Remove this when old C function is removed.
- (lambda (orig)
- (should (equal-including-properties
- (substitute-command-keys orig)
- (substitute-command-keys-old orig)))))
- (test
+ `(cl-flet* ((test
(lambda (orig result)
(should (equal-including-properties
(substitute-command-keys orig)
- result))
- (should-be-same-as-c-version orig)))
+ result))))
(test-re
(lambda (orig regexp)
(should (string-match (concat "^" regexp "$")
- (substitute-command-keys orig)))
- (should-be-same-as-c-version orig))))
+ (substitute-command-keys orig))))))
,@body))
(ert-deftest help-tests-substitute-command-keys/no-change ()
")))))
-;; TODO: This is a temporary test that should be removed together with
-;; substitute-command-keys-old.
-(ert-deftest help-tests-substitute-command-keys/compare ()
- (with-substitute-command-keys-test
- (with-temp-buffer
- (Info-mode)
- (outline-minor-mode)
- (test-re "\\{Info-mode-map}" ".*")))
- (with-substitute-command-keys-test
- (with-temp-buffer
- (c-mode)
- (outline-minor-mode)
- (test-re "\\{c-mode-map}" ".*"))))
-
-(ert-deftest help-tests-substitute-command-keys/compare-all ()
- (let (keymaps)
- (mapatoms (lambda (var)
- (when (keymapp var)
- (push var keymaps))))
- (dolist (keymap keymaps)
- (with-substitute-command-keys-test
- (test-re (concat "\\{" (symbol-name keymap) "}") ".*")))))
-
(provide 'help-tests)
;;; help-tests.el ends here
projects / emacs.git / commitdiff