APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # Date 1346592700 -3600 # Node ID a81a739181dce8c6705bddd92047b210b95abb0c # Parent b0d40183ac7959bf1c6f5fe0df678f83b5c8b0ec Add command remapping, a more robust alternative to #'substitute-key-definition src/ChangeLog addition: 2012-09-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; * keymap.c: Add command remapping, a more robust equivalent to #'substitute-key-definition. * keymap.c (CHECK_REMAPPING_POSITION): New. * keymap.c (keymap_equal): Correct a comment here. * keymap.c (Fdefine_key): Document the command remapping syntax. * keymap.c (Fremap_command): New. * keymap.c (command_remapping): New. * keymap.c (Fcommand_remapping): New. * keymap.c (commands_remapped_to_mapper): New. * keymap.c (commands_remapped_to_traverser): New. * keymap.c (Fcommands_remapped_to): New. * keymap.c (get_relevant_keymaps): Take a new POSITION argument. * keymap.c (Fcurrent_keymaps, event_binding): Supply the new POSITION argument to get_relevant_keymaps. * keymap.c (Fkey_binding): Add new arguments, NO-REMAP and POSITION. * keymap.c (map_keymap_mapper): * keymap.c (Fwhere_is_internal): * keymap.c (where_is_to_char): * keymap.c (where_is_recursive_mapper): Don't expose the key remapping in these functions. This conflicts with GNU, but is more sane for our callers. Access to command remapping is with the functions #'command-remapping, #'commands-remapped-to, and #'remap-command, not with the general keymap functions, apart from the compatibility hack in #'define-key. * keymap.c (syms_of_keymap): * keymap.c (vars_of_keymap): * keymap.c (complex_vars_of_keymap): * lisp.h: New CHECK_COMMAND macro. man/ChangeLog addition: 2012-09-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; * lispref/keymaps.texi (Keymaps): * lispref/keymaps.texi (Changing Key Bindings): * lispref/keymaps.texi (Scanning Keymaps): * lispref/keymaps.texi (Remapping commands): * lispref/keymaps.texi (XEmacs): New. * lispref/keymaps.texi (Other Keymap Functions): Document the new command remapping functionality in this file. lisp/ChangeLog addition: 2012-09-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; * help.el (describe-function-1): Document any command remapping that has been done in this function. tests/ChangeLog addition: 2012-09-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; * automated/keymap-tests.el: Test the new command remapping functionality. diff -r b0d40183ac79 -r a81a739181dc lisp/ChangeLog --- a/lisp/ChangeLog Sun Aug 12 11:32:36 2012 +0100 +++ b/lisp/ChangeLog Sun Sep 02 14:31:40 2012 +0100 ＠＠ -2,6 +2,11 ＠＠ * XEmacs 21.5.32 "habanero" is released. +2012-09-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * help.el (describe-function-1): + Document any command remapping that has been done in this function. + 2012-05-14 Aidan Kehoe <kehoea(a)parhasard.net&gt; * byte-optimize.el (byte-optimize-letX): diff -r b0d40183ac79 -r a81a739181dc lisp/help.el --- a/lisp/help.el Sun Aug 12 11:32:36 2012 +0100 +++ b/lisp/help.el Sun Sep 02 14:31:40 2012 +0100 ＠＠ -1497,7 +1497,9 ＠＠ (global-tty-binding (where-is-internal function global-tty-map)) (global-window-system-binding - (where-is-internal function global-window-system-map))) + (where-is-internal function global-window-system-map)) + (command-remapping (command-remapping function)) + (commands-remapped-to (commands-remapped-to function))) (if (or global-binding global-tty-binding global-window-system-binding) (if (and (equal global-binding ＠＠ -1531,11 +1533,23 ＠＠ "\n%s\n -- generally (that is, unless\ overridden by TTY- or window-system-specific mappings)\n" - (mapconcat #'key-description - global-binding + (mapconcat #'key-description global-binding ", "))))) - (princ (substitute-command-keys - (format "\n\\[%s]" function)))))))))))) + (if command-remapping + (progn + (princ "Its keys are remapped to `") + (princ (symbol-name command-remapping)) + (princ "'.\n")) + (princ (substitute-command-keys + (format "\n\\[%s]" function)))) + (when commands-remapped-to + (if (cdr commands-remapped-to) + (princ (format "The following functions are \ +remapped to it:\n`%s'" (mapconcat #'prin1-to-string commands-remapped-to + "', `"))) + (princ (format "`%s' is remapped to it.\n" + (car + commands-remapped-to)))))))))))))) ;;; [Obnoxious, whining people who complain very LOUDLY on Usenet ;;; are binding this to keys.] diff -r b0d40183ac79 -r a81a739181dc man/ChangeLog --- a/man/ChangeLog Sun Aug 12 11:32:36 2012 +0100 +++ b/man/ChangeLog Sun Sep 02 14:31:40 2012 +0100 ＠＠ -8,6 +8,16 ＠＠ * XEmacs 21.5.32 "habanero" is released. +2012-09-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * lispref/keymaps.texi (Keymaps): + * lispref/keymaps.texi (Changing Key Bindings): + * lispref/keymaps.texi (Scanning Keymaps): + * lispref/keymaps.texi (Remapping commands): + * lispref/keymaps.texi (XEmacs): New. + * lispref/keymaps.texi (Other Keymap Functions): + Document the new command remapping functionality in this file. + 2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net&gt; * lispref/macros.texi (Expansion): diff -r b0d40183ac79 -r a81a739181dc man/lispref/keymaps.texi --- a/man/lispref/keymaps.texi Sun Aug 12 11:32:36 2012 +0100 +++ b/man/lispref/keymaps.texi Sun Sep 02 14:31:40 2012 +0100 ＠＠ -33,6 +33,8 ＠＠ * Changing Key Bindings:: Redefining a key in a keymap. * Key Binding Commands:: Interactive interfaces for redefining keys. * Scanning Keymaps:: Looking through all keymaps, for printing help. +* Remapping commands:: Specifying that one command should override + another. * Other Keymap Functions:: Miscellaneous keymap functions. ＠end menu ＠＠ -1168,7 +1170,8 ＠＠ ＠var{olddef} is replaced with ＠var{newdef} wherever it appears. Prefix keymaps are checked recursively. -The function returns ＠code{nil}. +The function returns ＠code{nil}. ＠pxref{Remapping commands} for a more +robust way of doing the same thing. For example, this redefines ＠kbd{C-x C-f}, if you do it in an XEmacs with standard bindings: ＠＠ -1581,6 +1584,37 ＠＠ displayed. ＠end deffn +＠node Remapping commands +＠section Remapping commands + +This section describes some functionality to allow commands to be +remapped, e.g. when providing workalike commands. + +＠defun remap-command keymap old new +This function ensures that in ＠var{keymap} any command lookups that +would previously have given ＠var{old} now give ＠var{new}. This is +equivalent to the following GNU-compatible code, which also works in +XEmacs: + +＠smallexample +(define-key KEYMAP [remap OLD] NEW) +＠end smallexample +＠end defun + +＠defun command-remapping command &optional position keymaps +If ＠var{command} has a remapping in ＠var{keymaps}, this function returns +that remapping. Otherwise it returns ＠var{nil}. ＠var{keymaps} defaults +to the currently active keymaps. ＠var{position} specifies the relevant buffer +position where keymaps should be searched for, and overrides +＠var{keymaps}. It can also be a marker or an event. +＠end defun + +＠defun commands-remapped-to command &optional position keymaps +This is the inverse operation of ＠code{command-remapping}; it returns a +list of the commands that will never be executed in ＠var{keymaps} +because ＠var{command} will be execute instead. +＠end defun + ＠node Other Keymap Functions ＠section Other Keymap Functions diff -r b0d40183ac79 -r a81a739181dc src/ChangeLog --- a/src/ChangeLog Sun Aug 12 11:32:36 2012 +0100 +++ b/src/ChangeLog Sun Sep 02 14:31:40 2012 +0100 ＠＠ -21,6 +21,41 ＠＠ * XEmacs 21.5.32 "habanero" is released. +2012-09-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * keymap.c: + Add command remapping, a more robust equivalent to + #'substitute-key-definition. + * keymap.c (CHECK_REMAPPING_POSITION): New. + * keymap.c (keymap_equal): Correct a comment here. + * keymap.c (Fdefine_key): Document the command remapping syntax. + * keymap.c (Fremap_command): New. + * keymap.c (command_remapping): New. + * keymap.c (Fcommand_remapping): New. + * keymap.c (commands_remapped_to_mapper): New. + * keymap.c (commands_remapped_to_traverser): New. + * keymap.c (Fcommands_remapped_to): New. + * keymap.c (get_relevant_keymaps): Take a new POSITION argument. + * keymap.c (Fcurrent_keymaps, event_binding): + Supply the new POSITION argument to get_relevant_keymaps. + * keymap.c (Fkey_binding): + Add new arguments, NO-REMAP and POSITION. + + * keymap.c (map_keymap_mapper): + * keymap.c (Fwhere_is_internal): + * keymap.c (where_is_to_char): + * keymap.c (where_is_recursive_mapper): + Don't expose the key remapping in these functions. This conflicts + with GNU, but is more sane for our callers. Access to command + remapping is with the functions #'command-remapping, + #'commands-remapped-to, and #'remap-command, not with the general + keymap functions, apart from the compatibility hack in #'define-key. + + * keymap.c (syms_of_keymap): + * keymap.c (vars_of_keymap): + * keymap.c (complex_vars_of_keymap): + * lisp.h: New CHECK_COMMAND macro. + 2012-05-14 Aidan Kehoe <kehoea(a)parhasard.net&gt; * minibuf.c (Ftest_completion): diff -r b0d40183ac79 -r a81a739181dc src/keymap.c --- a/src/keymap.c Sun Aug 12 11:32:36 2012 +0100 +++ b/src/keymap.c Sun Sep 02 14:31:40 2012 +0100 ＠＠ -188,9 +188,14 ＠＠ Lisp_Object Qmodeline_map; Lisp_Object Qtoolbar_map; +Lisp_Object Qremap; +Lisp_Object Qxemacs_command_remapping; /* Uninterned, so there's no conflict + with any key named remap. */ + EXFUN (Fkeymap_fullness, 1); EXFUN (Fset_keymap_name, 2); EXFUN (Fsingle_key_description, 1); +EXFUN (Fremap_command, 3); static void describe_command (Lisp_Object definition, Lisp_Object buffer); static void describe_map (Lisp_Object keymap, Lisp_Object elt_prefix, ＠＠ -200,6 +205,14 ＠＠ int mice_only_p, Lisp_Object buffer); static Lisp_Object keymap_submaps (Lisp_Object keymap); +static int get_relevant_keymaps (Lisp_Object, Lisp_Object, int, + Lisp_Object maps[]); +static Lisp_Object lookup_keys (Lisp_Object, int, Lisp_Object *, int); +static void map_keymap (Lisp_Object keymap_table, int sort_first, + void (*function) (const Lisp_Key_Data *key, + Lisp_Object binding, + void *fn_arg), + void *fn_arg); Lisp_Object Qcontrol, Qctrl, Qmeta, Qsuper, Qhyper, Qalt, Qshift; ＠＠ -220,17 +233,21 ＠＠ /* Kludge kludge kludge */ Lisp_Object QLFD, QTAB, QRET, QESC, QDEL, QSPC, QBS; +#define CHECK_REMAPPING_POSITION(object) do \ + { \ + if (!(NILP (object) || FIXNUMP (object) || MARKERP (object) \ + || EVENTP (object))) \ + { \ + wtaerror ("Not a valid POSITION", object); \ + } \ + } while (0) +  /************************************************************************/ /* The keymap Lisp object */ /************************************************************************/ -/* Keymaps are equal if Faces are equal if all of their display attributes are equal. We - don't compare names or doc-strings, because that would make equal - be eq. - - This isn't concerned with "unspecified" attributes, that's what - #'face-differs-from-default-p is for. */ +/* Keymaps are equal if all of their attributes are equal. */ static int keymap_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int UNUSED (foldcase)) ＠＠ -1826,6 +1843,12 ＠＠ `define-key' also accepts a number of abbreviations, aliases, and variants for convenience, compatibility, and internal use. +A key sequence can also be the vector [remap COMMAND]; this shadows any +bindings for COMMAND in KEYMAP, using DEF instead of COMMAND. See +`command-remapping' and `remap-command'. Specify [(remap) KEYSTROKE] if +your keyboard has a key with the name `remap' and you'd like to use it as a +prefix. + A keystroke may be represented by a key; this is treated as though it were a list containing that key as the only element. A keystroke may also be represented by an event object, as returned by the `next-command-event' and ＠＠ -1916,6 +1939,12 ＠＠ GCPRO3 (keymap, keys, def); + /* Allow access to any keys named remap, use our uninterned symbol. */ + if (2 == len && VECTORP (keys) && EQ (Qremap, XVECTOR_DATA (keys) [0])) + { + return Fremap_command (keymap, XVECTOR_DATA (keys) [1], def); + } + /* ASCII grunge. When the user defines a key which, in a strictly ASCII world, would be produced by two different keys (^J and linefeed, or ^H and backspace, ＠＠ -2036,7 +2065,206 ＠＠ } } } - + +DEFUN ("remap-command", Fremap_command, 3, 3, 0, /* +Ensure that NEW is called when previously OLD would be, in KEYMAP. + +NEW and OLD are both command symbols. KEYMAP is a keymap object. + +This is equivalent to `(define-key KEYMAP [remap OLD] NEW])'. See also +`substitute-key-definition', an older way of doing a similar thing. +*/ + (keymap, old, new_)) +{ + Lisp_Object cmd; + Lisp_Key_Data parsed; + + keymap = get_keymap (keymap, 1, 1); + CHECK_COMMAND (old); + CHECK_COMMAND (new_); + + define_key_parser (Qxemacs_command_remapping, &parsed); + cmd = keymap_lookup_1 (keymap, &parsed, 0); + if (NILP (cmd)) + { + cmd = Fmake_sparse_keymap (Qnil); + XKEYMAP (cmd)->name /* for debugging */ + = list2 (make_key_description (&parsed, 1), keymap); + keymap_store (keymap, &parsed, cmd); + } + + assert (!NILP (Fkeymapp (cmd))); + define_key_parser (old, &parsed); + keymap_store (cmd, &parsed, new_); + return new_; +} + +static Lisp_Object +command_remapping (Lisp_Object definition, int nmaps, Lisp_Object *maps) +{ + Lisp_Object remapping = Qnil; + Lisp_Object keys[2] = { Qxemacs_command_remapping, definition }; + int jj; + + for (jj = 0; jj < nmaps; jj++) + { + remapping = lookup_keys (maps[jj], countof (keys), keys, 0); + if (!NILP (remapping) && !FIXNUMP (remapping)) + { + return remapping; + } + } + + return Qnil; +} + +DEFUN ("command-remapping", Fcommand_remapping, 1, 3, 0, /* +Return the remapping for command COMMAND. + +Return nil if COMMAND is not remapped (or not a symbol). The remapping is +the command that is executed when some key sequence in the relevant keymaps +would normally execute COMMAND, but this has been intercepted by +`remap-command' or the [remap COMMAND] syntax for KEYS in `define-key'. + +If the optional argument POSITION is non-nil, it specifies an event, and the +remapping occurs in the keymaps associated with it. It can also be a number +or marker, in which case the keymap properties at the specified buffer +position instead of point are used. The KEYMAPS argument is ignored if +POSITION is non-nil. + +If the optional argument KEYMAPS is non-nil, it should be a list of +keymaps to search for command remapping. Otherwise, search for the +remapping in all currently active keymaps. +*/ + (command, position, keymaps)) +{ + Lisp_Object maps[100]; + Lisp_Object *gubbish = maps; + int nmaps, maps_count = countof (maps); + + CHECK_COMMAND (command); + CHECK_LIST (keymaps); + CHECK_REMAPPING_POSITION (position); + + /* Get keymaps as an array */ + if (NILP (keymaps) || !NILP (position)) + { + nmaps = get_relevant_keymaps (Qnil, position, maps_count, gubbish); + } + else + { + Elemcount jj = 0; + nmaps = XFIXNUM (Flength (keymaps)); + if (nmaps > maps_count) + { + gubbish = alloca_array (Lisp_Object, nmaps); + } + + { + LIST_LOOP_2 (elt, keymaps) + { + gubbish[jj++] = elt; + } + } + } + + if (nmaps > maps_count) + { + gubbish = alloca_array (Lisp_Object, nmaps); + nmaps = get_relevant_keymaps (Qnil, position, nmaps, gubbish); + } + + return command_remapping (command, nmaps, gubbish); +} + +struct commands_remapped_to_closure +{ + Lisp_Object command; + Lisp_Object result; +}; + +static void +commands_remapped_to_mapper (const Lisp_Key_Data *key, Lisp_Object binding, + void *data) +{ + struct commands_remapped_to_closure *crtc + = (struct commands_remapped_to_closure *) data; + + if (EQ (binding, crtc->command)) + { + crtc->result = Fcons (key->keysym, crtc->result); + } +} + +static Lisp_Object +commands_remapped_to_traverser (Lisp_Object k, void *arg) +{ + Lisp_Object remapping + = lookup_keys (k, 1, &Qxemacs_command_remapping, 0); + if (KEYMAPP (remapping)) + { + map_keymap (XKEYMAP (remapping)->table, 0, commands_remapped_to_mapper, + arg); + } + + return Qnil; +} + +DEFUN ("commands-remapped-to", Fcommands_remapped_to, 1, 3, 0, /* +Return a list of symbols for which COMMAND is their remapping in KEYMAPS. + +This is the inverse operation of `command-remapping', which see. +*/ + (command, keymaps, position)) +{ + Lisp_Object maps[100]; + Lisp_Object *gubbish = maps; + int nmaps, maps_count = countof (maps), jj; + struct commands_remapped_to_closure closure = { command, Qnil }; + struct gcpro gcpro1; + + CHECK_COMMAND (command); + CHECK_LIST (keymaps); + CHECK_REMAPPING_POSITION (position); + + /* Get keymaps as an array */ + if (NILP (keymaps) || !NILP (position)) + { + nmaps = get_relevant_keymaps (Qnil, position, maps_count, gubbish); + } + else + { + jj = 0; + nmaps = XFIXNUM (Flength (keymaps)); + if (nmaps > maps_count) + { + gubbish = alloca_array (Lisp_Object, nmaps); + } + + { + LIST_LOOP_2 (elt, keymaps) + { + gubbish[jj++] = elt; + } + } + } + + if (nmaps > maps_count) + { + gubbish = alloca_array (Lisp_Object, nmaps); + nmaps = get_relevant_keymaps (Qnil, position, nmaps, gubbish); + } + + GCPRO1 (closure.result); + + for (jj = 0; jj < nmaps; jj++) + { + traverse_keymaps (maps[jj], Qnil, commands_remapped_to_traverser, + (void *) (&closure)); + } + + RETURN_UNGCPRO (closure.result); +}  /************************************************************************/ /* Looking up keys in keymaps */ ＠＠ -2318,8 +2546,8 ＠＠ } static int -get_relevant_keymaps (Lisp_Object keys, - int max_maps, Lisp_Object maps[]) +get_relevant_keymaps (Lisp_Object keys, Lisp_Object position, int max_maps, + Lisp_Object maps[]) { /* This function can GC */ Lisp_Object terminal = Qnil; ＠＠ -2464,6 +2692,31 ＠＠ } #endif /* HAVE_WINDOW_SYSTEM */ + if (FIXNUMP (position)) + { + get_relevant_extent_keymaps (position, wrap_buffer (current_buffer), + Qnil, &closure); + } + else if (MARKERP (position) && !NILP (Fmarker_buffer (position))) + { + get_relevant_extent_keymaps (Fmarker_position (position), + Fmarker_buffer (position), + Qnil, &closure); + } + else if (EVENTP (position)) + { + Lisp_Object ew = Fevent_window (position); + + get_relevant_extent_keymaps (Fevent_point (position), + WINDOWP (ew) ? + Fwindow_buffer (Fevent_window (position)) +: Qnil, Qnil, &closure); + } + else + { + assert (NILP (position)); + } + if (CONSOLE_TTY_P (con)) relevant_map_push (Vglobal_tty_map, &closure); else ＠＠ -2580,23 +2833,34 ＠＠ int nmaps; GCPRO1 (event_or_keys); - nmaps = get_relevant_keymaps (event_or_keys, countof (maps), + nmaps = get_relevant_keymaps (event_or_keys, Qnil, countof (maps), gubbish); if (nmaps > countof (maps)) { gubbish = alloca_array (Lisp_Object, nmaps); - nmaps = get_relevant_keymaps (event_or_keys, nmaps, gubbish); + nmaps = get_relevant_keymaps (event_or_keys, Qnil, nmaps, gubbish); } UNGCPRO; return Flist (nmaps, gubbish); } -DEFUN ("key-binding", Fkey_binding, 1, 2, 0, /* +DEFUN ("key-binding", Fkey_binding, 1, 4, 0, /* Return the binding for command KEYS in current keymaps. + KEYS is a string, a vector of events, or a vector of key-description lists as described in the documentation for the `define-key' function. -The binding is probably a symbol with a function definition; see -the documentation for `lookup-key' for more information. + +NO-REMAP, if non-nil, specifies that any substitutions that have been +specified by `remap-command' (or, equivalently, by `(define-key KEYMAP +\[remap OLD] NEW)') should be ignored. + +POSITION, if non-nil, specifies a marker (and its associated buffer) or an +integer position (in the current buffer) to examine for relevant keymaps. +It can also be an event, in which case the associated buffer and position of +that event will be used. + +The binding is probably a symbol with a function definition; see the +documentation for `lookup-key' for more information. For key-presses, the order of keymaps searched is: - the `keymap' property of any extent(s) at point; ＠＠ -2650,7 +2914,7 ＠＠ generate and display a list of possible key sequences and bindings given the prefix so far generated. */ - (keys, accept_default)) + (keys, accept_default, no_remap, position)) { /* This function can GC */ int i; ＠＠ -2659,7 +2923,7 ＠＠ struct gcpro gcpro1, gcpro2; GCPRO2 (keys, accept_default); /* get_relevant_keymaps may autoload */ - nmaps = get_relevant_keymaps (keys, countof (maps), maps); + nmaps = get_relevant_keymaps (keys, position, countof (maps), maps); UNGCPRO; ＠＠ -2668,15 +2932,19 ＠＠ for (i = 0; i < nmaps; i++) { - Lisp_Object tem = Flookup_key (maps[i], keys, - accept_default); + Lisp_Object tem = Flookup_key (maps[i], keys, accept_default); + if (FIXNUMP (tem)) { /* Too long in some local map means don't look at global map */ return Qnil; } - else if (!NILP (tem)) - return tem; + + if (!NILP (tem) && NILP (no_remap) && SYMBOLP (tem)) + { + Lisp_Object remap = command_remapping (tem, nmaps, maps); + return NILP (remap) ? tem : remap; + } } return Qnil; } ＠＠ -2724,7 +2992,7 ＠＠ assert (EVENTP (event0)); - nmaps = get_relevant_keymaps (event0, countof (maps), maps); + nmaps = get_relevant_keymaps (event0, Qnil, countof (maps), maps); if (nmaps > countof (maps)) nmaps = countof (maps); return process_event_binding_result (lookup_events (event0, nmaps, maps, ＠＠ -3024,6 +3292,13 ＠＠ /* This function can GC */ Lisp_Object fn; fn = GET_LISP_FROM_VOID (function); + + /* Don't expose our remapping here. */ + if (EQ (KEY_DATA_KEYSYM (key), Qxemacs_command_remapping)) + { + return; + } + call2 (fn, make_key_description (key, 1), binding); } ＠＠ -3483,12 +3758,12 ＠＠ /* Get keymaps as an array */ if (NILP (keymaps)) { - nmaps = get_relevant_keymaps (event_or_keys, countof (maps), - gubbish); + nmaps = get_relevant_keymaps (event_or_keys, Qnil, countof (maps), + gubbish); if (nmaps > countof (maps)) { gubbish = alloca_array (Lisp_Object, nmaps); - nmaps = get_relevant_keymaps (event_or_keys, nmaps, gubbish); + nmaps = get_relevant_keymaps (event_or_keys, Qnil, nmaps, gubbish); } } else if (CONSP (keymaps)) ＠＠ -3518,6 +3793,11 ＠＠ } } + if (!NILP (command_remapping (definition, nmaps, gubbish))) + { + return Qnil; + } + return where_is_internal (definition, gubbish, nmaps, firstonly, 0); } ＠＠ -3536,11 +3816,11 ＠＠ int nmaps; /* Get keymaps as an array */ - nmaps = get_relevant_keymaps (Qnil, countof (maps), gubbish); + nmaps = get_relevant_keymaps (Qnil, Qnil, countof (maps), gubbish); if (nmaps > countof (maps)) { gubbish = alloca_array (Lisp_Object, nmaps); - nmaps = get_relevant_keymaps (Qnil, nmaps, gubbish); + nmaps = get_relevant_keymaps (Qnil, Qnil, nmaps, gubbish); } where_is_internal (definition, maps, nmaps, Qt, buffer); ＠＠ -3714,6 +3994,12 ＠＠ continue; } + /* Don't expose the command remapping to #'where-is-internal */ + if (EQ (key, Qxemacs_command_remapping)) + { + continue; + } + /* If the map is a "bucky" map, then add a bit to the modifiers_so_far list. Otherwise, add a new raw_key onto the end of keys_so_far. ＠＠ -4307,6 +4593,7 ＠＠ DEFSYMBOL (Qmodeline_map); DEFSYMBOL (Qtoolbar_map); + DEFSYMBOL (Qremap); DEFSUBR (Fkeymap_parents); DEFSUBR (Fset_keymap_parents); ＠＠ -4326,6 +4613,9 ＠＠ DEFSUBR (Fmap_keymap); DEFSUBR (Fevent_matches_key_specifier_p); DEFSUBR (Fdefine_key); + DEFSUBR (Fremap_command); + DEFSUBR (Fcommands_remapped_to); + DEFSUBR (Fcommand_remapping); DEFSUBR (Flookup_key); DEFSUBR (Fkey_binding); DEFSUBR (Fuse_global_map); ＠＠ -4455,6 +4745,10 ＠＠ Vsingle_space_string = make_string ((const Ibyte *) " ", 1); staticpro (&Vsingle_space_string); + + Qxemacs_command_remapping + = Fmake_symbol (build_ascstring ("xemacs-command-remapping")); + staticpro (&Qxemacs_command_remapping); } void diff -r b0d40183ac79 -r a81a739181dc src/lisp.h --- a/src/lisp.h Sun Aug 12 11:32:36 2012 +0100 +++ b/src/lisp.h Sun Sep 02 14:31:40 2012 +0100 ＠＠ -3521,6 +3521,13 ＠＠ while (NILP (Ffunctionp (fun))) \ signal_invalid_function_error (fun); \ } while (0) + +#define CHECK_COMMAND(x) do { \ + if (NILP (Fcommandp (x))) \ + { \ + dead_wrong_type_argument (Qcommandp, x); \ + } \ + } while (0)  /************************************************************************/ /* Parsing keyword arguments */ diff -r b0d40183ac79 -r a81a739181dc tests/ChangeLog --- a/tests/ChangeLog Sun Aug 12 11:32:36 2012 +0100 +++ b/tests/ChangeLog Sun Sep 02 14:31:40 2012 +0100 ＠＠ -2,6 +2,11 ＠＠ * XEmacs 21.5.32 "habanero" is released. +2012-09-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * automated/keymap-tests.el: + Test the new command remapping functionality. + 2012-05-12 Aidan Kehoe <kehoea(a)parhasard.net&gt; * automated/mule-tests.el: diff -r b0d40183ac79 -r a81a739181dc tests/automated/keymap-tests.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/automated/keymap-tests.el Sun Sep 02 14:31:40 2012 +0100 ＠＠ -0,0 +1,104 ＠＠ +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; Author: Aidan Kehoe <kehoea(a)parhasard.net&gt; +;; Maintainers: Aidan Kehoe <kehoea(a)parhasard.net&gt; +;; Created: 2012 +;; Keywords: tests + +;; This file is part of XEmacs. + +;; XEmacs 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 3 of the License, or (at your +;; option) any later version. + +;; XEmacs is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +;; for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>;. + +;;; Synched up with: Not in FSF. + +(let* ((map (make-keymap 'help-map-copy)) + (parent-map (make-keymap 'help-map-copy-parent)) + (help-map-copy t) + (minor-mode-map-alist (acons 'help-map-copy map minor-mode-map-alist))) + (set-keymap-parent map parent-map) + (loop for (keys def) on '((shift tab) help-prev-symbol tab + help-next-symbol c customize-variable V + find-variable-at-point q + help-mode-quit f find-function-at-point d + describe-function-at-point v + describe-variable-at-point i Info-elisp-ref F + find-function-at-point Q help-mode-bury button2 + help-mouse-find-source-or-track p + help-prev-section n help-next-section return + help-find-source-or-scroll-up) + by #'cddr + do (define-key map (vector keys) def)) + (loop for (keys def) on '(u view-scroll-some-lines-down % view-goto-percent + \2 digit-argument p view-goto-percent \? + view-search-backward - negative-argument k + view-scroll-lines-down backspace scroll-down G + view-last-windowful f scroll-up \5 + digit-argument s view-repeat-search \0 + digit-argument n view-repeat-search = what-line + \\ view-search-backward delete scroll-down \8 + digit-argument E view-file d + view-scroll-some-lines-up \3 digit-argument q + view-quit ! shell-command (control j) + view-scroll-lines-up (control m) + view-scroll-lines-up y view-scroll-lines-down + linefeed view-scroll-lines-up g view-goto-line + \6 digit-argument t toggle-truncate-lines C + view-cleanup-backspaces b scroll-down \1 + digit-argument P view-buffer return + view-scroll-lines-up | shell-command-on-region j + view-scroll-lines-up \9 digit-argument \' + register-to-point e view-scroll-lines-up \4 + digit-argument r recenter space scroll-up / + view-search-forward N view-buffer m + point-to-register h view-mode-describe \7 + digit-argument + find-function-at-point view-mode-describe) + by #'cddr + do (define-key parent-map (vector keys) def)) + (Assert (eq (key-binding [F]) 'find-function-at-point) + "checking normal key lookup works, F") + (Assert (eq (key-binding [c]) 'customize-variable) + "checking normal key lookup works, c") + (Assert (eq (key-binding [\2]) 'digit-argument) + "checking normal key parent lookup works, \\2") + (Assert (eq (key-binding [|]) 'shell-command-on-region) + "checking normal key parent lookup works, |") + (define-key map [remap find-function-at-point] #'find-file) + (Assert (eq (key-binding [F]) 'find-file) + "checking remapped key lookup works, F") + (Assert (eq (key-binding [f]) 'find-file) + "checking remapped key lookup works, f") + (Assert (eq (key-binding [\2]) 'digit-argument) + "checking normal key parent lookup works, \\2") + (Assert (eq (key-binding [|]) 'shell-command-on-region) + "checking normal key parent lookup works, |") + (Assert (eq (key-binding [find-function-at-point]) 'view-mode-describe) + "checking remapped function doesn't affect key name mapping") + (define-key parent-map [remap help-next-symbol] #'find-file) + (Assert (eq (key-binding [tab]) 'find-file) + "checking remapping in parent extends to child") + (Assert (equal (commands-remapped-to 'find-file) + '(help-next-symbol find-function-at-point)) + "checking #'commands-remapped-to is sane") + (Check-Error wrong-type-argument (commands-remapped-to pi)) + (Check-Error wrong-type-argument (commands-remapped-to 'find-file pi)) + (Check-Error wrong-type-argument (commands-remapped-to 'find-file nil pi)) + (Assert (eq (command-remapping 'find-function-at-point) 'find-file) + "checking #'command-remapping is sane") + (Check-Error wrong-type-argument (command-remapping pi)) + (Check-Error wrong-type-argument (command-remapping 'find-function-at-point + pi)) + (Check-Error wrong-type-argument (command-remapping 'find-function-at-point + nil pi))) + -- ‘Liston operated so fast that he once accidentally amputated an assistant’s fingers along with a patient’s leg, […] The patient and the assistant both died of sepsis, and a spectator reportedly died of shock, resulting in the only known procedure with a 300% mortality.’ (Atul Gawande, NEJM, 2012) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches