#include <config.h>
#include <stdio.h>
#if HAVE_ALLOCA_H
# include <alloca.h>
#endif
#include "lisp.h"
#include "commands.h"
#include "buffer.h"
#include "charset.h"
#include "keyboard.h"
#include "termhooks.h"
#include "blockinput.h"
#include "puresize.h"
#include "intervals.h"
#include "keymap.h"
#include "window.h"
#define DENSE_TABLE_SIZE (0200)
Lisp_Object current_global_map;
Lisp_Object global_map;
Lisp_Object meta_map;
Lisp_Object control_x_map;
Lisp_Object Vminibuffer_local_map;
Lisp_Object Vminibuffer_local_ns_map;
Lisp_Object Vminibuffer_local_completion_map;
Lisp_Object Vminibuffer_local_filename_completion_map;
Lisp_Object Vminibuffer_local_must_match_filename_map;
Lisp_Object Vminibuffer_local_must_match_map;
Lisp_Object Vminor_mode_map_alist;
Lisp_Object Vminor_mode_overriding_map_alist;
Lisp_Object Vemulation_mode_map_alists;
Lisp_Object Vfunction_key_map;
Lisp_Object Vkey_translation_map;
Lisp_Object Vdefine_key_rebound_commands;
Lisp_Object Qkeymapp, Qkeymap, Qnon_ascii, Qmenu_item, Qremap;
static Lisp_Object exclude_keys;
static Lisp_Object command_remapping_vector;
extern Lisp_Object meta_prefix_char;
extern Lisp_Object Voverriding_local_map;
static Lisp_Object where_is_cache;
static Lisp_Object where_is_cache_keymaps;
static Lisp_Object store_in_keymap P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
static void fix_submap_inheritance P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
static Lisp_Object define_as_prefix P_ ((Lisp_Object, Lisp_Object));
static void describe_command P_ ((Lisp_Object, Lisp_Object));
static void describe_translation P_ ((Lisp_Object, Lisp_Object));
static void describe_map P_ ((Lisp_Object, Lisp_Object,
void (*) P_ ((Lisp_Object, Lisp_Object)),
int, Lisp_Object, Lisp_Object*, int, int));
static void describe_vector P_ ((Lisp_Object, Lisp_Object, Lisp_Object,
void (*) (Lisp_Object, Lisp_Object), int,
Lisp_Object, Lisp_Object, int *,
int, int, int));
static void silly_event_symbol_error P_ ((Lisp_Object));
DEFUN ("make-keymap", Fmake_keymap, Smake_keymap, 0, 1, 0,
doc: )
(string)
Lisp_Object string;
{
Lisp_Object tail;
if (!NILP (string))
tail = Fcons (string, Qnil);
else
tail = Qnil;
return Fcons (Qkeymap,
Fcons (Fmake_char_table (Qkeymap, Qnil), tail));
}
DEFUN ("make-sparse-keymap", Fmake_sparse_keymap, Smake_sparse_keymap, 0, 1, 0,
doc: )
(string)
Lisp_Object string;
{
if (!NILP (string))
return Fcons (Qkeymap, Fcons (string, Qnil));
return Fcons (Qkeymap, Qnil);
}
void
initial_define_key (keymap, key, defname)
Lisp_Object keymap;
int key;
char *defname;
{
store_in_keymap (keymap, make_number (key), intern (defname));
}
void
initial_define_lispy_key (keymap, keyname, defname)
Lisp_Object keymap;
char *keyname;
char *defname;
{
store_in_keymap (keymap, intern (keyname), intern (defname));
}
DEFUN ("keymapp", Fkeymapp, Skeymapp, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
return (KEYMAPP (object) ? Qt : Qnil);
}
DEFUN ("keymap-prompt", Fkeymap_prompt, Skeymap_prompt, 1, 1, 0,
doc: )
(map)
Lisp_Object map;
{
map = get_keymap (map, 0, 0);
while (CONSP (map))
{
Lisp_Object tem = XCAR (map);
if (STRINGP (tem))
return tem;
map = XCDR (map);
}
return Qnil;
}
Lisp_Object
get_keymap (object, error, autoload)
Lisp_Object object;
int error, autoload;
{
Lisp_Object tem;
autoload_retry:
if (NILP (object))
goto end;
if (CONSP (object) && EQ (XCAR (object), Qkeymap))
return object;
tem = indirect_function (object);
if (CONSP (tem))
{
if (EQ (XCAR (tem), Qkeymap))
return tem;
if ((autoload || !error) && EQ (XCAR (tem), Qautoload)
&& SYMBOLP (object))
{
Lisp_Object tail;
tail = Fnth (make_number (4), tem);
if (EQ (tail, Qkeymap))
{
if (autoload)
{
struct gcpro gcpro1, gcpro2;
GCPRO2 (tem, object);
do_autoload (tem, object);
UNGCPRO;
goto autoload_retry;
}
else
return Qt;
}
}
}
end:
if (error)
wrong_type_argument (Qkeymapp, object);
return Qnil;
}
Lisp_Object
keymap_parent (keymap, autoload)
Lisp_Object keymap;
int autoload;
{
Lisp_Object list;
keymap = get_keymap (keymap, 1, autoload);
list = XCDR (keymap);
for (; CONSP (list); list = XCDR (list))
{
if (KEYMAPP (list))
return list;
}
return get_keymap (list, 0, autoload);
}
DEFUN ("keymap-parent", Fkeymap_parent, Skeymap_parent, 1, 1, 0,
doc: )
(keymap)
Lisp_Object keymap;
{
return keymap_parent (keymap, 1);
}
int
keymap_memberp (map, maps)
Lisp_Object map, maps;
{
if (NILP (map)) return 0;
while (KEYMAPP (maps) && !EQ (map, maps))
maps = keymap_parent (maps, 0);
return (EQ (map, maps));
}
DEFUN ("set-keymap-parent", Fset_keymap_parent, Sset_keymap_parent, 2, 2, 0,
doc: )
(keymap, parent)
Lisp_Object keymap, parent;
{
Lisp_Object list, prev;
struct gcpro gcpro1, gcpro2;
int i;
where_is_cache_keymaps = Qt;
GCPRO2 (keymap, parent);
keymap = get_keymap (keymap, 1, 1);
if (!NILP (parent))
{
parent = get_keymap (parent, 1, 1);
if (keymap_memberp (keymap, parent))
error ("Cyclic keymap inheritance");
}
prev = keymap;
while (1)
{
list = XCDR (prev);
if (!CONSP (list) || KEYMAPP (list))
{
if (EQ (XCDR (prev), parent))
RETURN_UNGCPRO (parent);
CHECK_IMPURE (prev);
XSETCDR (prev, parent);
break;
}
prev = list;
}
for (list = XCDR (keymap); CONSP (list); list = XCDR (list))
{
if (EQ (XCAR (list), Qkeymap))
break;
if (CONSP (XCAR (list))
&& CONSP (XCDR (XCAR (list))))
fix_submap_inheritance (keymap, XCAR (XCAR (list)),
XCDR (XCAR (list)));
if (VECTORP (XCAR (list)))
for (i = 0; i < XVECTOR (XCAR (list))->size; i++)
if (CONSP (XVECTOR (XCAR (list))->contents[i]))
fix_submap_inheritance (keymap, make_number (i),
XVECTOR (XCAR (list))->contents[i]);
if (CHAR_TABLE_P (XCAR (list)))
{
Lisp_Object indices[3];
map_char_table (fix_submap_inheritance, Qnil,
XCAR (list), XCAR (list),
keymap, 0, indices);
}
}
RETURN_UNGCPRO (parent);
}
static void
fix_submap_inheritance (map, event, submap)
Lisp_Object map, event, submap;
{
Lisp_Object map_parent, parent_entry;
submap = get_keymap (get_keyelt (submap, 0), 0, 0);
if (!CONSP (submap))
return;
map_parent = keymap_parent (map, 0);
if (!NILP (map_parent))
parent_entry =
get_keymap (access_keymap (map_parent, event, 0, 0, 0), 0, 0);
else
parent_entry = Qnil;
if (!CONSP (parent_entry))
return;
if (! EQ (parent_entry, submap))
{
Lisp_Object submap_parent;
submap_parent = submap;
while (1)
{
Lisp_Object tem;
tem = keymap_parent (submap_parent, 0);
if (KEYMAPP (tem))
{
if (keymap_memberp (tem, parent_entry))
return;
submap_parent = tem;
}
else
break;
}
Fset_keymap_parent (submap_parent, parent_entry);
}
}
Lisp_Object
access_keymap (map, idx, t_ok, noinherit, autoload)
Lisp_Object map;
Lisp_Object idx;
int t_ok;
int noinherit;
int autoload;
{
Lisp_Object val;
val = Qunbound;
idx = EVENT_HEAD (idx);
if (SYMBOLP (idx))
idx = reorder_modifiers (idx);
else if (INTEGERP (idx))
XSETFASTINT (idx, XINT (idx) & (CHAR_META | (CHAR_META - 1)));
if (INTEGERP (idx) && XUINT (idx) & meta_modifier)
{
struct gcpro gcpro1;
Lisp_Object meta_map;
GCPRO1 (map);
if (XINT (meta_prefix_char) & CHAR_META)
meta_prefix_char = make_number (27);
meta_map = get_keymap (access_keymap (map, meta_prefix_char,
t_ok, noinherit, autoload),
0, autoload);
UNGCPRO;
if (CONSP (meta_map))
{
map = meta_map;
idx = make_number (XUINT (idx) & ~meta_modifier);
}
else if (t_ok)
idx = Qt;
else
return Qnil;
}
{
Lisp_Object tail;
Lisp_Object t_binding = Qnil;
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
GCPRO4 (map, tail, idx, t_binding);
t_ok = t_ok ? 2 : 0;
for (tail = XCDR (map);
(CONSP (tail)
|| (tail = get_keymap (tail, 0, autoload), CONSP (tail)));
tail = XCDR (tail))
{
Lisp_Object binding;
binding = XCAR (tail);
if (SYMBOLP (binding))
{
if (noinherit && EQ (binding, Qkeymap))
RETURN_UNGCPRO (Qnil);
}
else if (CONSP (binding))
{
Lisp_Object key = XCAR (binding);
if (EQ (key, idx))
val = XCDR (binding);
else if (t_ok
&& INTEGERP (idx)
&& (XINT (idx) & CHAR_MODIFIER_MASK) == 0
&& INTEGERP (key)
&& (XINT (key) & CHAR_MODIFIER_MASK) == 0
&& !SINGLE_BYTE_CHAR_P (XINT (idx))
&& !SINGLE_BYTE_CHAR_P (XINT (key))
&& CHAR_VALID_P (XINT (key), 1)
&& !CHAR_VALID_P (XINT (key), 0)
&& (CHAR_CHARSET (XINT (key))
== CHAR_CHARSET (XINT (idx))))
{
t_binding = XCDR (binding);
t_ok = 0;
}
else if (t_ok > 1 && EQ (key, Qt))
{
t_binding = XCDR (binding);
t_ok = 1;
}
}
else if (VECTORP (binding))
{
if (NATNUMP (idx) && XFASTINT (idx) < ASIZE (binding))
val = AREF (binding, XFASTINT (idx));
}
else if (CHAR_TABLE_P (binding))
{
if (NATNUMP (idx) && (XFASTINT (idx) & CHAR_MODIFIER_MASK) == 0)
{
val = Faref (binding, idx);
if (NILP (val))
val = Qunbound;
}
}
if (!EQ (val, Qunbound))
{
if (EQ (val, Qt))
val = Qnil;
val = get_keyelt (val, autoload);
if (KEYMAPP (val))
fix_submap_inheritance (map, idx, val);
RETURN_UNGCPRO (val);
}
QUIT;
}
UNGCPRO;
return get_keyelt (t_binding, autoload);
}
}
static void
map_keymap_item (fun, args, key, val, data)
map_keymap_function_t fun;
Lisp_Object args, key, val;
void *data;
{
if (EQ (val, Qt))
val = Qnil;
(*fun) (key, val, args, data);
}
static void
map_keymap_char_table_item (args, key, val)
Lisp_Object args, key, val;
{
if (!NILP (val))
{
map_keymap_function_t fun = XSAVE_VALUE (XCAR (args))->pointer;
args = XCDR (args);
map_keymap_item (fun, XCDR (args), key, val,
XSAVE_VALUE (XCAR (args))->pointer);
}
}
void
map_keymap (map, fun, args, data, autoload)
map_keymap_function_t fun;
Lisp_Object map, args;
void *data;
int autoload;
{
struct gcpro gcpro1, gcpro2, gcpro3;
Lisp_Object tail;
tail = Qnil;
GCPRO3 (map, args, tail);
map = get_keymap (map, 1, autoload);
for (tail = (CONSP (map) && EQ (Qkeymap, XCAR (map))) ? XCDR (map) : map;
CONSP (tail) || (tail = get_keymap (tail, 0, autoload), CONSP (tail));
tail = XCDR (tail))
{
Lisp_Object binding = XCAR (tail);
if (CONSP (binding))
map_keymap_item (fun, args, XCAR (binding), XCDR (binding), data);
else if (VECTORP (binding))
{
int len = ASIZE (binding);
int c;
for (c = 0; c < len; c++)
{
Lisp_Object character;
XSETFASTINT (character, c);
map_keymap_item (fun, args, character, AREF (binding, c), data);
}
}
else if (CHAR_TABLE_P (binding))
{
Lisp_Object indices[3];
map_char_table (map_keymap_char_table_item, Qnil, binding, binding,
Fcons (make_save_value (fun, 0),
Fcons (make_save_value (data, 0),
args)),
0, indices);
}
}
UNGCPRO;
}
static void
map_keymap_call (key, val, fun, dummy)
Lisp_Object key, val, fun;
void *dummy;
{
call2 (fun, key, val);
}
DEFUN ("map-keymap", Fmap_keymap, Smap_keymap, 2, 3, 0,
doc: )
(function, keymap, sort_first)
Lisp_Object function, keymap, sort_first;
{
if (INTEGERP (function))
xsignal1 (Qinvalid_function, function);
if (! NILP (sort_first))
return call3 (intern ("map-keymap-internal"), function, keymap, Qt);
map_keymap (keymap, map_keymap_call, function, NULL, 1);
return Qnil;
}
Lisp_Object
get_keyelt (object, autoload)
Lisp_Object object;
int autoload;
{
while (1)
{
if (!(CONSP (object)))
return object;
else if (EQ (XCAR (object), Qkeymap) || EQ (XCAR (object), Qlambda))
return object;
else if (EQ (XCAR (object), Qmenu_item))
{
if (CONSP (XCDR (object)))
{
Lisp_Object tem;
object = XCDR (XCDR (object));
tem = object;
if (CONSP (object))
object = XCAR (object);
for (; CONSP (tem) && CONSP (XCDR (tem)); tem = XCDR (tem))
if (EQ (XCAR (tem), QCfilter) && autoload)
{
Lisp_Object filter;
filter = XCAR (XCDR (tem));
filter = list2 (filter, list2 (Qquote, object));
object = menu_item_eval_property (filter);
break;
}
}
else
return object;
}
else if (STRINGP (XCAR (object)))
{
object = XCDR (object);
if (CONSP (object) && STRINGP (XCAR (object)))
object = XCDR (object);
if (CONSP (object) && CONSP (XCAR (object)))
{
Lisp_Object carcar;
carcar = XCAR (XCAR (object));
if (NILP (carcar) || VECTORP (carcar))
object = XCDR (object);
}
}
else
{
struct gcpro gcpro1;
Lisp_Object map;
GCPRO1 (object);
map = get_keymap (Fcar_safe (object), 0, autoload);
UNGCPRO;
return (!CONSP (map) ? object
: access_keymap (map, Fcdr (object), 0, 0, autoload));
}
}
}
static Lisp_Object
store_in_keymap (keymap, idx, def)
Lisp_Object keymap;
register Lisp_Object idx;
Lisp_Object def;
{
where_is_cache = Qnil;
where_is_cache_keymaps = Qt;
if (CONSP (def) && PURE_P (def)
&& (EQ (XCAR (def), Qmenu_item) || STRINGP (XCAR (def))))
def = Fcons (XCAR (def), XCDR (def));
if (!CONSP (keymap) || !EQ (XCAR (keymap), Qkeymap))
error ("attempt to define a key in a non-keymap");
idx = EVENT_HEAD (idx);
if (SYMBOLP (idx))
idx = reorder_modifiers (idx);
else if (INTEGERP (idx))
XSETFASTINT (idx, XINT (idx) & (CHAR_META | (CHAR_META - 1)));
{
Lisp_Object tail;
Lisp_Object insertion_point;
insertion_point = keymap;
for (tail = XCDR (keymap); CONSP (tail); tail = XCDR (tail))
{
Lisp_Object elt;
elt = XCAR (tail);
if (VECTORP (elt))
{
if (NATNUMP (idx) && XFASTINT (idx) < ASIZE (elt))
{
CHECK_IMPURE (elt);
ASET (elt, XFASTINT (idx), def);
return def;
}
insertion_point = tail;
}
else if (CHAR_TABLE_P (elt))
{
if (NATNUMP (idx) && !(XFASTINT (idx) & CHAR_MODIFIER_MASK))
{
Faset (elt, idx,
NILP (def) ? Qt : def);
return def;
}
insertion_point = tail;
}
else if (CONSP (elt))
{
if (EQ (idx, XCAR (elt)))
{
CHECK_IMPURE (elt);
XSETCDR (elt, def);
return def;
}
}
else if (EQ (elt, Qkeymap))
goto keymap_end;
QUIT;
}
keymap_end:
CHECK_IMPURE (insertion_point);
XSETCDR (insertion_point,
Fcons (Fcons (idx, def), XCDR (insertion_point)));
}
return def;
}
EXFUN (Fcopy_keymap, 1);
Lisp_Object
copy_keymap_item (elt)
Lisp_Object elt;
{
Lisp_Object res, tem;
if (!CONSP (elt))
return elt;
res = tem = elt;
if (EQ (XCAR (tem), Qmenu_item))
{
res = elt = Fcons (XCAR (tem), XCDR (tem));
tem = XCDR (elt);
if (CONSP (tem))
{
XSETCDR (elt, Fcons (XCAR (tem), XCDR (tem)));
elt = XCDR (elt);
tem = XCDR (elt);
}
if (CONSP (tem))
{
XSETCDR (elt, Fcons (XCAR (tem), XCDR (tem)));
elt = XCDR (elt);
tem = XCAR (elt);
if (CONSP (tem) && EQ (XCAR (tem), Qkeymap))
XSETCAR (elt, Fcopy_keymap (tem));
tem = XCDR (elt);
if (CONSP (tem) && CONSP (XCAR (tem)))
XSETCDR (elt, XCDR (tem));
}
}
else
{
if (STRINGP (XCAR (tem)))
{
res = elt = Fcons (XCAR (tem), XCDR (tem));
tem = XCDR (elt);
if (CONSP (tem) && STRINGP (XCAR (tem)))
{
XSETCDR (elt, Fcons (XCAR (tem), XCDR (tem)));
elt = XCDR (elt);
tem = XCDR (elt);
}
if (CONSP (tem)
&& CONSP (XCAR (tem))
&& (NILP (XCAR (XCAR (tem)))
|| VECTORP (XCAR (XCAR (tem)))))
{
XSETCDR (elt, XCDR (tem));
tem = XCDR (tem);
}
if (CONSP (tem) && EQ (XCAR (tem), Qkeymap))
XSETCDR (elt, Fcopy_keymap (tem));
}
else if (EQ (XCAR (tem), Qkeymap))
res = Fcopy_keymap (elt);
}
return res;
}
static void
copy_keymap_1 (chartable, idx, elt)
Lisp_Object chartable, idx, elt;
{
Faset (chartable, idx, copy_keymap_item (elt));
}
DEFUN ("copy-keymap", Fcopy_keymap, Scopy_keymap, 1, 1, 0,
doc: )
(keymap)
Lisp_Object keymap;
{
register Lisp_Object copy, tail;
keymap = get_keymap (keymap, 1, 0);
copy = tail = Fcons (Qkeymap, Qnil);
keymap = XCDR (keymap);
while (CONSP (keymap) && !EQ (XCAR (keymap), Qkeymap))
{
Lisp_Object elt = XCAR (keymap);
if (CHAR_TABLE_P (elt))
{
Lisp_Object indices[3];
elt = Fcopy_sequence (elt);
map_char_table (copy_keymap_1, Qnil, elt, elt, elt, 0, indices);
}
else if (VECTORP (elt))
{
int i;
elt = Fcopy_sequence (elt);
for (i = 0; i < ASIZE (elt); i++)
ASET (elt, i, copy_keymap_item (AREF (elt, i)));
}
else if (CONSP (elt))
elt = Fcons (XCAR (elt), copy_keymap_item (XCDR (elt)));
XSETCDR (tail, Fcons (elt, Qnil));
tail = XCDR (tail);
keymap = XCDR (keymap);
}
XSETCDR (tail, keymap);
return copy;
}
DEFUN ("define-key", Fdefine_key, Sdefine_key, 3, 3, 0,
doc: )
(keymap, key, def)
Lisp_Object keymap;
Lisp_Object key;
Lisp_Object def;
{
register int idx;
register Lisp_Object c;
register Lisp_Object cmd;
int metized = 0;
int meta_bit;
int length;
struct gcpro gcpro1, gcpro2, gcpro3;
GCPRO3 (keymap, key, def);
keymap = get_keymap (keymap, 1, 1);
CHECK_VECTOR_OR_STRING (key);
length = XFASTINT (Flength (key));
if (length == 0)
RETURN_UNGCPRO (Qnil);
if (SYMBOLP (def) && !EQ (Vdefine_key_rebound_commands, Qt))
Vdefine_key_rebound_commands = Fcons (def, Vdefine_key_rebound_commands);
meta_bit = VECTORP (key) ? meta_modifier : 0x80;
if (VECTORP (def) && ASIZE (def) > 0 && CONSP (AREF (def, 0)))
{
Lisp_Object tmp = Fmake_vector (make_number (ASIZE (def)), Qnil);
int i = ASIZE (def);
while (--i >= 0)
{
Lisp_Object c = AREF (def, i);
if (CONSP (c) && lucid_event_type_list_p (c))
c = Fevent_convert_list (c);
ASET (tmp, i, c);
}
def = tmp;
}
idx = 0;
while (1)
{
c = Faref (key, make_number (idx));
if (CONSP (c) && lucid_event_type_list_p (c))
c = Fevent_convert_list (c);
if (SYMBOLP (c))
silly_event_symbol_error (c);
if (INTEGERP (c)
&& (XINT (c) & meta_bit)
&& !metized)
{
c = meta_prefix_char;
metized = 1;
}
else
{
if (INTEGERP (c))
XSETINT (c, XINT (c) & ~meta_bit);
metized = 0;
idx++;
}
if (!INTEGERP (c) && !SYMBOLP (c) && !CONSP (c))
error ("Key sequence contains invalid event");
if (idx == length)
RETURN_UNGCPRO (store_in_keymap (keymap, c, def));
cmd = access_keymap (keymap, c, 0, 1, 1);
if (NILP (cmd))
cmd = define_as_prefix (keymap, c);
keymap = get_keymap (cmd, 0, 1);
if (!CONSP (keymap))
error ("Key sequence %s starts with non-prefix key %s",
SDATA (Fkey_description (key, Qnil)),
SDATA (Fkey_description (Fsubstring (key, make_number (0),
make_number (idx)),
Qnil)));
}
}
DEFUN ("command-remapping", Fcommand_remapping, Scommand_remapping, 1, 3, 0,
doc: )
(command, position, keymaps)
Lisp_Object command, position, keymaps;
{
if (!SYMBOLP (command))
return Qnil;
ASET (command_remapping_vector, 1, command);
if (NILP (keymaps))
return Fkey_binding (command_remapping_vector, Qnil, Qt, position);
else
{
Lisp_Object maps, binding;
for (maps = keymaps; !NILP (maps); maps = Fcdr (maps))
{
binding = Flookup_key (Fcar (maps), command_remapping_vector, Qnil);
if (!NILP (binding) && !INTEGERP (binding))
return binding;
}
return Qnil;
}
}
DEFUN ("lookup-key", Flookup_key, Slookup_key, 2, 3, 0,
doc: )
(keymap, key, accept_default)
Lisp_Object keymap;
Lisp_Object key;
Lisp_Object accept_default;
{
register int idx;
register Lisp_Object cmd;
register Lisp_Object c;
int length;
int t_ok = !NILP (accept_default);
struct gcpro gcpro1, gcpro2;
GCPRO2 (keymap, key);
keymap = get_keymap (keymap, 1, 1);
CHECK_VECTOR_OR_STRING (key);
length = XFASTINT (Flength (key));
if (length == 0)
RETURN_UNGCPRO (keymap);
idx = 0;
while (1)
{
c = Faref (key, make_number (idx++));
if (CONSP (c) && lucid_event_type_list_p (c))
c = Fevent_convert_list (c);
if (INTEGERP (c) && XINT (c) & 0x80 && STRINGP (key))
XSETINT (c, (XINT (c) | meta_modifier) & ~0x80);
if (!INTEGERP (c) && !SYMBOLP (c) && !CONSP (c) && !STRINGP (c))
error ("Key sequence contains invalid event");
cmd = access_keymap (keymap, c, t_ok, 0, 1);
if (idx == length)
RETURN_UNGCPRO (cmd);
keymap = get_keymap (cmd, 0, 1);
if (!CONSP (keymap))
RETURN_UNGCPRO (make_number (idx));
QUIT;
}
}
static Lisp_Object
define_as_prefix (keymap, c)
Lisp_Object keymap, c;
{
Lisp_Object cmd;
cmd = Fmake_sparse_keymap (Qnil);
cmd = nconc2 (cmd, access_keymap (keymap, c, 0, 0, 0));
store_in_keymap (keymap, c, cmd);
return cmd;
}
Lisp_Object
append_key (key_sequence, key)
Lisp_Object key_sequence, key;
{
Lisp_Object args[2];
args[0] = key_sequence;
args[1] = Fcons (key, Qnil);
return Fvconcat (2, args);
}
static void
silly_event_symbol_error (c)
Lisp_Object c;
{
Lisp_Object parsed, base, name, assoc;
int modifiers;
parsed = parse_modifiers (c);
modifiers = (int) XUINT (XCAR (XCDR (parsed)));
base = XCAR (parsed);
name = Fsymbol_name (base);
assoc = Fassoc (name, exclude_keys);
if (! NILP (assoc))
{
char new_mods[sizeof ("\\A-\\C-\\H-\\M-\\S-\\s-")];
char *p = new_mods;
Lisp_Object keystring;
if (modifiers & alt_modifier)
{ *p++ = '\\'; *p++ = 'A'; *p++ = '-'; }
if (modifiers & ctrl_modifier)
{ *p++ = '\\'; *p++ = 'C'; *p++ = '-'; }
if (modifiers & hyper_modifier)
{ *p++ = '\\'; *p++ = 'H'; *p++ = '-'; }
if (modifiers & meta_modifier)
{ *p++ = '\\'; *p++ = 'M'; *p++ = '-'; }
if (modifiers & shift_modifier)
{ *p++ = '\\'; *p++ = 'S'; *p++ = '-'; }
if (modifiers & super_modifier)
{ *p++ = '\\'; *p++ = 's'; *p++ = '-'; }
*p = 0;
c = reorder_modifiers (c);
keystring = concat2 (build_string (new_mods), XCDR (assoc));
error ((modifiers & ~meta_modifier
? "To bind the key %s, use [?%s], not [%s]"
: "To bind the key %s, use \"%s\", not [%s]"),
SDATA (SYMBOL_NAME (c)), SDATA (keystring),
SDATA (SYMBOL_NAME (c)));
}
}
static Lisp_Object *cmm_modes = NULL, *cmm_maps = NULL;
static int cmm_size = 0;
int
current_minor_maps (modeptr, mapptr)
Lisp_Object **modeptr, **mapptr;
{
int i = 0;
int list_number = 0;
Lisp_Object alist, assoc, var, val;
Lisp_Object emulation_alists;
Lisp_Object lists[2];
emulation_alists = Vemulation_mode_map_alists;
lists[0] = Vminor_mode_overriding_map_alist;
lists[1] = Vminor_mode_map_alist;
for (list_number = 0; list_number < 2; list_number++)
{
if (CONSP (emulation_alists))
{
alist = XCAR (emulation_alists);
emulation_alists = XCDR (emulation_alists);
if (SYMBOLP (alist))
alist = find_symbol_value (alist);
list_number = -1;
}
else
alist = lists[list_number];
for ( ; CONSP (alist); alist = XCDR (alist))
if ((assoc = XCAR (alist), CONSP (assoc))
&& (var = XCAR (assoc), SYMBOLP (var))
&& (val = find_symbol_value (var), !EQ (val, Qunbound))
&& !NILP (val))
{
Lisp_Object temp;
if (list_number == 1)
{
val = assq_no_quit (var, lists[0]);
if (!NILP (val))
continue;
}
if (i >= cmm_size)
{
int newsize, allocsize;
Lisp_Object *newmodes, *newmaps;
newsize = cmm_size == 0 ? 30 : cmm_size * 2;
allocsize = newsize * sizeof *newmodes;
BLOCK_INPUT;
newmodes = (Lisp_Object *) malloc (allocsize);
if (newmodes)
{
if (cmm_modes)
{
bcopy (cmm_modes, newmodes, cmm_size * sizeof cmm_modes[0]);
free (cmm_modes);
}
cmm_modes = newmodes;
}
newmaps = (Lisp_Object *) malloc (allocsize);
if (newmaps)
{
if (cmm_maps)
{
bcopy (cmm_maps, newmaps, cmm_size * sizeof cmm_maps[0]);
free (cmm_maps);
}
cmm_maps = newmaps;
}
UNBLOCK_INPUT;
if (newmodes == NULL || newmaps == NULL)
break;
cmm_size = newsize;
}
temp = Findirect_function (XCDR (assoc), Qt);
if (!NILP (temp))
{
cmm_modes[i] = var;
cmm_maps [i] = temp;
i++;
}
}
}
if (modeptr) *modeptr = cmm_modes;
if (mapptr) *mapptr = cmm_maps;
return i;
}
DEFUN ("current-active-maps", Fcurrent_active_maps, Scurrent_active_maps,
0, 1, 0,
doc: )
(olp)
Lisp_Object olp;
{
Lisp_Object keymaps = Fcons (current_global_map, Qnil);
if (!NILP (olp))
{
if (!NILP (current_kboard->Voverriding_terminal_local_map))
keymaps = Fcons (current_kboard->Voverriding_terminal_local_map, keymaps);
else if (!NILP (Voverriding_local_map))
keymaps = Fcons (Voverriding_local_map, keymaps);
}
if (NILP (XCDR (keymaps)))
{
Lisp_Object local;
Lisp_Object *maps;
int nmaps, i;
local = get_local_map (PT, current_buffer, Qlocal_map);
if (!NILP (local))
keymaps = Fcons (local, keymaps);
nmaps = current_minor_maps (0, &maps);
for (i = --nmaps; i >= 0; i--)
if (!NILP (maps[i]))
keymaps = Fcons (maps[i], keymaps);
local = get_local_map (PT, current_buffer, Qkeymap);
if (!NILP (local))
keymaps = Fcons (local, keymaps);
}
return keymaps;
}
DEFUN ("key-binding", Fkey_binding, Skey_binding, 1, 4, 0,
doc: )
(key, accept_default, no_remap, position)
Lisp_Object key, accept_default, no_remap, position;
{
Lisp_Object *maps, value;
int nmaps, i;
struct gcpro gcpro1, gcpro2;
int count = SPECPDL_INDEX ();
GCPRO2 (key, position);
if (NILP (position) && VECTORP (key))
{
Lisp_Object event
= AREF (key, SYMBOLP (AREF (key, 0)) && ASIZE (key) > 1 ? 1 : 0);
if (EVENT_HAS_PARAMETERS (event) && CONSP (XCDR (event)))
{
Lisp_Object kind = EVENT_HEAD_KIND (EVENT_HEAD (event));
if (EQ (kind, Qmouse_click))
position = EVENT_START (event);
}
}
if (CONSP (position))
{
Lisp_Object window;
window = POSN_WINDOW (position);
if (WINDOWP (window)
&& BUFFERP (XWINDOW (window)->buffer)
&& XBUFFER (XWINDOW (window)->buffer) != current_buffer)
{
record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
set_buffer_internal (XBUFFER (XWINDOW (window)->buffer));
}
}
if (! NILP (current_kboard->Voverriding_terminal_local_map))
{
value = Flookup_key (current_kboard->Voverriding_terminal_local_map,
key, accept_default);
if (! NILP (value) && !INTEGERP (value))
goto done;
}
else if (! NILP (Voverriding_local_map))
{
value = Flookup_key (Voverriding_local_map, key, accept_default);
if (! NILP (value) && !INTEGERP (value))
goto done;
}
else
{
Lisp_Object keymap, local_map;
EMACS_INT pt;
pt = INTEGERP (position) ? XINT (position)
: MARKERP (position) ? marker_position (position)
: PT;
local_map = get_local_map (pt, current_buffer, Qlocal_map);
keymap = get_local_map (pt, current_buffer, Qkeymap);
if (CONSP (position))
{
Lisp_Object string;
if (POSN_INBUFFER_P (position))
{
Lisp_Object pos;
pos = POSN_BUFFER_POSN (position);
if (INTEGERP (pos)
&& XINT (pos) >= BEG && XINT (pos) <= Z)
{
local_map = get_local_map (XINT (pos),
current_buffer, Qlocal_map);
keymap = get_local_map (XINT (pos),
current_buffer, Qkeymap);
}
}
if (string = POSN_STRING (position),
(CONSP (string) && STRINGP (XCAR (string))))
{
Lisp_Object pos, map;
pos = XCDR (string);
string = XCAR (string);
if (INTEGERP (pos)
&& XINT (pos) >= 0
&& XINT (pos) < SCHARS (string))
{
map = Fget_text_property (pos, Qlocal_map, string);
if (!NILP (map))
local_map = map;
map = Fget_text_property (pos, Qkeymap, string);
if (!NILP (map))
keymap = map;
}
}
}
if (! NILP (keymap))
{
value = Flookup_key (keymap, key, accept_default);
if (! NILP (value) && !INTEGERP (value))
goto done;
}
nmaps = current_minor_maps (0, &maps);
for (i = 0; i < nmaps; i++)
if (! NILP (maps[i]))
{
value = Flookup_key (maps[i], key, accept_default);
if (! NILP (value) && !INTEGERP (value))
goto done;
}
if (! NILP (local_map))
{
value = Flookup_key (local_map, key, accept_default);
if (! NILP (value) && !INTEGERP (value))
goto done;
}
}
value = Flookup_key (current_global_map, key, accept_default);
done:
unbind_to (count, Qnil);
UNGCPRO;
if (NILP (value) || INTEGERP (value))
return Qnil;
if (NILP (no_remap) && SYMBOLP (value))
{
Lisp_Object value1;
if (value1 = Fcommand_remapping (value, position, Qnil), !NILP (value1))
value = value1;
}
return value;
}
DEFUN ("local-key-binding", Flocal_key_binding, Slocal_key_binding, 1, 2, 0,
doc: )
(keys, accept_default)
Lisp_Object keys, accept_default;
{
register Lisp_Object map;
map = current_buffer->keymap;
if (NILP (map))
return Qnil;
return Flookup_key (map, keys, accept_default);
}
DEFUN ("global-key-binding", Fglobal_key_binding, Sglobal_key_binding, 1, 2, 0,
doc: )
(keys, accept_default)
Lisp_Object keys, accept_default;
{
return Flookup_key (current_global_map, keys, accept_default);
}
DEFUN ("minor-mode-key-binding", Fminor_mode_key_binding, Sminor_mode_key_binding, 1, 2, 0,
doc: )
(key, accept_default)
Lisp_Object key, accept_default;
{
Lisp_Object *modes, *maps;
int nmaps;
Lisp_Object binding;
int i, j;
struct gcpro gcpro1, gcpro2;
nmaps = current_minor_maps (&modes, &maps);
binding = Qnil;
GCPRO2 (key, binding);
for (i = j = 0; i < nmaps; i++)
if (!NILP (maps[i])
&& !NILP (binding = Flookup_key (maps[i], key, accept_default))
&& !INTEGERP (binding))
{
if (KEYMAPP (binding))
maps[j++] = Fcons (modes[i], binding);
else if (j == 0)
RETURN_UNGCPRO (Fcons (Fcons (modes[i], binding), Qnil));
}
UNGCPRO;
return Flist (j, maps);
}
DEFUN ("define-prefix-command", Fdefine_prefix_command, Sdefine_prefix_command, 1, 3, 0,
doc: )
(command, mapvar, name)
Lisp_Object command, mapvar, name;
{
Lisp_Object map;
map = Fmake_sparse_keymap (name);
Ffset (command, map);
if (!NILP (mapvar))
Fset (mapvar, map);
else
Fset (command, map);
return command;
}
DEFUN ("use-global-map", Fuse_global_map, Suse_global_map, 1, 1, 0,
doc: )
(keymap)
Lisp_Object keymap;
{
keymap = get_keymap (keymap, 1, 1);
current_global_map = keymap;
return Qnil;
}
DEFUN ("use-local-map", Fuse_local_map, Suse_local_map, 1, 1, 0,
doc: )
(keymap)
Lisp_Object keymap;
{
if (!NILP (keymap))
keymap = get_keymap (keymap, 1, 1);
current_buffer->keymap = keymap;
return Qnil;
}
DEFUN ("current-local-map", Fcurrent_local_map, Scurrent_local_map, 0, 0, 0,
doc: )
()
{
return current_buffer->keymap;
}
DEFUN ("current-global-map", Fcurrent_global_map, Scurrent_global_map, 0, 0, 0,
doc: )
()
{
return current_global_map;
}
DEFUN ("current-minor-mode-maps", Fcurrent_minor_mode_maps, Scurrent_minor_mode_maps, 0, 0, 0,
doc: )
()
{
Lisp_Object *maps;
int nmaps = current_minor_maps (0, &maps);
return Flist (nmaps, maps);
}
static void
accessible_keymaps_1 (key, cmd, maps, tail, thisseq, is_metized)
Lisp_Object maps, tail, thisseq, key, cmd;
int is_metized;
{
Lisp_Object tem;
cmd = get_keymap (get_keyelt (cmd, 0), 0, 0);
if (NILP (cmd))
return;
while (!NILP (tem = Frassq (cmd, maps)))
{
Lisp_Object prefix = XCAR (tem);
int lim = XINT (Flength (XCAR (tem)));
if (lim <= XINT (Flength (thisseq)))
{
int i = 0;
while (i < lim && EQ (Faref (prefix, make_number (i)),
Faref (thisseq, make_number (i))))
i++;
if (i >= lim)
return;
}
maps = XCDR (Fmemq (tem, maps));
}
if (is_metized)
{
int meta_bit = meta_modifier;
Lisp_Object last = make_number (XINT (Flength (thisseq)) - 1);
tem = Fcopy_sequence (thisseq);
Faset (tem, last, make_number (XINT (key) | meta_bit));
XSETCDR (tail,
Fcons (Fcons (tem, cmd), XCDR (tail)));
}
else
{
tem = append_key (thisseq, key);
nconc2 (tail, Fcons (Fcons (tem, cmd), Qnil));
}
}
static void
accessible_keymaps_char_table (args, index, cmd)
Lisp_Object args, index, cmd;
{
accessible_keymaps_1 (index, cmd,
XCAR (XCAR (args)),
XCAR (XCDR (args)),
XCDR (XCDR (args)),
XINT (XCDR (XCAR (args))));
}
DEFUN ("accessible-keymaps", Faccessible_keymaps, Saccessible_keymaps,
1, 2, 0,
doc: )
(keymap, prefix)
Lisp_Object keymap, prefix;
{
Lisp_Object maps, tail;
int prefixlen = 0;
if (!NILP (prefix))
prefixlen = XINT (Flength (prefix));
if (!NILP (prefix))
{
Lisp_Object tem;
tem = Flookup_key (keymap, prefix, Qt);
tem = get_keymap (tem, 0, 0);
if (CONSP (tem))
{
if (STRINGP (prefix))
{
int i, i_byte, c;
Lisp_Object copy;
copy = Fmake_vector (make_number (SCHARS (prefix)), Qnil);
for (i = 0, i_byte = 0; i < SCHARS (prefix);)
{
int i_before = i;
FETCH_STRING_CHAR_ADVANCE (c, prefix, i, i_byte);
if (SINGLE_BYTE_CHAR_P (c) && (c & 0200))
c ^= 0200 | meta_modifier;
ASET (copy, i_before, make_number (c));
}
prefix = copy;
}
maps = Fcons (Fcons (prefix, tem), Qnil);
}
else
return Qnil;
}
else
maps = Fcons (Fcons (Fmake_vector (make_number (0), Qnil),
get_keymap (keymap, 1, 0)),
Qnil);
for (tail = maps; CONSP (tail); tail = XCDR (tail))
{
register Lisp_Object thisseq, thismap;
Lisp_Object last;
int is_metized;
thisseq = Fcar (Fcar (tail));
thismap = Fcdr (Fcar (tail));
last = make_number (XINT (Flength (thisseq)) - 1);
is_metized = (XINT (last) >= 0
&& XINT (last) >= prefixlen
&& EQ (Faref (thisseq, last), meta_prefix_char));
for (; CONSP (thismap); thismap = XCDR (thismap))
{
Lisp_Object elt;
elt = XCAR (thismap);
QUIT;
if (CHAR_TABLE_P (elt))
{
Lisp_Object indices[3];
map_char_table (accessible_keymaps_char_table, Qnil, elt,
elt, Fcons (Fcons (maps, make_number (is_metized)),
Fcons (tail, thisseq)),
0, indices);
}
else if (VECTORP (elt))
{
register int i;
for (i = 0; i < ASIZE (elt); i++)
accessible_keymaps_1 (make_number (i), AREF (elt, i),
maps, tail, thisseq, is_metized);
}
else if (CONSP (elt))
accessible_keymaps_1 (XCAR (elt), XCDR (elt),
maps, tail, thisseq,
is_metized && INTEGERP (XCAR (elt)));
}
}
return maps;
}
Lisp_Object Qsingle_key_description, Qkey_description;
DEFUN ("key-description", Fkey_description, Skey_description, 1, 2, 0,
doc: )
(keys, prefix)
Lisp_Object keys, prefix;
{
int len = 0;
int i, i_byte;
Lisp_Object *args;
int size = XINT (Flength (keys));
Lisp_Object list;
Lisp_Object sep = build_string (" ");
Lisp_Object key;
int add_meta = 0;
if (!NILP (prefix))
size += XINT (Flength (prefix));
args = (Lisp_Object *) alloca (size * 4 * sizeof (Lisp_Object));
next_list:
if (!NILP (prefix))
list = prefix, prefix = Qnil;
else if (!NILP (keys))
list = keys, keys = Qnil;
else
{
if (add_meta)
{
args[len] = Fsingle_key_description (meta_prefix_char, Qnil);
len += 2;
}
else if (len == 0)
return empty_string;
return Fconcat (len - 1, args);
}
if (STRINGP (list))
size = SCHARS (list);
else if (VECTORP (list))
size = XVECTOR (list)->size;
else if (CONSP (list))
size = XINT (Flength (list));
else
wrong_type_argument (Qarrayp, list);
i = i_byte = 0;
while (i < size)
{
if (STRINGP (list))
{
int c;
FETCH_STRING_CHAR_ADVANCE (c, list, i, i_byte);
if (SINGLE_BYTE_CHAR_P (c) && (c & 0200))
c ^= 0200 | meta_modifier;
XSETFASTINT (key, c);
}
else if (VECTORP (list))
{
key = AREF (list, i++);
}
else
{
key = XCAR (list);
list = XCDR (list);
i++;
}
if (add_meta)
{
if (!INTEGERP (key)
|| EQ (key, meta_prefix_char)
|| (XINT (key) & meta_modifier))
{
args[len++] = Fsingle_key_description (meta_prefix_char, Qnil);
args[len++] = sep;
if (EQ (key, meta_prefix_char))
continue;
}
else
XSETINT (key, (XINT (key) | meta_modifier) & ~0x80);
add_meta = 0;
}
else if (EQ (key, meta_prefix_char))
{
add_meta = 1;
continue;
}
args[len++] = Fsingle_key_description (key, Qnil);
args[len++] = sep;
}
goto next_list;
}
char *
push_key_description (c, p, force_multibyte)
register unsigned int c;
register char *p;
int force_multibyte;
{
unsigned c2;
int valid_p;
c &= meta_modifier | ~ - meta_modifier;
c2 = c & ~(alt_modifier | ctrl_modifier | hyper_modifier
| meta_modifier | shift_modifier | super_modifier);
valid_p = SINGLE_BYTE_CHAR_P (c2) || char_valid_p (c2, 0);
if (! valid_p)
{
p += sprintf (p, "[%d]", c);
return p;
}
if (c & alt_modifier)
{
*p++ = 'A';
*p++ = '-';
c -= alt_modifier;
}
if ((c & ctrl_modifier) != 0
|| (c2 < ' ' && c2 != 27 && c2 != '\t' && c2 != Ctl ('M')))
{
*p++ = 'C';
*p++ = '-';
c &= ~ctrl_modifier;
}
if (c & hyper_modifier)
{
*p++ = 'H';
*p++ = '-';
c -= hyper_modifier;
}
if (c & meta_modifier)
{
*p++ = 'M';
*p++ = '-';
c -= meta_modifier;
}
if (c & shift_modifier)
{
*p++ = 'S';
*p++ = '-';
c -= shift_modifier;
}
if (c & super_modifier)
{
*p++ = 's';
*p++ = '-';
c -= super_modifier;
}
if (c < 040)
{
if (c == 033)
{
*p++ = 'E';
*p++ = 'S';
*p++ = 'C';
}
else if (c == '\t')
{
*p++ = 'T';
*p++ = 'A';
*p++ = 'B';
}
else if (c == Ctl ('M'))
{
*p++ = 'R';
*p++ = 'E';
*p++ = 'T';
}
else
{
if (c > 0 && c <= Ctl ('Z'))
*p++ = c + 0140;
else
*p++ = c + 0100;
}
}
else if (c == 0177)
{
*p++ = 'D';
*p++ = 'E';
*p++ = 'L';
}
else if (c == ' ')
{
*p++ = 'S';
*p++ = 'P';
*p++ = 'C';
}
else if (c < 128
|| (NILP (current_buffer->enable_multibyte_characters)
&& SINGLE_BYTE_CHAR_P (c)
&& !force_multibyte))
{
*p++ = c;
}
else
{
if (force_multibyte)
{
if (SINGLE_BYTE_CHAR_P (c))
c = unibyte_char_to_multibyte (c);
p += CHAR_STRING (c, p);
}
else if (NILP (current_buffer->enable_multibyte_characters))
{
int bit_offset;
*p++ = '\\';
for (bit_offset = 18; bit_offset >= 0; bit_offset -= 3)
{
if (c >= (1 << bit_offset))
*p++ = ((c & (7 << bit_offset)) >> bit_offset) + '0';
}
}
else
p += CHAR_STRING (c, p);
}
return p;
}
DEFUN ("single-key-description", Fsingle_key_description,
Ssingle_key_description, 1, 2, 0,
doc: )
(key, no_angles)
Lisp_Object key, no_angles;
{
if (CONSP (key) && lucid_event_type_list_p (key))
key = Fevent_convert_list (key);
key = EVENT_HEAD (key);
if (INTEGERP (key))
{
unsigned int charset, c1, c2;
int without_bits = XINT (key) & ~((-1) << CHARACTERBITS);
if (SINGLE_BYTE_CHAR_P (without_bits))
charset = 0;
else
SPLIT_CHAR (without_bits, charset, c1, c2);
if (! CHAR_VALID_P (without_bits, 1))
{
char buf[256];
sprintf (buf, "Invalid char code %d", XINT (key));
return build_string (buf);
}
else if (charset
&& ((c1 == 0 && c2 == -1) || c2 == 0))
{
Lisp_Object name;
char buf[256];
name = CHARSET_TABLE_INFO (charset, CHARSET_SHORT_NAME_IDX);
CHECK_STRING (name);
if (c1 == 0)
sprintf (buf, "Generic char %d: all of ", without_bits);
else
sprintf (buf, "Generic char %d: row %d of ", without_bits, c1);
return concat2 (build_string (buf), name);
}
else
{
char tem[KEY_DESCRIPTION_SIZE], *end;
int nbytes, nchars;
Lisp_Object string;
end = push_key_description (XUINT (key), tem, 1);
nbytes = end - tem;
nchars = multibyte_chars_in_text (tem, nbytes);
if (nchars == nbytes)
{
*end = '\0';
string = build_string (tem);
}
else
string = make_multibyte_string (tem, nchars, nbytes);
return string;
}
}
else if (SYMBOLP (key))
{
if (NILP (no_angles))
{
char *buffer
= (char *) alloca (SBYTES (SYMBOL_NAME (key)) + 5);
sprintf (buffer, "<%s>", SDATA (SYMBOL_NAME (key)));
return build_string (buffer);
}
else
return Fsymbol_name (key);
}
else if (STRINGP (key))
return Fcopy_sequence (key);
else
error ("KEY must be an integer, cons, symbol, or string");
return Qnil;
}
char *
push_text_char_description (c, p)
register unsigned int c;
register char *p;
{
if (c >= 0200)
{
*p++ = 'M';
*p++ = '-';
c -= 0200;
}
if (c < 040)
{
*p++ = '^';
*p++ = c + 64;
}
else if (c == 0177)
{
*p++ = '^';
*p++ = '?';
}
else
*p++ = c;
return p;
}
DEFUN ("text-char-description", Ftext_char_description, Stext_char_description, 1, 1, 0,
doc: )
(character)
Lisp_Object character;
{
unsigned char str[6];
int c;
CHECK_NUMBER (character);
c = XINT (character);
if (!SINGLE_BYTE_CHAR_P (c))
{
int len = CHAR_STRING (c, str);
return make_multibyte_string (str, 1, len);
}
*push_text_char_description (c & 0377, str) = 0;
return build_string (str);
}
static int
ascii_sequence_p (seq)
Lisp_Object seq;
{
int i;
int len = XINT (Flength (seq));
for (i = 0; i < len; i++)
{
Lisp_Object ii, elt;
XSETFASTINT (ii, i);
elt = Faref (seq, ii);
if (!INTEGERP (elt)
|| (XUINT (elt) & ~CHAR_META) >= 0x80)
return 0;
}
return 1;
}
static Lisp_Object where_is_internal ();
static Lisp_Object where_is_internal_1 ();
static void where_is_internal_2 ();
static Lisp_Object
shadow_lookup (shadow, key, flag)
Lisp_Object shadow, key, flag;
{
Lisp_Object tail, value;
for (tail = shadow; CONSP (tail); tail = XCDR (tail))
{
value = Flookup_key (XCAR (tail), key, flag);
if (NATNUMP (value))
{
value = Flookup_key (XCAR (tail),
Fsubstring (key, make_number (0), value), flag);
if (!NILP (value))
return Qnil;
}
else if (!NILP (value))
return value;
}
return Qnil;
}
static Lisp_Object Vmouse_events;
static Lisp_Object
where_is_internal (definition, keymaps, firstonly, noindirect, no_remap)
Lisp_Object definition, keymaps;
Lisp_Object firstonly, noindirect, no_remap;
{
Lisp_Object maps = Qnil;
Lisp_Object found, sequences;
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
int nomenus = !NILP (firstonly) && !EQ (firstonly, Qnon_ascii);
found = keymaps;
while (CONSP (found))
{
maps =
nconc2 (maps,
Faccessible_keymaps (get_keymap (XCAR (found), 1, 0), Qnil));
found = XCDR (found);
}
GCPRO5 (definition, keymaps, maps, found, sequences);
found = Qnil;
sequences = Qnil;
if (NILP (no_remap)
&& SYMBOLP (definition)
&& !NILP (Fcommand_remapping (definition, Qnil, keymaps)))
RETURN_UNGCPRO (Qnil);
for (; !NILP (maps); maps = Fcdr (maps))
{
register Lisp_Object this, map, tem;
Lisp_Object last;
int last_is_meta;
this = Fcar (Fcar (maps));
map = Fcdr (Fcar (maps));
last = make_number (XINT (Flength (this)) - 1);
last_is_meta = (XINT (last) >= 0
&& EQ (Faref (this, last), meta_prefix_char));
if (nomenus && XINT (last) >= 0
&& SYMBOLP (tem = Faref (this, make_number (0)))
&& !NILP (Fmemq (XCAR (parse_modifiers (tem)), Vmouse_events)))
continue;
QUIT;
while (CONSP (map))
{
Lisp_Object elt, key, binding;
elt = XCAR (map);
map = XCDR (map);
sequences = Qnil;
QUIT;
if (VECTORP (elt))
{
Lisp_Object sequence;
int i;
for (i = 0; i < XVECTOR (elt)->size; i++)
{
binding = AREF (elt, i);
XSETFASTINT (key, i);
sequence = where_is_internal_1 (binding, key, definition,
noindirect, this,
last, nomenus, last_is_meta);
if (!NILP (sequence))
sequences = Fcons (sequence, sequences);
}
}
else if (CHAR_TABLE_P (elt))
{
Lisp_Object indices[3];
Lisp_Object args;
args = Fcons (Fcons (Fcons (definition, noindirect),
Qnil),
Fcons (Fcons (this, last),
Fcons (make_number (nomenus),
make_number (last_is_meta))));
map_char_table (where_is_internal_2, Qnil, elt, elt, args,
0, indices);
sequences = XCDR (XCAR (args));
}
else if (CONSP (elt))
{
Lisp_Object sequence;
key = XCAR (elt);
binding = XCDR (elt);
sequence = where_is_internal_1 (binding, key, definition,
noindirect, this,
last, nomenus, last_is_meta);
if (!NILP (sequence))
sequences = Fcons (sequence, sequences);
}
while (!NILP (sequences))
{
Lisp_Object sequence, remapped, function;
sequence = XCAR (sequences);
sequences = XCDR (sequences);
remapped = Qnil;
if (NILP (no_remap)
&& VECTORP (sequence) && XVECTOR (sequence)->size == 2
&& EQ (AREF (sequence, 0), Qremap)
&& (function = AREF (sequence, 1), SYMBOLP (function)))
{
Lisp_Object remapped1;
remapped1 = where_is_internal (function, keymaps, firstonly, noindirect, Qt);
if (CONSP (remapped1))
{
if (!EQ (shadow_lookup (keymaps, XCAR (remapped1), Qnil), function))
continue;
sequence = XCAR (remapped1);
remapped = XCDR (remapped1);
goto record_sequence;
}
}
if (!EQ (shadow_lookup (keymaps, sequence, Qnil), definition))
continue;
record_sequence:
if (! NILP (sequence))
{
Lisp_Object tem;
tem = Faref (sequence, make_number (XVECTOR (sequence)->size - 1));
if (STRINGP (tem))
Faset (sequence, make_number (XVECTOR (sequence)->size - 1),
build_string ("(any string)"));
}
if (NILP (Fmember (sequence, found)))
found = Fcons (sequence, found);
if (EQ (firstonly, Qnon_ascii))
RETURN_UNGCPRO (sequence);
else if (!NILP (firstonly) && ascii_sequence_p (sequence))
RETURN_UNGCPRO (sequence);
if (CONSP (remapped))
{
sequence = XCAR (remapped);
remapped = XCDR (remapped);
goto record_sequence;
}
}
}
}
UNGCPRO;
found = Fnreverse (found);
if (!NILP (firstonly))
return Fcar (found);
return found;
}
DEFUN ("where-is-internal", Fwhere_is_internal, Swhere_is_internal, 1, 5, 0,
doc: )
(definition, keymap, firstonly, noindirect, no_remap)
Lisp_Object definition, keymap;
Lisp_Object firstonly, noindirect, no_remap;
{
Lisp_Object sequences, keymaps;
int nomenus = !NILP (firstonly) && !EQ (firstonly, Qnon_ascii);
Lisp_Object result;
if (CONSP (keymap) && KEYMAPP (XCAR (keymap)))
keymaps = keymap;
else if (!NILP (keymap))
keymaps = Fcons (keymap, Fcons (current_global_map, Qnil));
else
keymaps = Fcurrent_active_maps (Qnil);
if (nomenus && NILP (noindirect) && NILP (keymap))
{
Lisp_Object *defns;
int i, j, n;
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
if (NILP (Fequal (keymaps, where_is_cache_keymaps)))
where_is_cache = Qnil;
if (NILP (where_is_cache))
{
Lisp_Object args[2];
where_is_cache = Fmake_hash_table (0, args);
where_is_cache_keymaps = Qt;
GCPRO5 (definition, keymaps, firstonly, noindirect, no_remap);
where_is_internal (definition, keymaps, firstonly, noindirect, no_remap);
UNGCPRO;
where_is_cache_keymaps = keymaps;
}
sequences = Fgethash (definition, where_is_cache, Qnil);
n = XINT (Flength (sequences));
defns = (Lisp_Object *) alloca (n * sizeof *defns);
for (i = 0; CONSP (sequences); sequences = XCDR (sequences))
defns[i++] = XCAR (sequences);
GCPRO2 (definition, keymaps);
result = Qnil;
j = -1;
for (i = n - 1; i >= 0; --i)
if (EQ (shadow_lookup (keymaps, defns[i], Qnil), definition))
{
if (ascii_sequence_p (defns[i]))
break;
else if (j < 0)
j = i;
}
result = i >= 0 ? defns[i] : (j >= 0 ? defns[j] : Qnil);
UNGCPRO;
}
else
{
where_is_cache = Qnil;
result = where_is_internal (definition, keymaps, firstonly, noindirect, no_remap);
}
return result;
}
static void
where_is_internal_2 (args, key, binding)
Lisp_Object args, key, binding;
{
Lisp_Object definition, noindirect, this, last;
Lisp_Object result, sequence;
int nomenus, last_is_meta;
struct gcpro gcpro1, gcpro2, gcpro3;
GCPRO3 (args, key, binding);
result = XCDR (XCAR (args));
definition = XCAR (XCAR (XCAR (args)));
noindirect = XCDR (XCAR (XCAR (args)));
this = XCAR (XCAR (XCDR (args)));
last = XCDR (XCAR (XCDR (args)));
nomenus = XFASTINT (XCAR (XCDR (XCDR (args))));
last_is_meta = XFASTINT (XCDR (XCDR (XCDR (args))));
sequence = where_is_internal_1 (binding, key, definition, noindirect,
this, last, nomenus, last_is_meta);
if (!NILP (sequence))
XSETCDR (XCAR (args), Fcons (sequence, result));
UNGCPRO;
}
static Lisp_Object
where_is_internal_1 (binding, key, definition, noindirect, this, last,
nomenus, last_is_meta)
Lisp_Object binding, key, definition, noindirect, this, last;
int nomenus, last_is_meta;
{
Lisp_Object sequence;
if (NILP (noindirect))
binding = get_keyelt (binding, 0);
if (!(!NILP (where_is_cache)
|| EQ (binding, definition)
|| (CONSP (definition) && !NILP (Fequal (binding, definition)))))
return Qnil;
if (INTEGERP (key) && last_is_meta)
{
sequence = Fcopy_sequence (this);
Faset (sequence, last, make_number (XINT (key) | meta_modifier));
}
else
sequence = append_key (this, key);
if (!NILP (where_is_cache))
{
Lisp_Object sequences = Fgethash (binding, where_is_cache, Qnil);
Fputhash (binding, Fcons (sequence, sequences), where_is_cache);
return Qnil;
}
else
return sequence;
}
DEFUN ("describe-buffer-bindings", Fdescribe_buffer_bindings, Sdescribe_buffer_bindings, 1, 3, 0,
doc: )
(buffer, prefix, menus)
Lisp_Object buffer, prefix, menus;
{
Lisp_Object outbuf, shadow;
int nomenu = NILP (menus);
register Lisp_Object start1;
struct gcpro gcpro1;
char *alternate_heading
= "\
Keyboard translations:\n\n\
You type Translation\n\
-------- -----------\n";
CHECK_BUFFER (buffer);
shadow = Qnil;
GCPRO1 (shadow);
outbuf = Fcurrent_buffer ();
if (STRINGP (Vkeyboard_translate_table) && !NILP (prefix))
{
int c;
const unsigned char *translate = SDATA (Vkeyboard_translate_table);
int translate_len = SCHARS (Vkeyboard_translate_table);
for (c = 0; c < translate_len; c++)
if (translate[c] != c)
{
char buf[KEY_DESCRIPTION_SIZE];
char *bufend;
if (alternate_heading)
{
insert_string (alternate_heading);
alternate_heading = 0;
}
bufend = push_key_description (translate[c], buf, 1);
insert (buf, bufend - buf);
Findent_to (make_number (16), make_number (1));
bufend = push_key_description (c, buf, 1);
insert (buf, bufend - buf);
insert ("\n", 1);
translate = SDATA (Vkeyboard_translate_table);
}
insert ("\n", 1);
}
if (!NILP (Vkey_translation_map))
describe_map_tree (Vkey_translation_map, 0, Qnil, prefix,
"Key translations", nomenu, 1, 0, 0);
start1 = Qnil;
if (!NILP (current_kboard->Voverriding_terminal_local_map))
start1 = current_kboard->Voverriding_terminal_local_map;
else if (!NILP (Voverriding_local_map))
start1 = Voverriding_local_map;
if (!NILP (start1))
{
describe_map_tree (start1, 1, shadow, prefix,
"\f\nOverriding Bindings", nomenu, 0, 0, 0);
shadow = Fcons (start1, shadow);
}
else
{
int i, nmaps;
Lisp_Object *modes, *maps;
Fset_buffer (buffer);
nmaps = current_minor_maps (&modes, &maps);
Fset_buffer (outbuf);
start1 = get_local_map (BUF_PT (XBUFFER (buffer)),
XBUFFER (buffer), Qkeymap);
if (!NILP (start1))
{
describe_map_tree (start1, 1, shadow, prefix,
"\f\n`keymap' Property Bindings", nomenu,
0, 0, 0);
shadow = Fcons (start1, shadow);
}
for (i = 0; i < nmaps; i++)
{
char *title, *p;
if (!SYMBOLP (modes[i]))
abort();
p = title = (char *) alloca (42 + SCHARS (SYMBOL_NAME (modes[i])));
*p++ = '\f';
*p++ = '\n';
*p++ = '`';
bcopy (SDATA (SYMBOL_NAME (modes[i])), p,
SCHARS (SYMBOL_NAME (modes[i])));
p += SCHARS (SYMBOL_NAME (modes[i]));
*p++ = '\'';
bcopy (" Minor Mode Bindings", p, sizeof (" Minor Mode Bindings") - 1);
p += sizeof (" Minor Mode Bindings") - 1;
*p = 0;
describe_map_tree (maps[i], 1, shadow, prefix,
title, nomenu, 0, 0, 0);
shadow = Fcons (maps[i], shadow);
}
start1 = get_local_map (BUF_PT (XBUFFER (buffer)),
XBUFFER (buffer), Qlocal_map);
if (!NILP (start1))
{
if (EQ (start1, XBUFFER (buffer)->keymap))
describe_map_tree (start1, 1, shadow, prefix,
"\f\nMajor Mode Bindings", nomenu, 0, 0, 0);
else
describe_map_tree (start1, 1, shadow, prefix,
"\f\n`local-map' Property Bindings",
nomenu, 0, 0, 0);
shadow = Fcons (start1, shadow);
}
}
describe_map_tree (current_global_map, 1, shadow, prefix,
"\f\nGlobal Bindings", nomenu, 0, 1, 0);
if (!NILP (Vfunction_key_map))
describe_map_tree (Vfunction_key_map, 0, Qnil, prefix,
"\f\nFunction key map translations", nomenu, 1, 0, 0);
UNGCPRO;
return Qnil;
}
void
describe_map_tree (startmap, partial, shadow, prefix, title, nomenu, transl,
always_title, mention_shadow)
Lisp_Object startmap, shadow, prefix;
int partial;
char *title;
int nomenu;
int transl;
int always_title;
int mention_shadow;
{
Lisp_Object maps, orig_maps, seen, sub_shadows;
struct gcpro gcpro1, gcpro2, gcpro3;
int something = 0;
char *key_heading
= "\
key binding\n\
--- -------\n";
orig_maps = maps = Faccessible_keymaps (startmap, prefix);
seen = Qnil;
sub_shadows = Qnil;
GCPRO3 (maps, seen, sub_shadows);
if (nomenu)
{
Lisp_Object list;
for (list = maps; !NILP (list); list = XCDR (list))
{
Lisp_Object elt, prefix, tem;
elt = Fcar (list);
prefix = Fcar (elt);
if (XVECTOR (prefix)->size >= 1)
{
tem = Faref (prefix, make_number (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 (; !NILP (maps); maps = Fcdr (maps))
{
register Lisp_Object elt, prefix, tail;
elt = Fcar (maps);
prefix = Fcar (elt);
sub_shadows = Qnil;
for (tail = shadow; CONSP (tail); tail = XCDR (tail))
{
Lisp_Object shmap;
shmap = XCAR (tail);
if ((STRINGP (prefix) && SCHARS (prefix) == 0)
|| (VECTORP (prefix) && XVECTOR (prefix)->size == 0))
;
else
{
shmap = Flookup_key (shmap, Fcar (elt), Qt);
if (INTEGERP (shmap))
shmap = Qnil;
}
if (!NILP (shmap) && !KEYMAPP (shmap))
goto skip;
if (!NILP (shmap))
sub_shadows = Fcons (shmap, sub_shadows);
}
for (tail = orig_maps; !EQ (tail, maps); tail = XCDR (tail))
{
Lisp_Object tem;
tem = Fequal (Fcar (XCAR (tail)), prefix);
if (!NILP (tem))
sub_shadows = Fcons (XCDR (XCAR (tail)), sub_shadows);
}
describe_map (Fcdr (elt), prefix,
transl ? describe_translation : describe_command,
partial, sub_shadows, &seen, nomenu, mention_shadow);
skip: ;
}
if (something)
insert_string ("\n");
UNGCPRO;
}
static int previous_description_column;
static void
describe_command (definition, args)
Lisp_Object definition, args;
{
register Lisp_Object tem1;
int column = (int) current_column ();
int description_column;
if (column > 30)
{
insert_char ('\n');
description_column = 32;
}
else if (column > 14 || (column > 10 && previous_description_column == 32))
description_column = 32;
else
description_column = 16;
Findent_to (make_number (description_column), make_number (1));
previous_description_column = description_column;
if (SYMBOLP (definition))
{
tem1 = SYMBOL_NAME (definition);
insert1 (tem1);
insert_string ("\n");
}
else if (STRINGP (definition) || VECTORP (definition))
insert_string ("Keyboard Macro\n");
else if (KEYMAPP (definition))
insert_string ("Prefix Command\n");
else
insert_string ("??\n");
}
static void
describe_translation (definition, args)
Lisp_Object definition, args;
{
register Lisp_Object tem1;
Findent_to (make_number (16), make_number (1));
if (SYMBOLP (definition))
{
tem1 = SYMBOL_NAME (definition);
insert1 (tem1);
insert_string ("\n");
}
else if (STRINGP (definition) || VECTORP (definition))
{
insert1 (Fkey_description (definition, Qnil));
insert_string ("\n");
}
else if (KEYMAPP (definition))
insert_string ("Prefix Command\n");
else
insert_string ("??\n");
}
struct describe_map_elt { Lisp_Object event; Lisp_Object definition; int shadowed; };
static int
describe_map_compare (aa, bb)
const void *aa, *bb;
{
const struct describe_map_elt *a = aa, *b = bb;
if (INTEGERP (a->event) && INTEGERP (b->event))
return ((XINT (a->event) > XINT (b->event))
- (XINT (a->event) < XINT (b->event)));
if (!INTEGERP (a->event) && INTEGERP (b->event))
return 1;
if (INTEGERP (a->event) && !INTEGERP (b->event))
return -1;
if (SYMBOLP (a->event) && SYMBOLP (b->event))
return (!NILP (Fstring_lessp (a->event, b->event)) ? -1
: !NILP (Fstring_lessp (b->event, a->event)) ? 1
: 0);
return 0;
}
static void
describe_map (map, prefix, elt_describer, partial, shadow,
seen, nomenu, mention_shadow)
register Lisp_Object map;
Lisp_Object prefix;
void (*elt_describer) P_ ((Lisp_Object, Lisp_Object));
int partial;
Lisp_Object shadow;
Lisp_Object *seen;
int nomenu;
int mention_shadow;
{
Lisp_Object tail, definition, event;
Lisp_Object tem;
Lisp_Object suppress;
Lisp_Object kludge;
int first = 1;
struct gcpro gcpro1, gcpro2, gcpro3;
int length_needed = 0;
struct describe_map_elt *vect;
int slots_used = 0;
int i;
suppress = Qnil;
if (partial)
suppress = intern ("suppress-keymap");
kludge = Fmake_vector (make_number (1), Qnil);
definition = Qnil;
for (tail = map; CONSP (tail); tail = XCDR (tail))
length_needed++;
vect = ((struct describe_map_elt *)
alloca (sizeof (struct describe_map_elt) * length_needed));
GCPRO3 (prefix, definition, kludge);
for (tail = map; CONSP (tail); tail = XCDR (tail))
{
QUIT;
if (VECTORP (XCAR (tail))
|| CHAR_TABLE_P (XCAR (tail)))
describe_vector (XCAR (tail),
prefix, Qnil, elt_describer, partial, shadow, map,
(int *)0, 0, 1, mention_shadow);
else if (CONSP (XCAR (tail)))
{
int this_shadowed = 0;
event = XCAR (XCAR (tail));
if (!(SYMBOLP (event) || INTEGERP (event)))
continue;
if (nomenu && EQ (event, Qmenu_bar))
continue;
definition = get_keyelt (XCDR (XCAR (tail)), 0);
if (NILP (definition)) continue;
if (SYMBOLP (definition) && partial)
{
tem = Fget (definition, suppress);
if (!NILP (tem))
continue;
}
ASET (kludge, 0, event);
if (!NILP (shadow))
{
tem = shadow_lookup (shadow, kludge, Qt);
if (!NILP (tem))
{
if (KEYMAPP (definition) && KEYMAPP (tem))
;
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))
{
tem = Fassq (tail, *seen);
if (CONSP (tem) && !NILP (Fequal (XCAR (tem), prefix)))
break;
*seen = Fcons (Fcons (tail, prefix), *seen);
}
}
qsort (vect, slots_used, sizeof (struct describe_map_elt),
describe_map_compare);
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;
if (INTEGERP (vect[i].event))
{
while (i + 1 < slots_used
&& EQ (vect[i+1].event, make_number (XINT (vect[i].event) + 1))
&& !NILP (Fequal (vect[i + 1].definition, definition))
&& vect[i].shadowed == vect[i + 1].shadowed)
i++;
end = vect[i].event;
}
insert1 (Fkey_description (kludge, prefix));
if (!EQ (start, end))
{
insert (" .. ", 4);
ASET (kludge, 0, end);
insert1 (Fkey_description (kludge, prefix));
}
(*elt_describer) (vect[i].definition, Qnil);
if (vect[i].shadowed)
{
SET_PT (PT - 1);
insert_string ("\n (that binding is currently shadowed by another mode)");
SET_PT (PT + 1);
}
}
UNGCPRO;
}
static void
describe_vector_princ (elt, fun)
Lisp_Object elt, fun;
{
Findent_to (make_number (16), make_number (1));
call1 (fun, elt);
Fterpri (Qnil);
}
DEFUN ("describe-vector", Fdescribe_vector, Sdescribe_vector, 1, 2, 0,
doc: )
(vector, describer)
Lisp_Object vector, describer;
{
int count = SPECPDL_INDEX ();
if (NILP (describer))
describer = intern ("princ");
specbind (Qstandard_output, Fcurrent_buffer ());
CHECK_VECTOR_OR_CHAR_TABLE (vector);
describe_vector (vector, Qnil, describer, describe_vector_princ, 0,
Qnil, Qnil, (int *)0, 0, 0, 0);
return unbind_to (count, Qnil);
}
static void
describe_vector (vector, prefix, args, elt_describer,
partial, shadow, entire_map,
indices, char_table_depth, keymap_p,
mention_shadow)
register Lisp_Object vector;
Lisp_Object prefix, args;
void (*elt_describer) P_ ((Lisp_Object, Lisp_Object));
int partial;
Lisp_Object shadow;
Lisp_Object entire_map;
int *indices;
int char_table_depth;
int keymap_p;
int mention_shadow;
{
Lisp_Object definition;
Lisp_Object tem2;
Lisp_Object elt_prefix = Qnil;
register int i;
Lisp_Object suppress;
Lisp_Object kludge;
int first = 1;
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
int from, to;
int complete_char;
int character;
int starting_i;
suppress = Qnil;
if (indices == 0)
indices = (int *) alloca (3 * sizeof (int));
definition = Qnil;
if (!keymap_p)
{
if (!NILP (prefix) && XFASTINT (Flength (prefix)) > 0)
{
Lisp_Object tem;
tem = Fkey_description (prefix, Qnil);
elt_prefix = concat2 (tem, build_string (" "));
}
prefix = Qnil;
}
kludge = Fmake_vector (make_number (1), Qnil);
GCPRO4 (elt_prefix, prefix, definition, kludge);
if (partial)
suppress = intern ("suppress-keymap");
if (CHAR_TABLE_P (vector))
{
if (char_table_depth == 0)
{
complete_char = 1;
from = 0;
to = CHAR_TABLE_ORDINARY_SLOTS;
}
else
{
if (char_table_depth >= 3)
error ("Too deep char table");
complete_char
= (CHARSET_VALID_P (indices[0])
&& ((CHARSET_DIMENSION (indices[0]) == 1
&& char_table_depth == 1)
|| char_table_depth == 2));
from = 32;
to = SUB_CHAR_TABLE_ORDINARY_SLOTS;
}
}
else
{
complete_char = 1;
from = 0;
to = XVECTOR (vector)->size;
}
for (i = from; i < to; i++)
{
int this_shadowed = 0;
QUIT;
if (CHAR_TABLE_P (vector))
{
if (char_table_depth == 0 && i >= CHAR_TABLE_SINGLE_BYTE_SLOTS)
complete_char = 0;
if (i >= CHAR_TABLE_SINGLE_BYTE_SLOTS
&& !CHARSET_DEFINED_P (i - 128))
continue;
definition
= get_keyelt (XCHAR_TABLE (vector)->contents[i], 0);
}
else
definition = get_keyelt (AREF (vector, i), 0);
if (NILP (definition)) continue;
if (SYMBOLP (definition) && partial)
{
Lisp_Object tem;
tem = Fget (definition, suppress);
if (!NILP (tem)) continue;
}
if (CHAR_TABLE_P (vector))
{
indices[char_table_depth] = i;
if (char_table_depth == 0)
{
character = i;
indices[0] = i - 128;
}
else if (complete_char)
{
character = MAKE_CHAR (indices[0], indices[1], indices[2]);
}
else
character = 0;
}
else
character = i;
ASET (kludge, 0, make_number (character));
if (!NILP (shadow) && complete_char)
{
Lisp_Object tem;
tem = shadow_lookup (shadow, kludge, Qt);
if (!NILP (tem))
{
if (mention_shadow)
this_shadowed = 1;
else
continue;
}
}
if (!NILP (entire_map) && complete_char)
{
Lisp_Object tem;
tem = Flookup_key (entire_map, kludge, Qt);
if (!EQ (tem, definition))
continue;
}
if (first)
{
if (char_table_depth == 0)
insert ("\n", 1);
first = 0;
}
if (char_table_depth > 0)
insert (" ", char_table_depth * 2);
if (!NILP (elt_prefix))
insert1 (elt_prefix);
if (SUB_CHAR_TABLE_P (vector))
{
if (complete_char)
insert_char (character);
else
{
char work[16];
sprintf (work, "(row %d)", i);
insert (work, strlen (work));
}
}
else if (CHAR_TABLE_P (vector))
{
if (complete_char)
insert1 (Fkey_description (kludge, prefix));
else
{
insert_string ("<");
tem2 = CHARSET_TABLE_INFO (i - 128, CHARSET_SHORT_NAME_IDX);
if (STRINGP (tem2))
insert_from_string (tem2, 0, 0, SCHARS (tem2),
SBYTES (tem2), 0);
else
insert ("?", 1);
insert (">", 1);
}
}
else
{
insert1 (Fkey_description (kludge, prefix));
}
if (CHAR_TABLE_P (vector) && SUB_CHAR_TABLE_P (definition))
{
insert ("\n", 1);
describe_vector (definition, prefix, args, elt_describer,
partial, shadow, entire_map,
indices, char_table_depth + 1, keymap_p,
mention_shadow);
continue;
}
starting_i = i;
if (CHAR_TABLE_P (vector))
{
int limit = to;
if (char_table_depth == 0)
limit = CHAR_TABLE_SINGLE_BYTE_SLOTS;
while (i + 1 < limit
&& (tem2 = get_keyelt (XCHAR_TABLE (vector)->contents[i + 1], 0),
!NILP (tem2))
&& !NILP (Fequal (tem2, definition)))
i++;
}
else
while (i + 1 < to
&& (tem2 = get_keyelt (AREF (vector, i + 1), 0),
!NILP (tem2))
&& !NILP (Fequal (tem2, definition)))
i++;
if (i != starting_i)
{
insert (" .. ", 4);
ASET (kludge, 0, make_number (i));
if (!NILP (elt_prefix))
insert1 (elt_prefix);
if (CHAR_TABLE_P (vector))
{
if (char_table_depth == 0)
{
insert1 (Fkey_description (kludge, prefix));
}
else if (complete_char)
{
indices[char_table_depth] = i;
character = MAKE_CHAR (indices[0], indices[1], indices[2]);
insert_char (character);
}
else
{
char work[16];
sprintf (work, "(row %d)", i);
insert (work, strlen (work));
}
}
else
{
insert1 (Fkey_description (kludge, prefix));
}
}
(*elt_describer) (definition, args);
if (this_shadowed)
{
SET_PT (PT - 1);
insert_string (" (binding currently shadowed)");
SET_PT (PT + 1);
}
}
if (CHAR_TABLE_P (vector) && !NILP (XCHAR_TABLE (vector)->defalt))
{
insert (" ", char_table_depth * 2);
insert_string ("<<default>>");
(*elt_describer) (XCHAR_TABLE (vector)->defalt, args);
}
UNGCPRO;
}
static Lisp_Object apropos_predicate;
static Lisp_Object apropos_accumulate;
static void
apropos_accum (symbol, string)
Lisp_Object symbol, string;
{
register Lisp_Object tem;
tem = Fstring_match (string, Fsymbol_name (symbol), Qnil);
if (!NILP (tem) && !NILP (apropos_predicate))
tem = call1 (apropos_predicate, symbol);
if (!NILP (tem))
apropos_accumulate = Fcons (symbol, apropos_accumulate);
}
DEFUN ("apropos-internal", Fapropos_internal, Sapropos_internal, 1, 2, 0,
doc: )
(regexp, predicate)
Lisp_Object regexp, predicate;
{
Lisp_Object tem;
CHECK_STRING (regexp);
apropos_predicate = predicate;
apropos_accumulate = Qnil;
map_obarray (Vobarray, apropos_accum, regexp);
tem = Fsort (apropos_accumulate, Qstring_lessp);
apropos_accumulate = Qnil;
apropos_predicate = Qnil;
return tem;
}
void
syms_of_keymap ()
{
Qkeymap = intern ("keymap");
staticpro (&Qkeymap);
staticpro (&apropos_predicate);
staticpro (&apropos_accumulate);
apropos_predicate = Qnil;
apropos_accumulate = Qnil;
Fput (Qkeymap, Qchar_table_extra_slots, make_number (0));
global_map = Fmake_keymap (Qnil);
Fset (intern ("global-map"), global_map);
current_global_map = global_map;
staticpro (&global_map);
staticpro (¤t_global_map);
meta_map = Fmake_keymap (Qnil);
Fset (intern ("esc-map"), meta_map);
Ffset (intern ("ESC-prefix"), meta_map);
control_x_map = Fmake_keymap (Qnil);
Fset (intern ("ctl-x-map"), control_x_map);
Ffset (intern ("Control-X-prefix"), control_x_map);
exclude_keys
= Fcons (Fcons (build_string ("DEL"), build_string ("\\d")),
Fcons (Fcons (build_string ("TAB"), build_string ("\\t")),
Fcons (Fcons (build_string ("RET"), build_string ("\\r")),
Fcons (Fcons (build_string ("ESC"), build_string ("\\e")),
Fcons (Fcons (build_string ("SPC"), build_string (" ")),
Qnil)))));
staticpro (&exclude_keys);
DEFVAR_LISP ("define-key-rebound-commands", &Vdefine_key_rebound_commands,
doc: );
Vdefine_key_rebound_commands = Qt;
DEFVAR_LISP ("minibuffer-local-map", &Vminibuffer_local_map,
doc: );
Vminibuffer_local_map = Fmake_sparse_keymap (Qnil);
DEFVAR_LISP ("minibuffer-local-ns-map", &Vminibuffer_local_ns_map,
doc: );
Vminibuffer_local_ns_map = Fmake_sparse_keymap (Qnil);
Fset_keymap_parent (Vminibuffer_local_ns_map, Vminibuffer_local_map);
DEFVAR_LISP ("minibuffer-local-completion-map", &Vminibuffer_local_completion_map,
doc: );
Vminibuffer_local_completion_map = Fmake_sparse_keymap (Qnil);
Fset_keymap_parent (Vminibuffer_local_completion_map, Vminibuffer_local_map);
DEFVAR_LISP ("minibuffer-local-filename-completion-map",
&Vminibuffer_local_filename_completion_map,
doc: );
Vminibuffer_local_filename_completion_map = Fmake_sparse_keymap (Qnil);
Fset_keymap_parent (Vminibuffer_local_filename_completion_map,
Vminibuffer_local_completion_map);
DEFVAR_LISP ("minibuffer-local-must-match-map", &Vminibuffer_local_must_match_map,
doc: );
Vminibuffer_local_must_match_map = Fmake_sparse_keymap (Qnil);
Fset_keymap_parent (Vminibuffer_local_must_match_map,
Vminibuffer_local_completion_map);
DEFVAR_LISP ("minibuffer-local-must-match-filename-map",
&Vminibuffer_local_must_match_filename_map,
doc: );
Vminibuffer_local_must_match_filename_map = Fmake_sparse_keymap (Qnil);
Fset_keymap_parent (Vminibuffer_local_must_match_filename_map,
Vminibuffer_local_must_match_map);
DEFVAR_LISP ("minor-mode-map-alist", &Vminor_mode_map_alist,
doc: );
Vminor_mode_map_alist = Qnil;
DEFVAR_LISP ("minor-mode-overriding-map-alist", &Vminor_mode_overriding_map_alist,
doc: );
Vminor_mode_overriding_map_alist = Qnil;
DEFVAR_LISP ("emulation-mode-map-alists", &Vemulation_mode_map_alists,
doc: );
Vemulation_mode_map_alists = Qnil;
DEFVAR_LISP ("function-key-map", &Vfunction_key_map,
doc: );
Vfunction_key_map = Fmake_sparse_keymap (Qnil);
DEFVAR_LISP ("key-translation-map", &Vkey_translation_map,
doc: );
Vkey_translation_map = Qnil;
staticpro (&Vmouse_events);
Vmouse_events = Fcons (intern ("menu-bar"),
Fcons (intern ("tool-bar"),
Fcons (intern ("header-line"),
Fcons (intern ("mode-line"),
Fcons (intern ("mouse-1"),
Fcons (intern ("mouse-2"),
Fcons (intern ("mouse-3"),
Fcons (intern ("mouse-4"),
Fcons (intern ("mouse-5"),
Qnil)))))))));
Qsingle_key_description = intern ("single-key-description");
staticpro (&Qsingle_key_description);
Qkey_description = intern ("key-description");
staticpro (&Qkey_description);
Qkeymapp = intern ("keymapp");
staticpro (&Qkeymapp);
Qnon_ascii = intern ("non-ascii");
staticpro (&Qnon_ascii);
Qmenu_item = intern ("menu-item");
staticpro (&Qmenu_item);
Qremap = intern ("remap");
staticpro (&Qremap);
command_remapping_vector = Fmake_vector (make_number (2), Qremap);
staticpro (&command_remapping_vector);
where_is_cache_keymaps = Qt;
where_is_cache = Qnil;
staticpro (&where_is_cache);
staticpro (&where_is_cache_keymaps);
defsubr (&Skeymapp);
defsubr (&Skeymap_parent);
defsubr (&Skeymap_prompt);
defsubr (&Sset_keymap_parent);
defsubr (&Smake_keymap);
defsubr (&Smake_sparse_keymap);
defsubr (&Smap_keymap);
defsubr (&Scopy_keymap);
defsubr (&Scommand_remapping);
defsubr (&Skey_binding);
defsubr (&Slocal_key_binding);
defsubr (&Sglobal_key_binding);
defsubr (&Sminor_mode_key_binding);
defsubr (&Sdefine_key);
defsubr (&Slookup_key);
defsubr (&Sdefine_prefix_command);
defsubr (&Suse_global_map);
defsubr (&Suse_local_map);
defsubr (&Scurrent_local_map);
defsubr (&Scurrent_global_map);
defsubr (&Scurrent_minor_mode_maps);
defsubr (&Scurrent_active_maps);
defsubr (&Saccessible_keymaps);
defsubr (&Skey_description);
defsubr (&Sdescribe_vector);
defsubr (&Ssingle_key_description);
defsubr (&Stext_char_description);
defsubr (&Swhere_is_internal);
defsubr (&Sdescribe_buffer_bindings);
defsubr (&Sapropos_internal);
}
void
keys_of_keymap ()
{
initial_define_key (global_map, 033, "ESC-prefix");
initial_define_key (global_map, Ctl('X'), "Control-X-prefix");
}