Reformatted.
[chise/xemacs-chise.git.1] / src / keymap.c
1 /* Manipulation of keymaps
2    Copyright (C) 1985, 1991-1995 Free Software Foundation, Inc.
3    Copyright (C) 1995 Board of Trustees, University of Illinois.
4    Copyright (C) 1995 Sun Microsystems, Inc.
5    Totally redesigned by jwz in 1991.
6
7 This file is part of XEmacs.
8
9 XEmacs is free software; you can redistribute it and/or modify it
10 under the terms of the GNU General Public License as published by the
11 Free Software Foundation; either version 2, or (at your option) any
12 later version.
13
14 XEmacs is distributed in the hope that it will be useful, but WITHOUT
15 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with XEmacs; see the file COPYING.  If not, write to
21 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 Boston, MA 02111-1307, USA.  */
23
24 /* Synched up with: Mule 2.0.  Not synched with FSF.  Substantially
25    different from FSF. */
26
27
28 #include <config.h>
29 #include "lisp.h"
30
31 #include "buffer.h"
32 #include "bytecode.h"
33 #include "console.h"
34 #include "elhash.h"
35 #include "events.h"
36 #include "frame.h"
37 #include "insdel.h"
38 #include "keymap.h"
39 #include "window.h"
40 #include "events-mod.h"
41
42 \f
43 /* A keymap contains six slots:
44
45    parents         Ordered list of keymaps to search after
46                    this one if no match is found.
47                    Keymaps can thus be arranged in a hierarchy.
48
49    table           A hash table, hashing keysyms to their bindings.
50                    It will be one of the following:
51
52                    -- a symbol, e.g. 'home
53                    -- a character, representing something printable
54                       (not ?\C-c meaning C-c, for instance)
55                    -- an integer representing a modifier combination
56
57    inverse_table   A hash table, hashing bindings to the list of keysyms
58                    in this keymap which are bound to them.  This is to make
59                    the Fwhere_is_internal() function be fast.  It needs to be
60                    fast because we want to be able to call it in realtime to
61                    update the keyboard-equivalents on the pulldown menus.
62                    Values of the table are either atoms (keysyms)
63                    or a dotted list of keysyms.
64
65    sub_maps_cache  An alist; for each entry in this keymap whose binding is
66                    a keymap (that is, Fkeymapp()) this alist associates that
67                    keysym with that binding.  This is used to optimize both
68                    Fwhere_is_internal() and Faccessible_keymaps().  This slot
69                    gets set to the symbol `t' every time a change is made to
70                    this keymap, causing it to be recomputed when next needed.
71
72    prompt          See `set-keymap-prompt'.
73
74    default_binding See `set-keymap-default-binding'.
75
76    Sequences of keys are stored in the obvious way: if the sequence of keys
77    "abc" was bound to some command `foo', the hierarchy would look like
78
79       keymap-1: associates "a" with keymap-2
80       keymap-2: associates "b" with keymap-3
81       keymap-3: associates "c" with foo
82
83    However, bucky bits ("modifiers" to the X-minded) are represented in the
84    keymap hierarchy as well. (This lets us use EQable objects as hash keys.)
85    Each combination of modifiers (e.g. control-hyper) gets its own submap
86    off of the main map.  The hash key for a modifier combination is
87    an integer, computed by MAKE_MODIFIER_HASH_KEY().
88
89    If the key `C-a' was bound to some command, the hierarchy would look like
90
91       keymap-1: associates the integer XEMACS_MOD_CONTROL with keymap-2
92       keymap-2: associates "a" with the command
93
94    Similarly, if the key `C-H-a' was bound to some command, the hierarchy
95    would look like
96
97       keymap-1: associates the integer (XEMACS_MOD_CONTROL | XEMACS_MOD_HYPER)
98                 with keymap-2
99       keymap-2: associates "a" with the command
100
101    Note that a special exception is made for the meta modifier, in order
102    to deal with ESC/meta lossage.  Any key combination containing the
103    meta modifier is first indexed off of the main map into the meta
104    submap (with hash key XEMACS_MOD_META) and then indexed off of the
105    meta submap with the meta modifier removed from the key combination.
106    For example, when associating a command with C-M-H-a, we'd have
107
108       keymap-1: associates the integer XEMACS_MOD_META with keymap-2
109       keymap-2: associates the integer (XEMACS_MOD_CONTROL | XEMACS_MOD_HYPER)
110                 with keymap-3
111       keymap-3: associates "a" with the command
112
113    Note that keymap-2 might have normal bindings in it; these would be
114    for key combinations containing only the meta modifier, such as
115    M-y or meta-backspace.
116
117    If the command that "a" was bound to in keymap-3 was itself a keymap,
118    then that would make the key "C-M-H-a" be a prefix character.
119
120    Note that this new model of keymaps takes much of the magic away from
121    the Escape key: the value of the variable `esc-map' is no longer indexed
122    in the `global-map' under the ESC key.  It's indexed under the integer
123    XEMACS_MOD_META.  This is not user-visible, however; none of the "bucky"
124    maps are.
125
126    There is a hack in Flookup_key() that makes (lookup-key global-map "\^[")
127    and (define-key some-random-map "\^[" my-esc-map) work as before, for
128    compatibility.
129
130    Since keymaps are opaque, the only way to extract information from them
131    is with the functions lookup-key, key-binding, local-key-binding, and
132    global-key-binding, which work just as before, and the new function
133    map-keymap, which is roughly analogous to maphash.
134
135    Note that map-keymap perpetuates the illusion that the "bucky" submaps
136    don't exist: if you map over a keymap with bucky submaps, it will also
137    map over those submaps.  It does not, however, map over other random
138    submaps of the keymap, just the bucky ones.
139
140    One implication of this is that when you map over `global-map', you will
141    also map over `esc-map'.  It is merely for compatibility that the esc-map
142    is accessible at all; I think that's a bad thing, since it blurs the
143    distinction between ESC and "meta" even more.  "M-x" is no more a two-
144    key sequence than "C-x" is.
145
146  */
147
148 struct Lisp_Keymap
149 {
150   struct lcrecord_header header;
151   Lisp_Object parents;          /* Keymaps to be searched after this one.
152                                    An ordered list */
153   Lisp_Object prompt;           /* Qnil or a string to print in the minibuffer
154                                    when reading from this keymap */
155   Lisp_Object table;            /* The contents of this keymap */
156   Lisp_Object inverse_table;    /* The inverse mapping of the above */
157   Lisp_Object default_binding;  /* Use this if no other binding is found
158                                    (this overrides parent maps and the
159                                    normal global-map lookup). */
160   Lisp_Object sub_maps_cache;   /* Cache of directly inferior keymaps;
161                                    This holds an alist, of the key and the
162                                    maps, or the modifier bit and the map.
163                                    If this is the symbol t, then the cache
164                                    needs to be recomputed. */
165   Lisp_Object name;             /* Just for debugging convenience */
166 };
167
168 #define MAKE_MODIFIER_HASH_KEY(modifier) make_int (modifier)
169 #define MODIFIER_HASH_KEY_BITS(x) (INTP (x) ? XINT (x) : 0)
170
171 \f
172
173 /* Actually allocate storage for these variables */
174
175 Lisp_Object Vcurrent_global_map; /* Always a keymap */
176
177 static Lisp_Object Vmouse_grabbed_buffer;
178
179 /* Alist of minor mode variables and keymaps.  */
180 static Lisp_Object Qminor_mode_map_alist;
181
182 static Lisp_Object Voverriding_local_map;
183
184 static Lisp_Object Vkey_translation_map;
185
186 static Lisp_Object Vvertical_divider_map;
187
188 /* This is incremented whenever a change is made to a keymap.  This is
189    so that things which care (such as the menubar code) can recompute
190    privately-cached data when the user has changed keybindings.
191  */
192 Fixnum keymap_tick;
193
194 /* Prefixing a key with this character is the same as sending a meta bit. */
195 Lisp_Object Vmeta_prefix_char;
196
197 Lisp_Object Qkeymapp;
198 Lisp_Object Vsingle_space_string;
199 Lisp_Object Qsuppress_keymap;
200 Lisp_Object Qmodeline_map;
201 Lisp_Object Qtoolbar_map;
202
203 EXFUN (Fkeymap_fullness, 1);
204 EXFUN (Fset_keymap_name, 2);
205 EXFUN (Fsingle_key_description, 1);
206
207 static void describe_command (Lisp_Object definition, Lisp_Object buffer);
208 static void describe_map (Lisp_Object keymap, Lisp_Object elt_prefix,
209                           void (*elt_describer) (Lisp_Object, Lisp_Object),
210                           int partial,
211                           Lisp_Object shadow,
212                           int mice_only_p,
213                           Lisp_Object buffer);
214 static Lisp_Object keymap_submaps (Lisp_Object keymap);
215
216 Lisp_Object Qcontrol, Qctrl, Qmeta, Qsuper, Qhyper, Qalt, Qshift;
217 Lisp_Object Qbutton0, Qbutton1, Qbutton2, Qbutton3;
218 Lisp_Object Qbutton4, Qbutton5, Qbutton6, Qbutton7;
219 Lisp_Object Qbutton0up, Qbutton1up, Qbutton2up, Qbutton3up;
220 Lisp_Object Qbutton4up, Qbutton5up, Qbutton6up, Qbutton7up;
221
222 Lisp_Object Qmenu_selection;
223 /* Emacs compatibility */
224 Lisp_Object Qdown_mouse_1, Qmouse_1;
225 Lisp_Object Qdown_mouse_2, Qmouse_2;
226 Lisp_Object Qdown_mouse_3, Qmouse_3;
227 Lisp_Object Qdown_mouse_4, Qmouse_4;
228 Lisp_Object Qdown_mouse_5, Qmouse_5;
229 Lisp_Object Qdown_mouse_6, Qmouse_6;
230 Lisp_Object Qdown_mouse_7, Qmouse_7;
231
232 /* Kludge kludge kludge */
233 Lisp_Object QLFD, QTAB, QRET, QESC, QDEL, QSPC, QBS;
234
235 \f
236 /************************************************************************/
237 /*                     The keymap Lisp object                           */
238 /************************************************************************/
239
240 static Lisp_Object
241 mark_keymap (Lisp_Object obj)
242 {
243   Lisp_Keymap *keymap = XKEYMAP (obj);
244   mark_object (keymap->parents);
245   mark_object (keymap->prompt);
246   mark_object (keymap->inverse_table);
247   mark_object (keymap->sub_maps_cache);
248   mark_object (keymap->default_binding);
249   mark_object (keymap->name);
250   return keymap->table;
251 }
252
253 static void
254 print_keymap (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
255 {
256   /* This function can GC */
257   Lisp_Keymap *keymap = XKEYMAP (obj);
258   char buf[200];
259   if (print_readably)
260     error ("printing unreadable object #<keymap 0x%x>", keymap->header.uid);
261   write_c_string ("#<keymap ", printcharfun);
262   if (!NILP (keymap->name))
263     {
264       print_internal (keymap->name, printcharfun, 1);
265       write_c_string (" ", printcharfun);
266     }
267   sprintf (buf, "size %ld 0x%x>",
268            (long) XINT (Fkeymap_fullness (obj)), keymap->header.uid);
269   write_c_string (buf, printcharfun);
270 }
271
272 static const struct lrecord_description keymap_description[] = {
273   { XD_LISP_OBJECT, offsetof (Lisp_Keymap, parents) },
274   { XD_LISP_OBJECT, offsetof (Lisp_Keymap, prompt) },
275   { XD_LISP_OBJECT, offsetof (Lisp_Keymap, table) },
276   { XD_LISP_OBJECT, offsetof (Lisp_Keymap, inverse_table) },
277   { XD_LISP_OBJECT, offsetof (Lisp_Keymap, default_binding) },
278   { XD_LISP_OBJECT, offsetof (Lisp_Keymap, sub_maps_cache) },
279   { XD_LISP_OBJECT, offsetof (Lisp_Keymap, name) },
280   { XD_END }
281 };
282
283 /* No need for keymap_equal #### Why not? */
284 DEFINE_LRECORD_IMPLEMENTATION ("keymap", keymap,
285                                mark_keymap, print_keymap, 0, 0, 0,
286                                keymap_description,
287                                Lisp_Keymap);
288 \f
289 /************************************************************************/
290 /*                Traversing keymaps and their parents                  */
291 /************************************************************************/
292
293 static Lisp_Object
294 traverse_keymaps (Lisp_Object start_keymap, Lisp_Object start_parents,
295                   Lisp_Object (*mapper) (Lisp_Object keymap, void *mapper_arg),
296                   void *mapper_arg)
297 {
298   /* This function can GC */
299   Lisp_Object keymap;
300   Lisp_Object tail = start_parents;
301   Lisp_Object malloc_sucks[10];
302   Lisp_Object malloc_bites = Qnil;
303   int stack_depth = 0;
304   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
305   GCPRO4 (*malloc_sucks, malloc_bites, start_keymap, tail);
306   gcpro1.nvars = 0;
307
308   start_keymap = get_keymap (start_keymap, 1, 1);
309   keymap = start_keymap;
310   /* Hack special-case parents at top-level */
311   tail = !NILP (tail) ? tail : XKEYMAP (keymap)->parents;
312
313   for (;;)
314     {
315       Lisp_Object result;
316
317       QUIT;
318       result = mapper (keymap, mapper_arg);
319       if (!NILP (result))
320         {
321           while (CONSP (malloc_bites))
322             {
323               Lisp_Cons *victim = XCONS (malloc_bites);
324               malloc_bites = victim->cdr;
325               free_cons (victim);
326             }
327           UNGCPRO;
328           return result;
329         }
330       if (NILP (tail))
331         {
332           if (stack_depth == 0)
333             {
334               UNGCPRO;
335               return Qnil;          /* Nothing found */
336             }
337           stack_depth--;
338           if (CONSP (malloc_bites))
339             {
340               Lisp_Cons *victim = XCONS (malloc_bites);
341               tail = victim->car;
342               malloc_bites = victim->cdr;
343               free_cons (victim);
344             }
345           else
346             {
347               tail = malloc_sucks[stack_depth];
348               gcpro1.nvars = stack_depth;
349             }
350           keymap = XCAR (tail);
351           tail = XCDR (tail);
352         }
353       else
354         {
355           Lisp_Object parents;
356
357           keymap = XCAR (tail);
358           tail = XCDR (tail);
359           parents = XKEYMAP (keymap)->parents;
360           if (!CONSP (parents))
361             ;
362           else if (NILP (tail))
363             /* Tail-recurse */
364             tail = parents;
365           else
366             {
367               if (CONSP (malloc_bites))
368                 malloc_bites = noseeum_cons (tail, malloc_bites);
369               else if (stack_depth < countof (malloc_sucks))
370                 {
371                   malloc_sucks[stack_depth++] = tail;
372                   gcpro1.nvars = stack_depth;
373                 }
374               else
375                 {
376                   /* *&@##[*&^$ C. @#[$*&@# Unix.  Losers all. */
377                   int i;
378                   for (i = 0, malloc_bites = Qnil;
379                        i < countof (malloc_sucks);
380                        i++)
381                     malloc_bites = noseeum_cons (malloc_sucks[i],
382                                                  malloc_bites);
383                   gcpro1.nvars = 0;
384                 }
385               tail = parents;
386             }
387         }
388       keymap = get_keymap (keymap, 1, 1);
389       if (EQ (keymap, start_keymap))
390         {
391           signal_simple_error ("Cyclic keymap indirection",
392                                start_keymap);
393         }
394     }
395 }
396
397 \f
398 /************************************************************************/
399 /*                     Some low-level functions                         */
400 /************************************************************************/
401
402 static int
403 bucky_sym_to_bucky_bit (Lisp_Object sym)
404 {
405   if (EQ (sym, Qcontrol)) return XEMACS_MOD_CONTROL;
406   if (EQ (sym, Qmeta))    return XEMACS_MOD_META;
407   if (EQ (sym, Qsuper))   return XEMACS_MOD_SUPER;
408   if (EQ (sym, Qhyper))   return XEMACS_MOD_HYPER;
409   if (EQ (sym, Qalt))     return XEMACS_MOD_ALT;
410   if (EQ (sym, Qsymbol))  return XEMACS_MOD_ALT; /* #### - reverse compat */
411   if (EQ (sym, Qshift))   return XEMACS_MOD_SHIFT;
412
413   return 0;
414 }
415
416 static Lisp_Object
417 control_meta_superify (Lisp_Object frob, int modifiers)
418 {
419   if (modifiers == 0)
420     return frob;
421   frob = Fcons (frob, Qnil);
422   if (modifiers & XEMACS_MOD_SHIFT)   frob = Fcons (Qshift,   frob);
423   if (modifiers & XEMACS_MOD_ALT)     frob = Fcons (Qalt,     frob);
424   if (modifiers & XEMACS_MOD_HYPER)   frob = Fcons (Qhyper,   frob);
425   if (modifiers & XEMACS_MOD_SUPER)   frob = Fcons (Qsuper,   frob);
426   if (modifiers & XEMACS_MOD_CONTROL) frob = Fcons (Qcontrol, frob);
427   if (modifiers & XEMACS_MOD_META)    frob = Fcons (Qmeta,    frob);
428   return frob;
429 }
430
431 static Lisp_Object
432 make_key_description (const struct key_data *key, int prettify)
433 {
434   Lisp_Object keysym = key->keysym;
435   int modifiers = key->modifiers;
436
437   if (prettify && CHARP (keysym))
438     {
439       /* This is a little slow, but (control a) is prettier than (control 65).
440          It's now ok to do this for digit-chars too, since we've fixed the
441          bug where \9 read as the integer 9 instead of as the symbol with
442          "9" as its name.
443        */
444       /* !!#### I'm not sure how correct this is. */
445       Bufbyte str [1 + MAX_EMCHAR_LEN];
446       Bytecount count = set_charptr_emchar (str, XCHAR (keysym));
447       str[count] = 0;
448       keysym = intern ((char *) str);
449     }
450   return control_meta_superify (keysym, modifiers);
451 }
452
453 \f
454 /************************************************************************/
455 /*                   Low-level keymap-store functions                   */
456 /************************************************************************/
457
458 static Lisp_Object
459 raw_lookup_key (Lisp_Object keymap,
460                 const struct key_data *raw_keys, int raw_keys_count,
461                 int keys_so_far, int accept_default);
462
463 /* Relies on caller to gc-protect args */
464 static Lisp_Object
465 keymap_lookup_directly (Lisp_Object keymap,
466                         Lisp_Object keysym, int modifiers)
467 {
468   Lisp_Keymap *k;
469
470   modifiers &= ~(XEMACS_MOD_BUTTON1 | XEMACS_MOD_BUTTON2 | XEMACS_MOD_BUTTON3
471                  | XEMACS_MOD_BUTTON4 | XEMACS_MOD_BUTTON5);
472   if ((modifiers & ~(XEMACS_MOD_CONTROL | XEMACS_MOD_META | XEMACS_MOD_SUPER
473                      | XEMACS_MOD_HYPER | XEMACS_MOD_ALT | XEMACS_MOD_SHIFT))
474       != 0)
475     ABORT ();
476
477   k = XKEYMAP (keymap);
478
479   /* If the keysym is a one-character symbol, use the char code instead. */
480   if (SYMBOLP (keysym) && string_char_length (XSYMBOL (keysym)->name) == 1)
481     {
482       Lisp_Object i_fart_on_gcc =
483         make_char (string_char (XSYMBOL (keysym)->name, 0));
484       keysym = i_fart_on_gcc;
485     }
486
487   if (modifiers & XEMACS_MOD_META)     /* Utterly hateful ESC lossage */
488     {
489       Lisp_Object submap = Fgethash (MAKE_MODIFIER_HASH_KEY (XEMACS_MOD_META),
490                                      k->table, Qnil);
491       if (NILP (submap))
492         return Qnil;
493       k = XKEYMAP (submap);
494       modifiers &= ~XEMACS_MOD_META;
495     }
496
497   if (modifiers != 0)
498     {
499       Lisp_Object submap = Fgethash (MAKE_MODIFIER_HASH_KEY (modifiers),
500                                      k->table, Qnil);
501       if (NILP (submap))
502         return Qnil;
503       k = XKEYMAP (submap);
504     }
505   return Fgethash (keysym, k->table, Qnil);
506 }
507
508 static void
509 keymap_store_inverse_internal (Lisp_Object inverse_table,
510                                Lisp_Object keysym,
511                                Lisp_Object value)
512 {
513   Lisp_Object keys = Fgethash (value, inverse_table, Qunbound);
514
515   if (UNBOUNDP (keys))
516     {
517       keys = keysym;
518       /* Don't cons this unless necessary */
519       /* keys = Fcons (keysym, Qnil); */
520       Fputhash (value, keys, inverse_table);
521     }
522   else if (!CONSP (keys))
523     {
524       /* Now it's necessary to cons */
525       keys = Fcons (keys, keysym);
526       Fputhash (value, keys, inverse_table);
527     }
528   else
529     {
530       while (CONSP (XCDR (keys)))
531         keys = XCDR (keys);
532       XCDR (keys) = Fcons (XCDR (keys), keysym);
533       /* No need to call puthash because we've destructively
534          modified the list tail in place */
535     }
536 }
537
538
539 static void
540 keymap_delete_inverse_internal (Lisp_Object inverse_table,
541                                 Lisp_Object keysym,
542                                 Lisp_Object value)
543 {
544   Lisp_Object keys = Fgethash (value, inverse_table, Qunbound);
545   Lisp_Object new_keys = keys;
546   Lisp_Object tail;
547   Lisp_Object *prev;
548
549   if (UNBOUNDP (keys))
550     ABORT ();
551
552   for (prev = &new_keys, tail = new_keys;
553        ;
554        prev = &(XCDR (tail)), tail = XCDR (tail))
555     {
556       if (EQ (tail, keysym))
557         {
558           *prev = Qnil;
559           break;
560         }
561       else if (EQ (keysym, XCAR (tail)))
562         {
563           *prev = XCDR (tail);
564           break;
565         }
566     }
567
568   if (NILP (new_keys))
569     Fremhash (value, inverse_table);
570   else if (!EQ (keys, new_keys))
571     /* Removed the first elt */
572     Fputhash (value, new_keys, inverse_table);
573   /* else the list's tail has been modified, so we don't need to
574      touch the hash table again (the pointer in there is ok).
575    */
576 }
577
578 /* Prevent luser from shooting herself in the foot using something like
579    (define-key ctl-x-4-map "p" global-map) */
580 static void
581 check_keymap_definition_loop (Lisp_Object def, Lisp_Keymap *to_keymap)
582 {
583   def = get_keymap (def, 0, 0);
584
585   if (KEYMAPP (def))
586     {
587       Lisp_Object maps;
588
589       if (XKEYMAP (def) == to_keymap)
590         signal_simple_error ("Cyclic keymap definition", def);
591
592       for (maps = keymap_submaps (def);
593            CONSP (maps);
594            maps = XCDR (maps))
595         check_keymap_definition_loop (XCDR (XCAR (maps)), to_keymap);
596     }
597 }
598
599 static void
600 keymap_store_internal (Lisp_Object keysym, Lisp_Keymap *keymap,
601                        Lisp_Object def)
602 {
603   Lisp_Object prev_def = Fgethash (keysym, keymap->table, Qnil);
604
605   if (EQ (prev_def, def))
606       return;
607
608   check_keymap_definition_loop (def, keymap);
609
610   if (!NILP (prev_def))
611     keymap_delete_inverse_internal (keymap->inverse_table,
612                                     keysym, prev_def);
613   if (NILP (def))
614     {
615       Fremhash (keysym, keymap->table);
616     }
617   else
618     {
619       Fputhash (keysym, def, keymap->table);
620       keymap_store_inverse_internal (keymap->inverse_table,
621                                      keysym, def);
622     }
623   keymap_tick++;
624 }
625
626
627 static Lisp_Object
628 create_bucky_submap (Lisp_Keymap *k, int modifiers,
629                      Lisp_Object parent_for_debugging_info)
630 {
631   Lisp_Object submap = Fmake_sparse_keymap (Qnil);
632   /* User won't see this, but it is nice for debugging Emacs */
633   XKEYMAP (submap)->name
634     = control_meta_superify (parent_for_debugging_info, modifiers);
635   /* Invalidate cache */
636   k->sub_maps_cache = Qt;
637   keymap_store_internal (MAKE_MODIFIER_HASH_KEY (modifiers), k, submap);
638   return submap;
639 }
640
641
642 /* Relies on caller to gc-protect keymap, keysym, value */
643 static void
644 keymap_store (Lisp_Object keymap, const struct key_data *key,
645               Lisp_Object value)
646 {
647   Lisp_Object keysym = key->keysym;
648   int modifiers = key->modifiers;
649   Lisp_Keymap *k = XKEYMAP (keymap);
650
651   modifiers &= ~(XEMACS_MOD_BUTTON1 | XEMACS_MOD_BUTTON2 | XEMACS_MOD_BUTTON3
652                  | XEMACS_MOD_BUTTON4 | XEMACS_MOD_BUTTON5);
653   assert ((modifiers & ~(XEMACS_MOD_CONTROL | XEMACS_MOD_META
654                          | XEMACS_MOD_SUPER | XEMACS_MOD_HYPER
655                          | XEMACS_MOD_ALT | XEMACS_MOD_SHIFT)) == 0);
656
657   /* If the keysym is a one-character symbol, use the char code instead. */
658   if (SYMBOLP (keysym) && string_char_length (XSYMBOL (keysym)->name) == 1)
659     keysym = make_char (string_char (XSYMBOL (keysym)->name, 0));
660
661   if (modifiers & XEMACS_MOD_META)     /* Utterly hateful ESC lossage */
662     {
663       Lisp_Object submap = Fgethash (MAKE_MODIFIER_HASH_KEY (XEMACS_MOD_META),
664                                      k->table, Qnil);
665       if (NILP (submap))
666         submap = create_bucky_submap (k, XEMACS_MOD_META, keymap);
667       k = XKEYMAP (submap);
668       modifiers &= ~XEMACS_MOD_META;
669     }
670
671   if (modifiers != 0)
672     {
673       Lisp_Object submap = Fgethash (MAKE_MODIFIER_HASH_KEY (modifiers),
674                                      k->table, Qnil);
675       if (NILP (submap))
676         submap = create_bucky_submap (k, modifiers, keymap);
677       k = XKEYMAP (submap);
678     }
679   k->sub_maps_cache = Qt; /* Invalidate cache */
680   keymap_store_internal (keysym, k, value);
681 }
682
683 \f
684 /************************************************************************/
685 /*                   Listing the submaps of a keymap                    */
686 /************************************************************************/
687
688 struct keymap_submaps_closure
689 {
690   Lisp_Object *result_locative;
691 };
692
693 static int
694 keymap_submaps_mapper_0 (Lisp_Object key, Lisp_Object value,
695                          void *keymap_submaps_closure)
696 {
697   /* This function can GC */
698   /* Perform any autoloads, etc */
699   Fkeymapp (value);
700   return 0;
701 }
702
703 static int
704 keymap_submaps_mapper (Lisp_Object key, Lisp_Object value,
705                        void *keymap_submaps_closure)
706 {
707   /* This function can GC */
708   Lisp_Object *result_locative;
709   struct keymap_submaps_closure *cl =
710     (struct keymap_submaps_closure *) keymap_submaps_closure;
711   result_locative = cl->result_locative;
712
713   if (!NILP (Fkeymapp (value)))
714     *result_locative = Fcons (Fcons (key, value), *result_locative);
715   return 0;
716 }
717
718 static int map_keymap_sort_predicate (Lisp_Object obj1, Lisp_Object obj2,
719                                       Lisp_Object pred);
720
721 static Lisp_Object
722 keymap_submaps (Lisp_Object keymap)
723 {
724   /* This function can GC */
725   Lisp_Keymap *k = XKEYMAP (keymap);
726
727   if (EQ (k->sub_maps_cache, Qt)) /* Unknown */
728     {
729       Lisp_Object result = Qnil;
730       struct gcpro gcpro1, gcpro2;
731       struct keymap_submaps_closure keymap_submaps_closure;
732
733       GCPRO2 (keymap, result);
734       keymap_submaps_closure.result_locative = &result;
735       /* Do this first pass to touch (and load) any autoloaded maps */
736       elisp_maphash (keymap_submaps_mapper_0, k->table,
737                      &keymap_submaps_closure);
738       result = Qnil;
739       elisp_maphash (keymap_submaps_mapper, k->table,
740                      &keymap_submaps_closure);
741       /* keep it sorted so that the result of accessible-keymaps is ordered */
742       k->sub_maps_cache = list_sort (result,
743                                      Qnil,
744                                      map_keymap_sort_predicate);
745       UNGCPRO;
746     }
747   return k->sub_maps_cache;
748 }
749
750 \f
751 /************************************************************************/
752 /*                    Basic operations on keymaps                       */
753 /************************************************************************/
754
755 static Lisp_Object
756 make_keymap (size_t size)
757 {
758   Lisp_Object result;
759   Lisp_Keymap *keymap = alloc_lcrecord_type (Lisp_Keymap, &lrecord_keymap);
760
761   XSETKEYMAP (result, keymap);
762
763   keymap->parents         = Qnil;
764   keymap->prompt          = Qnil;
765   keymap->table           = Qnil;
766   keymap->inverse_table   = Qnil;
767   keymap->default_binding = Qnil;
768   keymap->sub_maps_cache  = Qnil; /* No possible submaps */
769   keymap->name            = Qnil;
770
771   if (size != 0) /* hack for copy-keymap */
772     {
773       keymap->table =
774         make_lisp_hash_table (size, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
775       /* Inverse table is often less dense because of duplicate key-bindings.
776          If not, it will grow anyway. */
777       keymap->inverse_table =
778         make_lisp_hash_table (size * 3 / 4, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
779     }
780   return result;
781 }
782
783 DEFUN ("make-keymap", Fmake_keymap, 0, 1, 0, /*
784 Construct and return a new keymap object.
785 All entries in it are nil, meaning "command undefined".
786
787 Optional argument NAME specifies a name to assign to the keymap,
788 as in `set-keymap-name'.  This name is only a debugging convenience;
789 it is not used except when printing the keymap.
790 */
791        (name))
792 {
793   Lisp_Object keymap = make_keymap (60);
794   if (!NILP (name))
795     Fset_keymap_name (keymap, name);
796   return keymap;
797 }
798
799 DEFUN ("make-sparse-keymap", Fmake_sparse_keymap, 0, 1, 0, /*
800 Construct and return a new keymap object.
801 All entries in it are nil, meaning "command undefined".  The only
802 difference between this function and `make-keymap' is that this function
803 returns a "smaller" keymap (one that is expected to contain fewer
804 entries).  As keymaps dynamically resize, this distinction is not great.
805
806 Optional argument NAME specifies a name to assign to the keymap,
807 as in `set-keymap-name'.  This name is only a debugging convenience;
808 it is not used except when printing the keymap.
809 */
810        (name))
811 {
812   Lisp_Object keymap = make_keymap (8);
813   if (!NILP (name))
814     Fset_keymap_name (keymap, name);
815   return keymap;
816 }
817
818 DEFUN ("keymap-parents", Fkeymap_parents, 1, 1, 0, /*
819 Return the `parent' keymaps of KEYMAP, or nil.
820 The parents of a keymap are searched for keybindings when a key sequence
821 isn't bound in this one.  `(current-global-map)' is the default parent
822 of all keymaps.
823 */
824        (keymap))
825 {
826   keymap = get_keymap (keymap, 1, 1);
827   return Fcopy_sequence (XKEYMAP (keymap)->parents);
828 }
829
830
831
832 static Lisp_Object
833 traverse_keymaps_noop (Lisp_Object keymap, void *arg)
834 {
835   return Qnil;
836 }
837
838 DEFUN ("set-keymap-parents", Fset_keymap_parents, 2, 2, 0, /*
839 Set the `parent' keymaps of KEYMAP to PARENTS.
840 The parents of a keymap are searched for keybindings when a key sequence
841 isn't bound in this one.  `(current-global-map)' is the default parent
842 of all keymaps.
843 */
844        (keymap, parents))
845 {
846   /* This function can GC */
847   Lisp_Object k;
848   struct gcpro gcpro1, gcpro2;
849
850   GCPRO2 (keymap, parents);
851   keymap = get_keymap (keymap, 1, 1);
852
853   if (KEYMAPP (parents))        /* backwards-compatibility */
854     parents = list1 (parents);
855   if (!NILP (parents))
856     {
857       Lisp_Object tail = parents;
858       while (!NILP (tail))
859         {
860           QUIT;
861           CHECK_CONS (tail);
862           k = XCAR (tail);
863           /* Require that it be an actual keymap object, rather than a symbol
864              with a (crockish) symbol-function which is a keymap */
865           CHECK_KEYMAP (k); /* get_keymap (k, 1, 1); */
866           tail = XCDR (tail);
867         }
868     }
869
870   /* Check for circularities */
871   traverse_keymaps (keymap, parents, traverse_keymaps_noop, 0);
872   keymap_tick++;
873   XKEYMAP (keymap)->parents = Fcopy_sequence (parents);
874   UNGCPRO;
875   return parents;
876 }
877
878 DEFUN ("set-keymap-name", Fset_keymap_name, 2, 2, 0, /*
879 Set the `name' of the KEYMAP to NEW-NAME.
880 The name is only a debugging convenience; it is not used except
881 when printing the keymap.
882 */
883        (keymap, new_name))
884 {
885   keymap = get_keymap (keymap, 1, 1);
886
887   XKEYMAP (keymap)->name = new_name;
888   return new_name;
889 }
890
891 DEFUN ("keymap-name", Fkeymap_name, 1, 1, 0, /*
892 Return the `name' of KEYMAP.
893 The name is only a debugging convenience; it is not used except
894 when printing the keymap.
895 */
896        (keymap))
897 {
898   keymap = get_keymap (keymap, 1, 1);
899
900   return XKEYMAP (keymap)->name;
901 }
902
903 DEFUN ("set-keymap-prompt", Fset_keymap_prompt, 2, 2, 0, /*
904 Set the `prompt' of KEYMAP to string NEW-PROMPT, or `nil'
905 if no prompt is desired.  The prompt is shown in the echo-area
906 when reading a key-sequence to be looked-up in this keymap.
907 */
908        (keymap, new_prompt))
909 {
910   keymap = get_keymap (keymap, 1, 1);
911
912   if (!NILP (new_prompt))
913     CHECK_STRING (new_prompt);
914
915   XKEYMAP (keymap)->prompt = new_prompt;
916   return new_prompt;
917 }
918
919 static Lisp_Object
920 keymap_prompt_mapper (Lisp_Object keymap, void *arg)
921 {
922   return XKEYMAP (keymap)->prompt;
923 }
924
925
926 DEFUN ("keymap-prompt", Fkeymap_prompt, 1, 2, 0, /*
927 Return the `prompt' of KEYMAP.
928 If non-nil, the prompt is shown in the echo-area
929 when reading a key-sequence to be looked-up in this keymap.
930 */
931        (keymap, use_inherited))
932 {
933   /* This function can GC */
934   Lisp_Object prompt;
935
936   keymap = get_keymap (keymap, 1, 1);
937   prompt = XKEYMAP (keymap)->prompt;
938   if (!NILP (prompt) || NILP (use_inherited))
939     return prompt;
940   else
941     return traverse_keymaps (keymap, Qnil, keymap_prompt_mapper, 0);
942 }
943
944 DEFUN ("set-keymap-default-binding", Fset_keymap_default_binding, 2, 2, 0, /*
945 Sets the default binding of KEYMAP to COMMAND, or `nil'
946 if no default is desired.  The default-binding is returned when
947 no other binding for a key-sequence is found in the keymap.
948 If a keymap has a non-nil default-binding, neither the keymap's
949 parents nor the current global map are searched for key bindings.
950 */
951        (keymap, command))
952 {
953   /* This function can GC */
954   keymap = get_keymap (keymap, 1, 1);
955
956   XKEYMAP (keymap)->default_binding = command;
957   return command;
958 }
959
960 DEFUN ("keymap-default-binding", Fkeymap_default_binding, 1, 1, 0, /*
961 Return the default binding of KEYMAP, or `nil' if it has none.
962 The default-binding is returned when no other binding for a key-sequence
963 is found in the keymap.
964 If a keymap has a non-nil default-binding, neither the keymap's
965 parents nor the current global map are searched for key bindings.
966 */
967        (keymap))
968 {
969   /* This function can GC */
970   keymap = get_keymap (keymap, 1, 1);
971   return XKEYMAP (keymap)->default_binding;
972 }
973
974 DEFUN ("keymapp", Fkeymapp, 1, 1, 0, /*
975 Return t if OBJECT is a keymap object.
976 The keymap may be autoloaded first if necessary.
977 */
978        (object))
979 {
980   /* This function can GC */
981   return KEYMAPP (get_keymap (object, 0, 0)) ? Qt : Qnil;
982 }
983
984 /* Check that OBJECT is a keymap (after dereferencing through any
985    symbols).  If it is, return it.
986
987    If AUTOLOAD is non-zero and OBJECT is a symbol whose function value
988    is an autoload form, do the autoload and try again.
989    If AUTOLOAD is nonzero, callers must assume GC is possible.
990
991    ERRORP controls how we respond if OBJECT isn't a keymap.
992    If ERRORP is non-zero, signal an error; otherwise, just return Qnil.
993
994    Note that most of the time, we don't want to pursue autoloads.
995    Functions like Faccessible_keymaps which scan entire keymap trees
996    shouldn't load every autoloaded keymap.  I'm not sure about this,
997    but it seems to me that only read_key_sequence, Flookup_key, and
998    Fdefine_key should cause keymaps to be autoloaded.  */
999
1000 Lisp_Object
1001 get_keymap (Lisp_Object object, int errorp, int autoload)
1002 {
1003   /* This function can GC */
1004   while (1)
1005     {
1006       Lisp_Object tem = indirect_function (object, 0);
1007
1008       if (KEYMAPP (tem))
1009         return tem;
1010       /* Should we do an autoload?  */
1011       else if (autoload
1012                /* (autoload "filename" doc nil keymap) */
1013                && SYMBOLP (object)
1014                && CONSP (tem)
1015                && EQ (XCAR (tem), Qautoload)
1016                && EQ (Fcar (Fcdr (Fcdr (Fcdr (Fcdr (tem))))), Qkeymap))
1017         {
1018           /* do_autoload GCPROs both arguments */
1019           do_autoload (tem, object);
1020         }
1021       else if (errorp)
1022         object = wrong_type_argument (Qkeymapp, object);
1023       else
1024         return Qnil;
1025     }
1026 }
1027
1028 /* Given OBJECT which was found in a slot in a keymap,
1029    trace indirect definitions to get the actual definition of that slot.
1030    An indirect definition is a list of the form
1031    (KEYMAP . INDEX), where KEYMAP is a keymap or a symbol defined as one
1032    and INDEX is an ASCII code, or a cons of (KEYSYM . MODIFIERS).
1033  */
1034 static Lisp_Object
1035 get_keyelt (Lisp_Object object, int accept_default)
1036 {
1037   /* This function can GC */
1038   Lisp_Object map;
1039
1040  tail_recurse:
1041   if (!CONSP (object))
1042     return object;
1043
1044   {
1045     struct gcpro gcpro1;
1046     GCPRO1 (object);
1047     map = XCAR (object);
1048     map = get_keymap (map, 0, 1);
1049     UNGCPRO;
1050   }
1051   /* If the contents are (KEYMAP . ELEMENT), go indirect.  */
1052   if (!NILP (map))
1053     {
1054       Lisp_Object idx = Fcdr (object);
1055       struct key_data indirection;
1056       if (CHARP (idx))
1057         {
1058           Lisp_Event event;
1059           event.event_type = empty_event;
1060           character_to_event (XCHAR (idx), &event,
1061                               XCONSOLE (Vselected_console), 0, 0);
1062           indirection = event.event.key;
1063         }
1064       else if (CONSP (idx))
1065         {
1066           if (!INTP (XCDR (idx)))
1067             return Qnil;
1068           indirection.keysym = XCAR (idx);
1069           indirection.modifiers = (unsigned char) XINT (XCDR (idx));
1070         }
1071       else if (SYMBOLP (idx))
1072         {
1073           indirection.keysym = idx;
1074           indirection.modifiers = 0;
1075         }
1076       else
1077         {
1078           /* Random junk */
1079           return Qnil;
1080         }
1081       return raw_lookup_key (map, &indirection, 1, 0, accept_default);
1082     }
1083   else if (STRINGP (XCAR (object)))
1084     {
1085       /* If the keymap contents looks like (STRING . DEFN),
1086          use DEFN.
1087          Keymap alist elements like (CHAR MENUSTRING . DEFN)
1088          will be used by HierarKey menus.  */
1089       object = XCDR (object);
1090       goto tail_recurse;
1091     }
1092   else
1093     {
1094       /* Anything else is really the value.  */
1095       return object;
1096     }
1097 }
1098
1099 static Lisp_Object
1100 keymap_lookup_1 (Lisp_Object keymap, const struct key_data *key,
1101                  int accept_default)
1102 {
1103   /* This function can GC */
1104   return get_keyelt (keymap_lookup_directly (keymap,
1105                                              key->keysym, key->modifiers),
1106                      accept_default);
1107 }
1108
1109 \f
1110 /************************************************************************/
1111 /*                          Copying keymaps                             */
1112 /************************************************************************/
1113
1114 struct copy_keymap_inverse_closure
1115 {
1116   Lisp_Object inverse_table;
1117 };
1118
1119 static int
1120 copy_keymap_inverse_mapper (Lisp_Object key, Lisp_Object value,
1121                             void *copy_keymap_inverse_closure)
1122 {
1123   struct copy_keymap_inverse_closure *closure =
1124     (struct copy_keymap_inverse_closure *) copy_keymap_inverse_closure;
1125
1126   /* copy-sequence deals with dotted lists. */
1127   if (CONSP (value))
1128     value = Fcopy_list (value);
1129   Fputhash (key, value, closure->inverse_table);
1130
1131   return 0;
1132 }
1133
1134
1135 static Lisp_Object
1136 copy_keymap_internal (Lisp_Keymap *keymap)
1137 {
1138   Lisp_Object nkm = make_keymap (0);
1139   Lisp_Keymap *new_keymap = XKEYMAP (nkm);
1140   struct copy_keymap_inverse_closure copy_keymap_inverse_closure;
1141   copy_keymap_inverse_closure.inverse_table = keymap->inverse_table;
1142
1143   new_keymap->parents        = Fcopy_sequence (keymap->parents);
1144   new_keymap->sub_maps_cache = Qnil; /* No submaps */
1145   new_keymap->table          = Fcopy_hash_table (keymap->table);
1146   new_keymap->inverse_table  = Fcopy_hash_table (keymap->inverse_table);
1147   new_keymap->default_binding = keymap->default_binding;
1148   /* After copying the inverse map, we need to copy the conses which
1149      are its values, lest they be shared by the copy, and mangled.
1150    */
1151   elisp_maphash (copy_keymap_inverse_mapper, keymap->inverse_table,
1152                  &copy_keymap_inverse_closure);
1153   return nkm;
1154 }
1155
1156
1157 static Lisp_Object copy_keymap (Lisp_Object keymap);
1158
1159 struct copy_keymap_closure
1160 {
1161   Lisp_Keymap *self;
1162 };
1163
1164 static int
1165 copy_keymap_mapper (Lisp_Object key, Lisp_Object value,
1166                     void *copy_keymap_closure)
1167 {
1168   /* This function can GC */
1169   struct copy_keymap_closure *closure =
1170     (struct copy_keymap_closure *) copy_keymap_closure;
1171
1172   /* When we encounter a keymap which is indirected through a
1173      symbol, we need to copy the sub-map.  In v18, the form
1174        (lookup-key (copy-keymap global-map) "\C-x")
1175      returned a new keymap, not the symbol 'Control-X-prefix.
1176    */
1177   value = get_keymap (value, 0, 1); /* #### autoload GC-safe here? */
1178   if (KEYMAPP (value))
1179     keymap_store_internal (key, closure->self,
1180                            copy_keymap (value));
1181   return 0;
1182 }
1183
1184 static Lisp_Object
1185 copy_keymap (Lisp_Object keymap)
1186 {
1187   /* This function can GC */
1188   struct copy_keymap_closure copy_keymap_closure;
1189
1190   keymap = copy_keymap_internal (XKEYMAP (keymap));
1191   copy_keymap_closure.self = XKEYMAP (keymap);
1192   elisp_maphash (copy_keymap_mapper,
1193                  XKEYMAP (keymap)->table,
1194                  &copy_keymap_closure);
1195   return keymap;
1196 }
1197
1198 DEFUN ("copy-keymap", Fcopy_keymap, 1, 1, 0, /*
1199 Return a copy of the keymap KEYMAP.
1200 The copy starts out with the same definitions of KEYMAP,
1201 but changing either the copy or KEYMAP does not affect the other.
1202 Any key definitions that are subkeymaps are recursively copied.
1203 */
1204        (keymap))
1205 {
1206   /* This function can GC */
1207   keymap = get_keymap (keymap, 1, 1);
1208   return copy_keymap (keymap);
1209 }
1210
1211 \f
1212 static int
1213 keymap_fullness (Lisp_Object keymap)
1214 {
1215   /* This function can GC */
1216   int fullness;
1217   Lisp_Object sub_maps;
1218   struct gcpro gcpro1, gcpro2;
1219
1220   keymap = get_keymap (keymap, 1, 1);
1221   fullness = XINT (Fhash_table_count (XKEYMAP (keymap)->table));
1222   GCPRO2 (keymap, sub_maps);
1223   for (sub_maps = keymap_submaps (keymap);
1224        !NILP (sub_maps);
1225        sub_maps = XCDR (sub_maps))
1226     {
1227       if (MODIFIER_HASH_KEY_BITS (XCAR (XCAR (sub_maps))) != 0)
1228         {
1229           Lisp_Object bucky_map = XCDR (XCAR (sub_maps));
1230           fullness--; /* don't count bucky maps themselves. */
1231           fullness += keymap_fullness (bucky_map);
1232         }
1233     }
1234   UNGCPRO;
1235   return fullness;
1236 }
1237
1238 DEFUN ("keymap-fullness", Fkeymap_fullness, 1, 1, 0, /*
1239 Return the number of bindings in the keymap.
1240 */
1241        (keymap))
1242 {
1243   /* This function can GC */
1244   return make_int (keymap_fullness (get_keymap (keymap, 1, 1)));
1245 }
1246
1247 \f
1248 /************************************************************************/
1249 /*                        Defining keys in keymaps                      */
1250 /************************************************************************/
1251
1252 /* Given a keysym (should be a symbol, int, char), make sure it's valid
1253    and perform any necessary canonicalization. */
1254
1255 static void
1256 define_key_check_and_coerce_keysym (Lisp_Object spec,
1257                                     Lisp_Object *keysym,
1258                                     int modifiers)
1259 {
1260   /* Now, check and massage the trailing keysym specifier. */
1261   if (SYMBOLP (*keysym))
1262     {
1263       if (string_char_length (XSYMBOL (*keysym)->name) == 1)
1264         {
1265           Lisp_Object ream_gcc_up_the_ass =
1266             make_char (string_char (XSYMBOL (*keysym)->name, 0));
1267           *keysym = ream_gcc_up_the_ass;
1268           goto fixnum_keysym;
1269         }
1270     }
1271   else if (CHAR_OR_CHAR_INTP (*keysym))
1272     {
1273       CHECK_CHAR_COERCE_INT (*keysym);
1274     fixnum_keysym:
1275       if (XCHAR (*keysym) < ' '
1276           /* || (XCHAR (*keysym) >= 128 && XCHAR (*keysym) < 160) */)
1277         /* yuck!  Can't make the above restriction; too many compatibility
1278            problems ... */
1279         signal_simple_error ("keysym char must be printable", *keysym);
1280       /* #### This bites!  I want to be able to write (control shift a) */
1281       if (modifiers & XEMACS_MOD_SHIFT)
1282         signal_simple_error
1283           ("The `shift' modifier may not be applied to ASCII keysyms",
1284            spec);
1285     }
1286   else
1287     {
1288       signal_simple_error ("Unknown keysym specifier", *keysym);
1289     }
1290
1291   if (SYMBOLP (*keysym))
1292     {
1293       char *name = (char *) string_data (XSYMBOL (*keysym)->name);
1294
1295       /* FSFmacs uses symbols with the printed representation of keysyms in
1296          their names, like 'M-x, and we use the syntax '(meta x).  So, to avoid
1297          confusion, notice the M-x syntax and signal an error - because
1298          otherwise it would be interpreted as a regular keysym, and would even
1299          show up in the list-buffers output, causing confusion to the naive.
1300
1301          We can get away with this because none of the X keysym names contain
1302          a hyphen (some contain underscore, however).
1303
1304          It might be useful to reject keysyms which are not x-valid-keysym-
1305          name-p, but that would interfere with various tricks we do to
1306          sanitize the Sun keyboards, and would make it trickier to
1307          conditionalize a .emacs file for multiple X servers.
1308          */
1309       if (((int) strlen (name) >= 2 && name[1] == '-')
1310 #if 1
1311           ||
1312           /* Ok, this is a bit more dubious - prevent people from doing things
1313              like (global-set-key 'RET 'something) because that will have the
1314              same problem as above.  (Gag!)  Maybe we should just silently
1315              accept these as aliases for the "real" names?
1316              */
1317           (string_length (XSYMBOL (*keysym)->name) <= 3 &&
1318            (!strcmp (name, "LFD") ||
1319             !strcmp (name, "TAB") ||
1320             !strcmp (name, "RET") ||
1321             !strcmp (name, "ESC") ||
1322             !strcmp (name, "DEL") ||
1323             !strcmp (name, "SPC") ||
1324             !strcmp (name, "BS")))
1325 #endif /* unused */
1326           )
1327         signal_simple_error
1328           ("Invalid (FSF Emacs) key format (see doc of define-key)",
1329            *keysym);
1330
1331       /* #### Ok, this is a bit more dubious - make people not lose if they
1332          do things like (global-set-key 'RET 'something) because that would
1333          otherwise have the same problem as above.  (Gag!)  We silently
1334          accept these as aliases for the "real" names.
1335          */
1336       else if (!strncmp(name, "kp_", 3)) {
1337         /* Likewise, the obsolete keysym binding of kp_.* should not lose. */
1338         char temp[50];
1339
1340         strncpy(temp, name, sizeof (temp));
1341         temp[sizeof (temp) - 1] = '\0';
1342         temp[2] = '-';
1343         *keysym = Fintern_soft(make_string((Bufbyte *)temp,
1344                                            strlen(temp)),
1345                                Qnil);
1346       } else if (EQ (*keysym, QLFD))
1347         *keysym = QKlinefeed;
1348       else if (EQ (*keysym, QTAB))
1349         *keysym = QKtab;
1350       else if (EQ (*keysym, QRET))
1351         *keysym = QKreturn;
1352       else if (EQ (*keysym, QESC))
1353         *keysym = QKescape;
1354       else if (EQ (*keysym, QDEL))
1355         *keysym = QKdelete;
1356       else if (EQ (*keysym, QSPC))
1357         *keysym = QKspace;
1358       else if (EQ (*keysym, QBS))
1359         *keysym = QKbackspace;
1360       /* Emacs compatibility */
1361       else if (EQ(*keysym, Qdown_mouse_1))
1362         *keysym = Qbutton1;
1363       else if (EQ(*keysym, Qdown_mouse_2))
1364         *keysym = Qbutton2;
1365       else if (EQ(*keysym, Qdown_mouse_3))
1366         *keysym = Qbutton3;
1367       else if (EQ(*keysym, Qdown_mouse_4))
1368         *keysym = Qbutton4;
1369       else if (EQ(*keysym, Qdown_mouse_5))
1370         *keysym = Qbutton5;
1371       else if (EQ(*keysym, Qdown_mouse_6))
1372         *keysym = Qbutton6;
1373       else if (EQ(*keysym, Qdown_mouse_7))
1374         *keysym = Qbutton7;
1375       else if (EQ(*keysym, Qmouse_1))
1376         *keysym = Qbutton1up;
1377       else if (EQ(*keysym, Qmouse_2))
1378         *keysym = Qbutton2up;
1379       else if (EQ(*keysym, Qmouse_3))
1380         *keysym = Qbutton3up;
1381       else if (EQ(*keysym, Qmouse_4))
1382         *keysym = Qbutton4up;
1383       else if (EQ(*keysym, Qmouse_5))
1384         *keysym = Qbutton5up;
1385       else if (EQ(*keysym, Qmouse_6))
1386         *keysym = Qbutton6up;
1387       else if (EQ(*keysym, Qmouse_7))
1388         *keysym = Qbutton7up;
1389     }
1390 }
1391
1392
1393 /* Given any kind of key-specifier, return a keysym and modifier mask.
1394    Proper canonicalization is performed:
1395
1396    -- integers are converted into the equivalent characters.
1397    -- one-character strings are converted into the equivalent characters.
1398  */
1399
1400 static void
1401 define_key_parser (Lisp_Object spec, struct key_data *returned_value)
1402 {
1403   if (CHAR_OR_CHAR_INTP (spec))
1404     {
1405       Lisp_Event event;
1406       event.event_type = empty_event;
1407       character_to_event (XCHAR_OR_CHAR_INT (spec), &event,
1408                           XCONSOLE (Vselected_console), 0, 0);
1409       returned_value->keysym    = event.event.key.keysym;
1410       returned_value->modifiers = event.event.key.modifiers;
1411     }
1412   else if (EVENTP (spec))
1413     {
1414       switch (XEVENT (spec)->event_type)
1415         {
1416         case key_press_event:
1417           {
1418             returned_value->keysym    = XEVENT (spec)->event.key.keysym;
1419             returned_value->modifiers = XEVENT (spec)->event.key.modifiers;
1420             break;
1421           }
1422         case button_press_event:
1423         case button_release_event:
1424           {
1425             int down = (XEVENT (spec)->event_type == button_press_event);
1426             switch (XEVENT (spec)->event.button.button)
1427               {
1428               case 1:
1429                 returned_value->keysym = (down ? Qbutton1 : Qbutton1up); break;
1430               case 2:
1431                 returned_value->keysym = (down ? Qbutton2 : Qbutton2up); break;
1432               case 3:
1433                 returned_value->keysym = (down ? Qbutton3 : Qbutton3up); break;
1434               case 4:
1435                 returned_value->keysym = (down ? Qbutton4 : Qbutton4up); break;
1436               case 5:
1437                 returned_value->keysym = (down ? Qbutton5 : Qbutton5up); break;
1438               case 6:
1439                 returned_value->keysym = (down ? Qbutton6 : Qbutton6up); break;
1440               case 7:
1441                 returned_value->keysym = (down ? Qbutton7 : Qbutton7up); break;
1442               default:
1443                 returned_value->keysym = (down ? Qbutton0 : Qbutton0up); break;
1444               }
1445             returned_value->modifiers = XEVENT (spec)->event.button.modifiers;
1446             break;
1447           }
1448         default:
1449           signal_error (Qwrong_type_argument,
1450                         list2 (build_translated_string
1451                                ("unable to bind this type of event"),
1452                                spec));
1453         }
1454     }
1455   else if (SYMBOLP (spec))
1456     {
1457       /* Be nice, allow = to mean (=) */
1458       if (bucky_sym_to_bucky_bit (spec) != 0)
1459         signal_simple_error ("Key is a modifier name", spec);
1460       define_key_check_and_coerce_keysym (spec, &spec, 0);
1461       returned_value->keysym = spec;
1462       returned_value->modifiers = 0;
1463     }
1464   else if (CONSP (spec))
1465     {
1466       int modifiers = 0;
1467       Lisp_Object keysym = Qnil;
1468       Lisp_Object rest = spec;
1469
1470       /* First, parse out the leading modifier symbols. */
1471       while (CONSP (rest))
1472         {
1473           int modifier;
1474
1475           keysym = XCAR (rest);
1476           modifier = bucky_sym_to_bucky_bit (keysym);
1477           modifiers |= modifier;
1478           if (!NILP (XCDR (rest)))
1479             {
1480               if (! modifier)
1481                 signal_simple_error ("Unknown modifier", keysym);
1482             }
1483           else
1484             {
1485               if (modifier)
1486                 signal_simple_error ("Nothing but modifiers here",
1487                                      spec);
1488             }
1489           rest = XCDR (rest);
1490           QUIT;
1491         }
1492       if (!NILP (rest))
1493         signal_simple_error ("List must be nil-terminated", spec);
1494
1495       define_key_check_and_coerce_keysym (spec, &keysym, modifiers);
1496       returned_value->keysym = keysym;
1497       returned_value->modifiers = modifiers;
1498     }
1499   else
1500     {
1501       signal_simple_error ("Unknown key-sequence specifier",
1502                            spec);
1503     }
1504 }
1505
1506 /* Used by character-to-event */
1507 void
1508 key_desc_list_to_event (Lisp_Object list, Lisp_Object event,
1509                         int allow_menu_events)
1510 {
1511   struct key_data raw_key;
1512
1513   if (allow_menu_events &&
1514       CONSP (list) &&
1515       /* #### where the hell does this come from? */
1516       EQ (XCAR (list), Qmenu_selection))
1517     {
1518       Lisp_Object fn, arg;
1519       if (! NILP (Fcdr (Fcdr (list))))
1520         signal_simple_error ("Invalid menu event desc", list);
1521       arg = Fcar (Fcdr (list));
1522       if (SYMBOLP (arg))
1523         fn = Qcall_interactively;
1524       else
1525         fn = Qeval;
1526       XSETFRAME (XEVENT (event)->channel, selected_frame ());
1527       XEVENT (event)->event_type = misc_user_event;
1528       XEVENT (event)->event.eval.function = fn;
1529       XEVENT (event)->event.eval.object = arg;
1530       return;
1531     }
1532
1533   define_key_parser (list, &raw_key);
1534
1535   if (EQ (raw_key.keysym, Qbutton0) || EQ (raw_key.keysym, Qbutton0up) ||
1536       EQ (raw_key.keysym, Qbutton1) || EQ (raw_key.keysym, Qbutton1up) ||
1537       EQ (raw_key.keysym, Qbutton2) || EQ (raw_key.keysym, Qbutton2up) ||
1538       EQ (raw_key.keysym, Qbutton3) || EQ (raw_key.keysym, Qbutton3up) ||
1539       EQ (raw_key.keysym, Qbutton4) || EQ (raw_key.keysym, Qbutton4up) ||
1540       EQ (raw_key.keysym, Qbutton5) || EQ (raw_key.keysym, Qbutton5up) ||
1541       EQ (raw_key.keysym, Qbutton6) || EQ (raw_key.keysym, Qbutton6up) ||
1542       EQ (raw_key.keysym, Qbutton7) || EQ (raw_key.keysym, Qbutton7up))
1543     error ("Mouse-clicks can't appear in saved keyboard macros.");
1544
1545   XEVENT (event)->channel = Vselected_console;
1546   XEVENT (event)->event_type = key_press_event;
1547   XEVENT (event)->event.key.keysym = raw_key.keysym;
1548   XEVENT (event)->event.key.modifiers = raw_key.modifiers;
1549 }
1550
1551
1552 int
1553 event_matches_key_specifier_p (Lisp_Event *event, Lisp_Object key_specifier)
1554 {
1555   Lisp_Object event2 = Qnil;
1556   int retval;
1557   struct gcpro gcpro1;
1558
1559   if (event->event_type != key_press_event || NILP (key_specifier) ||
1560       (INTP (key_specifier) && !CHAR_INTP (key_specifier)))
1561     return 0;
1562
1563   /* if the specifier is an integer such as 27, then it should match
1564      both of the events 'escape' and 'control ['.  Calling
1565      Fcharacter_to_event() will only match 'escape'. */
1566   if (CHAR_OR_CHAR_INTP (key_specifier))
1567     return (XCHAR_OR_CHAR_INT (key_specifier)
1568             == event_to_character (event, 0, 0, 0));
1569
1570   /* Otherwise, we cannot call event_to_character() because we may
1571      be dealing with non-ASCII keystrokes.  In any case, if I ask
1572      for 'control [' then I should get exactly that, and not
1573      'escape'.
1574
1575      However, we have to behave differently on TTY's, where 'control ['
1576      is silently converted into 'escape' by the keyboard driver.
1577      In this case, ASCII is the only thing we know about, so we have
1578      to compare the ASCII values. */
1579
1580   GCPRO1 (event2);
1581   event2 = Fmake_event (Qnil, Qnil);
1582   Fcharacter_to_event (key_specifier, event2, Qnil, Qnil);
1583   if (XEVENT (event2)->event_type != key_press_event)
1584     retval = 0;
1585   else if (CONSOLE_TTY_P (XCONSOLE (EVENT_CHANNEL (event))))
1586     {
1587       int ch1, ch2;
1588
1589       ch1 = event_to_character (event, 0, 0, 0);
1590       ch2 = event_to_character (XEVENT (event2), 0, 0, 0);
1591       retval = (ch1 >= 0 && ch2 >= 0 && ch1 == ch2);
1592     }
1593   else if (EQ (event->event.key.keysym, XEVENT (event2)->event.key.keysym) &&
1594            event->event.key.modifiers == XEVENT (event2)->event.key.modifiers)
1595     retval = 1;
1596   else
1597     retval = 0;
1598   Fdeallocate_event (event2);
1599   UNGCPRO;
1600   return retval;
1601 }
1602
1603 static int
1604 meta_prefix_char_p (const struct key_data *key)
1605 {
1606   Lisp_Event event;
1607
1608   event.event_type = key_press_event;
1609   event.channel = Vselected_console;
1610   event.event.key.keysym = key->keysym;
1611   event.event.key.modifiers = key->modifiers;
1612   return event_matches_key_specifier_p (&event, Vmeta_prefix_char);
1613 }
1614
1615 DEFUN ("event-matches-key-specifier-p", Fevent_matches_key_specifier_p, 2, 2, 0, /*
1616 Return non-nil if EVENT matches KEY-SPECIFIER.
1617 This can be useful, e.g., to determine if the user pressed `help-char' or
1618 `quit-char'.
1619 */
1620        (event, key_specifier))
1621 {
1622   CHECK_LIVE_EVENT (event);
1623   return (event_matches_key_specifier_p (XEVENT (event), key_specifier)
1624           ? Qt : Qnil);
1625 }
1626
1627 #define MACROLET(k,m) do {              \
1628   returned_value->keysym = (k);         \
1629   returned_value->modifiers = (m);      \
1630   RETURN_SANS_WARNINGS;                 \
1631 } while (0)
1632
1633 /* ASCII grunge.
1634    Given a keysym, return another keysym/modifier pair which could be
1635    considered the same key in an ASCII world.  Backspace returns ^H, for
1636    example.
1637  */
1638 static void
1639 define_key_alternate_name (struct key_data *key,
1640                            struct key_data *returned_value)
1641 {
1642   Lisp_Object keysym = key->keysym;
1643   int modifiers = key->modifiers;
1644   int modifiers_sans_control = (modifiers & (~XEMACS_MOD_CONTROL));
1645   int modifiers_sans_meta = (modifiers & (~XEMACS_MOD_META));
1646   returned_value->keysym = Qnil; /* By default, no "alternate" key */
1647   returned_value->modifiers = 0;
1648   if (modifiers_sans_meta == XEMACS_MOD_CONTROL)
1649     {
1650       if (EQ (keysym, QKspace))
1651         MACROLET (make_char ('@'), modifiers);
1652       else if (!CHARP (keysym))
1653         return;
1654       else switch (XCHAR (keysym))
1655         {
1656         case '@':               /* c-@ => c-space */
1657           MACROLET (QKspace, modifiers);
1658         case 'h':               /* c-h => backspace */
1659           MACROLET (QKbackspace, modifiers_sans_control);
1660         case 'i':               /* c-i => tab */
1661           MACROLET (QKtab, modifiers_sans_control);
1662         case 'j':               /* c-j => linefeed */
1663           MACROLET (QKlinefeed, modifiers_sans_control);
1664         case 'm':               /* c-m => return */
1665           MACROLET (QKreturn, modifiers_sans_control);
1666         case '[':               /* c-[ => escape */
1667           MACROLET (QKescape, modifiers_sans_control);
1668         default:
1669           return;
1670         }
1671     }
1672   else if (modifiers_sans_meta != 0)
1673     return;
1674   else if (EQ (keysym, QKbackspace)) /* backspace => c-h */
1675     MACROLET (make_char ('h'), (modifiers | XEMACS_MOD_CONTROL));
1676   else if (EQ (keysym, QKtab))       /* tab => c-i */
1677     MACROLET (make_char ('i'), (modifiers | XEMACS_MOD_CONTROL));
1678   else if (EQ (keysym, QKlinefeed))  /* linefeed => c-j */
1679     MACROLET (make_char ('j'), (modifiers | XEMACS_MOD_CONTROL));
1680   else if (EQ (keysym, QKreturn))    /* return => c-m */
1681     MACROLET (make_char ('m'), (modifiers | XEMACS_MOD_CONTROL));
1682   else if (EQ (keysym, QKescape))    /* escape => c-[ */
1683     MACROLET (make_char ('['), (modifiers | XEMACS_MOD_CONTROL));
1684   else
1685     return;
1686 #undef MACROLET
1687 }
1688
1689
1690 static void
1691 ensure_meta_prefix_char_keymapp (Lisp_Object keys, int indx,
1692                                  Lisp_Object keymap)
1693 {
1694   /* This function can GC */
1695   Lisp_Object new_keys;
1696   int i;
1697   Lisp_Object mpc_binding;
1698   struct key_data meta_key;
1699
1700   if (NILP (Vmeta_prefix_char) ||
1701       (INTP (Vmeta_prefix_char) && !CHAR_INTP (Vmeta_prefix_char)))
1702     return;
1703
1704   define_key_parser (Vmeta_prefix_char, &meta_key);
1705   mpc_binding = keymap_lookup_1 (keymap, &meta_key, 0);
1706   if (NILP (mpc_binding) || !NILP (Fkeymapp (mpc_binding)))
1707     return;
1708
1709   if (indx == 0)
1710     new_keys = keys;
1711   else if (STRINGP (keys))
1712     new_keys = Fsubstring (keys, Qzero, make_int (indx));
1713   else if (VECTORP (keys))
1714     {
1715       new_keys = make_vector (indx, Qnil);
1716       for (i = 0; i < indx; i++)
1717         XVECTOR_DATA (new_keys) [i] = XVECTOR_DATA (keys) [i];
1718     }
1719   else
1720     {
1721       new_keys = Qnil;
1722       ABORT ();
1723     }
1724
1725   if (EQ (keys, new_keys))
1726     error_with_frob (mpc_binding,
1727                      "can't bind %s: %s has a non-keymap binding",
1728                      (char *) XSTRING_DATA (Fkey_description (keys)),
1729                      (char *) XSTRING_DATA (Fsingle_key_description
1730                                             (Vmeta_prefix_char)));
1731   else
1732     error_with_frob (mpc_binding,
1733                      "can't bind %s: %s %s has a non-keymap binding",
1734                      (char *) XSTRING_DATA (Fkey_description (keys)),
1735                      (char *) XSTRING_DATA (Fkey_description (new_keys)),
1736                      (char *) XSTRING_DATA (Fsingle_key_description
1737                                             (Vmeta_prefix_char)));
1738 }
1739
1740 DEFUN ("define-key", Fdefine_key, 3, 3, 0, /*
1741 Define key sequence KEYS, in KEYMAP, as DEF.
1742 KEYMAP is a keymap object.
1743 KEYS is the sequence of keystrokes to bind, described below.
1744 DEF is anything that can be a key's definition:
1745  nil (means key is undefined in this keymap);
1746  a command (a Lisp function suitable for interactive calling);
1747  a string or key sequence vector (treated as a keyboard macro);
1748  a keymap (to define a prefix key);
1749  a symbol; when the key is looked up, the symbol will stand for its
1750     function definition, that should at that time be one of the above,
1751     or another symbol whose function definition is used, and so on.
1752  a cons (STRING . DEFN), meaning that DEFN is the definition
1753     (DEFN should be a valid definition in its own right);
1754  or a cons (KEYMAP . CHAR), meaning use definition of CHAR in map KEYMAP.
1755
1756 Contrary to popular belief, the world is not ASCII.  When running under a
1757 window manager, XEmacs can tell the difference between, for example, the
1758 keystrokes control-h, control-shift-h, and backspace.  You can, in fact,
1759 bind different commands to each of these.
1760
1761 A `key sequence' is a set of keystrokes.  A `keystroke' is a keysym and some
1762 set of modifiers (such as control and meta).  A `keysym' is what is printed
1763 on the keys on your keyboard.
1764
1765 A keysym may be represented by a symbol, or (if and only if it is equivalent
1766 to an ASCII character in the range 32 - 255) by a character or its equivalent
1767 ASCII code.  The `A' key may be represented by the symbol `A', the character
1768 `?A', or by the number 65.  The `break' key may be represented only by the
1769 symbol `break'.
1770
1771 A keystroke may be represented by a list: the last element of the list
1772 is the key (a symbol, character, or number, as above) and the
1773 preceding elements are the symbolic names of modifier keys (control,
1774 meta, super, hyper, alt, and shift).  Thus, the sequence control-b is
1775 represented by the forms `(control b)', `(control ?b)', and `(control
1776 98)'.  A keystroke may also be represented by an event object, as
1777 returned by the `next-command-event' and `read-key-sequence'
1778 functions.
1779
1780 Note that in this context, the keystroke `control-b' is *not* represented
1781 by the number 2 (the ASCII code for ^B) or the character `?\^B'.  See below.
1782
1783 The `shift' modifier is somewhat of a special case.  You should not (and
1784 cannot) use `(meta shift a)' to mean `(meta A)', since for characters that
1785 have ASCII equivalents, the state of the shift key is implicit in the
1786 keysym (a vs. A).  You also cannot say `(shift =)' to mean `+', as that
1787 sort of thing varies from keyboard to keyboard.  The shift modifier is for
1788 use only with characters that do not have a second keysym on the same key,
1789 such as `backspace' and `tab'.
1790
1791 A key sequence is a vector of keystrokes.  As a degenerate case, elements
1792 of this vector may also be keysyms if they have no modifiers.  That is,
1793 the `A' keystroke is represented by all of these forms:
1794         A       ?A      65      (A)     (?A)    (65)
1795         [A]     [?A]    [65]    [(A)]   [(?A)]  [(65)]
1796
1797 the `control-a' keystroke is represented by these forms:
1798         (control A)     (control ?A)    (control 65)
1799         [(control A)]   [(control ?A)]  [(control 65)]
1800 the key sequence `control-c control-a' is represented by these forms:
1801         [(control c) (control a)]       [(control ?c) (control ?a)]
1802         [(control 99) (control 65)]     etc.
1803
1804 Mouse button clicks work just like keypresses: (control button1) means
1805 pressing the left mouse button while holding down the control key.
1806 \[(control c) (shift button3)] means control-c, hold shift, click right.
1807
1808 Commands may be bound to the mouse-button up-stroke rather than the down-
1809 stroke as well.  `button1' means the down-stroke, and `button1up' means the
1810 up-stroke.  Different commands may be bound to the up and down strokes,
1811 though that is probably not what you want, so be careful.
1812
1813 For backward compatibility, a key sequence may also be represented by a
1814 string.  In this case, it represents the key sequence(s) that would
1815 produce that sequence of ASCII characters in a purely ASCII world.  For
1816 example, a string containing the ASCII backspace character, "\\^H", would
1817 represent two key sequences: `(control h)' and `backspace'.  Binding a
1818 command to this will actually bind both of those key sequences.  Likewise
1819 for the following pairs:
1820
1821                 control h       backspace
1822                 control i       tab
1823                 control m       return
1824                 control j       linefeed
1825                 control [       escape
1826                 control @       control space
1827
1828 After binding a command to two key sequences with a form like
1829
1830         (define-key global-map "\\^X\\^I" \'command-1)
1831
1832 it is possible to redefine only one of those sequences like so:
1833
1834         (define-key global-map [(control x) (control i)] \'command-2)
1835         (define-key global-map [(control x) tab] \'command-3)
1836
1837 Of course, all of this applies only when running under a window system.  If
1838 you're talking to XEmacs through a TTY connection, you don't get any of
1839 these features.
1840 */
1841        (keymap, keys, def))
1842 {
1843   /* This function can GC */
1844   int idx;
1845   int metized = 0;
1846   int len;
1847   int ascii_hack;
1848   struct gcpro gcpro1, gcpro2, gcpro3;
1849
1850   if (VECTORP (keys))
1851     len = XVECTOR_LENGTH (keys);
1852   else if (STRINGP (keys))
1853     len = XSTRING_CHAR_LENGTH (keys);
1854   else if (CHAR_OR_CHAR_INTP (keys) || SYMBOLP (keys) || CONSP (keys))
1855     {
1856       if (!CONSP (keys)) keys = list1 (keys);
1857       len = 1;
1858       keys = make_vector (1, keys); /* this is kinda sleazy. */
1859     }
1860   else
1861     {
1862       keys = wrong_type_argument (Qsequencep, keys);
1863       len = XINT (Flength (keys));
1864     }
1865   if (len == 0)
1866     return Qnil;
1867
1868   GCPRO3 (keymap, keys, def);
1869
1870   /* ASCII grunge.
1871      When the user defines a key which, in a strictly ASCII world, would be
1872      produced by two different keys (^J and linefeed, or ^H and backspace,
1873      for example) then the binding will be made for both keysyms.
1874
1875      This is done if the user binds a command to a string, as in
1876      (define-key map "\^H" 'something), but not when using one of the new
1877      syntaxes, like (define-key map '(control h) 'something).
1878      */
1879   ascii_hack = (STRINGP (keys));
1880
1881   keymap = get_keymap (keymap, 1, 1);
1882
1883   idx = 0;
1884   while (1)
1885     {
1886       Lisp_Object c;
1887       struct key_data raw_key1;
1888       struct key_data raw_key2;
1889
1890       if (STRINGP (keys))
1891         c = make_char (string_char (XSTRING (keys), idx));
1892       else
1893         c = XVECTOR_DATA (keys) [idx];
1894
1895       define_key_parser (c, &raw_key1);
1896
1897       if (!metized && ascii_hack && meta_prefix_char_p (&raw_key1))
1898         {
1899           if (idx == (len - 1))
1900             {
1901               /* This is a hack to prevent a binding for the meta-prefix-char
1902                  from being made in a map which already has a non-empty "meta"
1903                  submap.  That is, we can't let both "escape" and "meta" have
1904                  a binding in the same keymap.  This implies that the idiom
1905                  (define-key my-map "\e" my-escape-map)
1906                  (define-key my-escape-map "a" 'my-command)
1907                  no longer works.  That's ok.  Instead the luser should do
1908                  (define-key my-map "\ea" 'my-command)
1909                  or, more correctly
1910                  (define-key my-map "\M-a" 'my-command)
1911                  and then perhaps
1912                  (defvar my-escape-map (lookup-key my-map "\e"))
1913                  if the luser really wants the map in a variable.
1914                  */
1915               Lisp_Object meta_map;
1916               struct gcpro ngcpro1;
1917
1918               NGCPRO1 (c);
1919               meta_map = Fgethash (MAKE_MODIFIER_HASH_KEY (XEMACS_MOD_META),
1920                                    XKEYMAP (keymap)->table, Qnil);
1921               if (!NILP (meta_map)
1922                   && keymap_fullness (meta_map) != 0)
1923                 signal_simple_error_2
1924                   ("Map contains meta-bindings, can't bind",
1925                    Fsingle_key_description (Vmeta_prefix_char), keymap);
1926               NUNGCPRO;
1927             }
1928           else
1929             {
1930               metized = 1;
1931               idx++;
1932               continue;
1933             }
1934         }
1935
1936       if (ascii_hack)
1937         define_key_alternate_name (&raw_key1, &raw_key2);
1938       else
1939         {
1940           raw_key2.keysym = Qnil;
1941           raw_key2.modifiers = 0;
1942         }
1943
1944       if (metized)
1945         {
1946           raw_key1.modifiers |= XEMACS_MOD_META;
1947           raw_key2.modifiers |= XEMACS_MOD_META;
1948           metized = 0;
1949         }
1950
1951       /* This crap is to make sure that someone doesn't bind something like
1952          "C-x M-a" while "C-x ESC" has a non-keymap binding. */
1953       if (raw_key1.modifiers & XEMACS_MOD_META)
1954         ensure_meta_prefix_char_keymapp (keys, idx, keymap);
1955
1956       if (++idx == len)
1957         {
1958           keymap_store (keymap, &raw_key1, def);
1959           if (ascii_hack && !NILP (raw_key2.keysym))
1960             keymap_store (keymap, &raw_key2, def);
1961           UNGCPRO;
1962           return def;
1963         }
1964
1965       {
1966         Lisp_Object cmd;
1967         struct gcpro ngcpro1;
1968         NGCPRO1 (c);
1969
1970         cmd = keymap_lookup_1 (keymap, &raw_key1, 0);
1971         if (NILP (cmd))
1972           {
1973             cmd = Fmake_sparse_keymap (Qnil);
1974             XKEYMAP (cmd)->name /* for debugging */
1975               = list2 (make_key_description (&raw_key1, 1), keymap);
1976             keymap_store (keymap, &raw_key1, cmd);
1977           }
1978         if (NILP (Fkeymapp (cmd)))
1979           signal_simple_error_2 ("Invalid prefix keys in sequence",
1980                                  c, keys);
1981
1982         if (ascii_hack && !NILP (raw_key2.keysym) &&
1983             NILP (keymap_lookup_1 (keymap, &raw_key2, 0)))
1984           keymap_store (keymap, &raw_key2, cmd);
1985
1986         keymap = get_keymap (cmd, 1, 1);
1987         NUNGCPRO;
1988       }
1989     }
1990 }
1991
1992 \f
1993 /************************************************************************/
1994 /*                      Looking up keys in keymaps                      */
1995 /************************************************************************/
1996
1997 /* We need a very fast (i.e., non-consing) version of lookup-key in order
1998    to make where-is-internal really fly. */
1999
2000 struct raw_lookup_key_mapper_closure
2001 {
2002   int remaining;
2003   const struct key_data *raw_keys;
2004   int raw_keys_count;
2005   int keys_so_far;
2006   int accept_default;
2007 };
2008
2009 static Lisp_Object raw_lookup_key_mapper (Lisp_Object k, void *);
2010
2011 /* Caller should gc-protect args (keymaps may autoload) */
2012 static Lisp_Object
2013 raw_lookup_key (Lisp_Object keymap,
2014                 const struct key_data *raw_keys, int raw_keys_count,
2015                 int keys_so_far, int accept_default)
2016 {
2017   /* This function can GC */
2018   struct raw_lookup_key_mapper_closure c;
2019   c.remaining = raw_keys_count - 1;
2020   c.raw_keys = raw_keys;
2021   c.raw_keys_count = raw_keys_count;
2022   c.keys_so_far = keys_so_far;
2023   c.accept_default = accept_default;
2024
2025   return traverse_keymaps (keymap, Qnil, raw_lookup_key_mapper, &c);
2026 }
2027
2028 static Lisp_Object
2029 raw_lookup_key_mapper (Lisp_Object k, void *arg)
2030 {
2031   /* This function can GC */
2032   struct raw_lookup_key_mapper_closure *c =
2033     (struct raw_lookup_key_mapper_closure *) arg;
2034   int accept_default = c->accept_default;
2035   int remaining = c->remaining;
2036   int keys_so_far = c->keys_so_far;
2037   const struct key_data *raw_keys = c->raw_keys;
2038   Lisp_Object cmd;
2039
2040   if (! meta_prefix_char_p (&(raw_keys[0])))
2041     {
2042       /* Normal case: every case except the meta-hack (see below). */
2043       cmd = keymap_lookup_1 (k, &(raw_keys[0]), accept_default);
2044
2045       if (remaining == 0)
2046         /* Return whatever we found if we're out of keys */
2047         ;
2048       else if (NILP (cmd))
2049         /* Found nothing (though perhaps parent map may have binding) */
2050         ;
2051       else if (NILP (Fkeymapp (cmd)))
2052         /* Didn't find a keymap, and we have more keys.
2053          * Return a fixnum to indicate that keys were too long.
2054          */
2055         cmd = make_int (keys_so_far + 1);
2056       else
2057         cmd = raw_lookup_key (cmd, raw_keys + 1, remaining,
2058                               keys_so_far + 1, accept_default);
2059     }
2060   else
2061     {
2062       /* This is a hack so that looking up a key-sequence whose last
2063        * element is the meta-prefix-char will return the keymap that
2064        * the "meta" keys are stored in, if there is no binding for
2065        * the meta-prefix-char (and if this map has a "meta" submap).
2066        * If this map doesn't have a "meta" submap, then the
2067        * meta-prefix-char is looked up just like any other key.
2068        */
2069       if (remaining == 0)
2070         {
2071           /* First look for the prefix-char directly */
2072           cmd = keymap_lookup_1 (k, &(raw_keys[0]), accept_default);
2073           if (NILP (cmd))
2074             {
2075               /* Do kludgy return of the meta-map */
2076               cmd = Fgethash (MAKE_MODIFIER_HASH_KEY (XEMACS_MOD_META),
2077                               XKEYMAP (k)->table, Qnil);
2078             }
2079         }
2080       else
2081         {
2082           /* Search for the prefix-char-prefixed sequence directly */
2083           cmd = keymap_lookup_1 (k, &(raw_keys[0]), accept_default);
2084           cmd = get_keymap (cmd, 0, 1);
2085           if (!NILP (cmd))
2086             cmd = raw_lookup_key (cmd, raw_keys + 1, remaining,
2087                                   keys_so_far + 1, accept_default);
2088           else if ((raw_keys[1].modifiers & XEMACS_MOD_META) == 0)
2089             {
2090               struct key_data metified;
2091               metified.keysym = raw_keys[1].keysym;
2092               metified.modifiers = raw_keys[1].modifiers |
2093                 (unsigned char) XEMACS_MOD_META;
2094
2095               /* Search for meta-next-char sequence directly */
2096               cmd = keymap_lookup_1 (k, &metified, accept_default);
2097               if (remaining == 1)
2098                 ;
2099               else
2100                 {
2101                   cmd = get_keymap (cmd, 0, 1);
2102                   if (!NILP (cmd))
2103                     cmd = raw_lookup_key (cmd, raw_keys + 2, remaining - 1,
2104                                           keys_so_far + 2,
2105                                           accept_default);
2106                 }
2107             }
2108         }
2109     }
2110   if (accept_default && NILP (cmd))
2111     cmd = XKEYMAP (k)->default_binding;
2112   return cmd;
2113 }
2114
2115 /* Value is number if `keys' is too long; NIL if valid but has no definition.*/
2116 /* Caller should gc-protect arguments */
2117 static Lisp_Object
2118 lookup_keys (Lisp_Object keymap, int nkeys, Lisp_Object *keys,
2119              int accept_default)
2120 {
2121   /* This function can GC */
2122   struct key_data kkk[20];
2123   struct key_data *raw_keys;
2124   int i;
2125
2126   if (nkeys == 0)
2127     return Qnil;
2128
2129   if (nkeys < countof (kkk))
2130     raw_keys = kkk;
2131   else
2132     raw_keys = alloca_array (struct key_data, nkeys);
2133
2134   for (i = 0; i < nkeys; i++)
2135     {
2136       define_key_parser (keys[i], &(raw_keys[i]));
2137     }
2138   return raw_lookup_key (keymap, raw_keys, nkeys, 0, accept_default);
2139 }
2140
2141 static Lisp_Object
2142 lookup_events (Lisp_Object event_head, int nmaps, Lisp_Object keymaps[],
2143                int accept_default)
2144 {
2145   /* This function can GC */
2146   struct key_data kkk[20];
2147   Lisp_Object event;
2148
2149   int nkeys;
2150   struct key_data *raw_keys;
2151   Lisp_Object tem = Qnil;
2152   struct gcpro gcpro1, gcpro2;
2153   int iii;
2154
2155   CHECK_LIVE_EVENT (event_head);
2156
2157   nkeys = event_chain_count (event_head);
2158
2159   if (nkeys < countof (kkk))
2160     raw_keys = kkk;
2161   else
2162     raw_keys = alloca_array (struct key_data, nkeys);
2163
2164   nkeys = 0;
2165   EVENT_CHAIN_LOOP (event, event_head)
2166     define_key_parser (event, &(raw_keys[nkeys++]));
2167   GCPRO2 (keymaps[0], event_head);
2168   gcpro1.nvars = nmaps;
2169   /* ####raw_keys[].keysym slots aren't gc-protected.  We rely (but shouldn't)
2170    * on somebody else somewhere (obarray) having a pointer to all keysyms. */
2171   for (iii = 0; iii < nmaps; iii++)
2172     {
2173       tem = raw_lookup_key (keymaps[iii], raw_keys, nkeys, 0,
2174                             accept_default);
2175       if (INTP (tem))
2176         {
2177           /* Too long in some local map means don't look at global map */
2178           tem = Qnil;
2179           break;
2180         }
2181       else if (!NILP (tem))
2182         break;
2183     }
2184   UNGCPRO;
2185   return tem;
2186 }
2187
2188 DEFUN ("lookup-key", Flookup_key, 2, 3, 0, /*
2189 In keymap KEYMAP, look up key-sequence KEYS.  Return the definition.
2190 Nil is returned if KEYS is unbound.  See documentation of `define-key'
2191 for valid key definitions and key-sequence specifications.
2192 A number is returned if KEYS is "too long"; that is, the leading
2193 characters fail to be a valid sequence of prefix characters in KEYMAP.
2194 The number is how many key strokes at the front of KEYS it takes to
2195 reach a non-prefix command.
2196 */
2197        (keymap, keys, accept_default))
2198 {
2199   /* This function can GC */
2200   if (VECTORP (keys))
2201     return lookup_keys (keymap,
2202                         XVECTOR_LENGTH (keys),
2203                         XVECTOR_DATA (keys),
2204                         !NILP (accept_default));
2205   else if (SYMBOLP (keys) || CHAR_OR_CHAR_INTP (keys) || CONSP (keys))
2206     return lookup_keys (keymap, 1, &keys, !NILP (accept_default));
2207   else if (STRINGP (keys))
2208     {
2209       int length = XSTRING_CHAR_LENGTH (keys);
2210       int i;
2211       struct key_data *raw_keys = alloca_array (struct key_data, length);
2212       if (length == 0)
2213         return Qnil;
2214
2215       for (i = 0; i < length; i++)
2216         {
2217           Emchar n = string_char (XSTRING (keys), i);
2218           define_key_parser (make_char (n), &(raw_keys[i]));
2219         }
2220       return raw_lookup_key (keymap, raw_keys, length, 0,
2221                              !NILP (accept_default));
2222     }
2223   else
2224     {
2225       keys = wrong_type_argument (Qsequencep, keys);
2226       return Flookup_key (keymap, keys, accept_default);
2227     }
2228 }
2229
2230 /* Given a key sequence, returns a list of keymaps to search for bindings.
2231    Does all manner of semi-hairy heuristics, like looking in the current
2232    buffer's map before looking in the global map and looking in the local
2233    map of the buffer in which the mouse was clicked in event0 is a click.
2234
2235    It would be kind of nice if this were in Lisp so that this semi-hairy
2236    semi-heuristic command-lookup behavior could be readily understood and
2237    customised.  However, this needs to be pretty fast, or performance of
2238    keyboard macros goes to shit; putting this in lisp slows macros down
2239    2-3x.  And they're already slower than v18 by 5-6x.
2240  */
2241
2242 struct relevant_maps
2243   {
2244     int nmaps;
2245     unsigned int max_maps;
2246     Lisp_Object *maps;
2247     struct gcpro *gcpro;
2248   };
2249
2250 static void get_relevant_extent_keymaps (Lisp_Object pos,
2251                                          Lisp_Object buffer_or_string,
2252                                          Lisp_Object glyph,
2253                                          struct relevant_maps *closure);
2254 static void get_relevant_minor_maps (Lisp_Object buffer,
2255                                      struct relevant_maps *closure);
2256
2257 static void
2258 relevant_map_push (Lisp_Object map, struct relevant_maps *closure)
2259 {
2260   unsigned int nmaps = closure->nmaps;
2261
2262   if (!KEYMAPP (map))
2263     return;
2264   closure->nmaps = nmaps + 1;
2265   if (nmaps < closure->max_maps)
2266     {
2267       closure->maps[nmaps] = map;
2268       closure->gcpro->nvars = nmaps;
2269     }
2270 }
2271
2272 static int
2273 get_relevant_keymaps (Lisp_Object keys,
2274                       int max_maps, Lisp_Object maps[])
2275 {
2276   /* This function can GC */
2277   Lisp_Object terminal = Qnil;
2278   struct gcpro gcpro1;
2279   struct relevant_maps closure;
2280   struct console *con;
2281
2282   GCPRO1 (*maps);
2283   gcpro1.nvars = 0;
2284   closure.nmaps = 0;
2285   closure.max_maps = max_maps;
2286   closure.maps = maps;
2287   closure.gcpro = &gcpro1;
2288
2289   if (EVENTP (keys))
2290     terminal = event_chain_tail (keys);
2291   else if (VECTORP (keys))
2292     {
2293       int len = XVECTOR_LENGTH (keys);
2294       if (len > 0)
2295         terminal = XVECTOR_DATA (keys)[len - 1];
2296     }
2297
2298   if (EVENTP (terminal))
2299     {
2300       CHECK_LIVE_EVENT (terminal);
2301       con = event_console_or_selected (terminal);
2302     }
2303   else
2304     con = XCONSOLE (Vselected_console);
2305
2306   if (KEYMAPP (con->overriding_terminal_local_map)
2307       || KEYMAPP (Voverriding_local_map))
2308     {
2309       if (KEYMAPP (con->overriding_terminal_local_map))
2310         relevant_map_push (con->overriding_terminal_local_map, &closure);
2311       if (KEYMAPP (Voverriding_local_map))
2312         relevant_map_push (Voverriding_local_map, &closure);
2313     }
2314   else if (!EVENTP (terminal)
2315            || (XEVENT (terminal)->event_type != button_press_event
2316                && XEVENT (terminal)->event_type != button_release_event))
2317     {
2318       Lisp_Object tem;
2319       XSETBUFFER (tem, current_buffer);
2320       /* It's not a mouse event; order of keymaps searched is:
2321          o  keymap of any/all extents under the mouse
2322          o  minor-mode maps
2323          o  local-map of current-buffer
2324          o  global-map
2325          */
2326       /* The terminal element of the lookup may be nil or a keysym.
2327          In those cases we don't want to check for an extent
2328          keymap. */
2329       if (EVENTP (terminal))
2330         {
2331           get_relevant_extent_keymaps (make_int (BUF_PT (current_buffer)),
2332                                        tem, Qnil, &closure);
2333         }
2334       get_relevant_minor_maps (tem, &closure);
2335
2336       tem = current_buffer->keymap;
2337       if (!NILP (tem))
2338         relevant_map_push (tem, &closure);
2339     }
2340 #ifdef HAVE_WINDOW_SYSTEM
2341   else
2342     {
2343       /* It's a mouse event; order of keymaps searched is:
2344          o  vertical-divider-map, if event is over a divider
2345          o  local-map of mouse-grabbed-buffer
2346          o  keymap of any/all extents under the mouse
2347          if the mouse is over a modeline:
2348          o  modeline-map of buffer corresponding to that modeline
2349          o  else, local-map of buffer under the mouse
2350          o  minor-mode maps
2351          o  local-map of current-buffer
2352          o  global-map
2353          */
2354       Lisp_Object window = Fevent_window (terminal);
2355
2356       if (!NILP (Fevent_over_vertical_divider_p (terminal)))
2357         {
2358           if (KEYMAPP (Vvertical_divider_map))
2359             relevant_map_push (Vvertical_divider_map, &closure);
2360         }
2361
2362       if (BUFFERP (Vmouse_grabbed_buffer))
2363         {
2364           Lisp_Object map = XBUFFER (Vmouse_grabbed_buffer)->keymap;
2365
2366           get_relevant_minor_maps (Vmouse_grabbed_buffer, &closure);
2367           if (!NILP (map))
2368             relevant_map_push (map, &closure);
2369         }
2370
2371       if (!NILP (window))
2372         {
2373           Lisp_Object buffer = Fwindow_buffer (window);
2374
2375           if (!NILP (buffer))
2376             {
2377               if (!NILP (Fevent_over_modeline_p (terminal)))
2378                 {
2379                   Lisp_Object map = symbol_value_in_buffer (Qmodeline_map,
2380                                                             buffer);
2381
2382                   get_relevant_extent_keymaps
2383                     (Fevent_modeline_position (terminal),
2384                      XBUFFER (buffer)->generated_modeline_string,
2385                      Fevent_glyph_extent (terminal), &closure);
2386
2387                   if (!UNBOUNDP (map) && !NILP (map))
2388                     relevant_map_push (get_keymap (map, 1, 1), &closure);
2389                 }
2390               else
2391                 {
2392                   get_relevant_extent_keymaps (Fevent_point (terminal), buffer,
2393                                                Fevent_glyph_extent (terminal),
2394                                                &closure);
2395                 }
2396
2397               if (!EQ (buffer, Vmouse_grabbed_buffer)) /* already pushed */
2398                 {
2399                   Lisp_Object map = XBUFFER (buffer)->keymap;
2400
2401                   get_relevant_minor_maps (buffer, &closure);
2402                   if (!NILP(map))
2403                     relevant_map_push (map, &closure);
2404                 }
2405             }
2406         }
2407       else if (!NILP (Fevent_over_toolbar_p (terminal)))
2408         {
2409           Lisp_Object map = Fsymbol_value (Qtoolbar_map);
2410
2411           if (!UNBOUNDP (map) && !NILP (map))
2412             relevant_map_push (map, &closure);
2413         }
2414     }
2415 #endif /* HAVE_WINDOW_SYSTEM */
2416
2417   {
2418     int nmaps = closure.nmaps;
2419     /* Silently truncate at 100 keymaps to prevent infinite lossage */
2420     if (nmaps >= max_maps && max_maps > 0)
2421       maps[max_maps - 1] = Vcurrent_global_map;
2422     else
2423       maps[nmaps] = Vcurrent_global_map;
2424     UNGCPRO;
2425     return nmaps + 1;
2426   }
2427 }
2428
2429 /* Returns a set of keymaps extracted from the extents at POS in
2430    BUFFER_OR_STRING.  The GLYPH arg, if specified, is one more extent
2431    to look for a keymap in, and if it has one, its keymap will be the
2432    first element in the list returned.  This is so we can correctly
2433    search the keymaps associated with glyphs which may be physically
2434    disjoint from their extents: for example, if a glyph is out in the
2435    margin, we should still consult the keymap of that glyph's extent,
2436    which may not itself be under the mouse.
2437  */
2438
2439 static void
2440 get_relevant_extent_keymaps (Lisp_Object pos, Lisp_Object buffer_or_string,
2441                              Lisp_Object glyph,
2442                              struct relevant_maps *closure)
2443 {
2444   /* This function can GC */
2445   /* the glyph keymap, if any, comes first.
2446      (Processing it twice is no big deal: noop.) */
2447   if (!NILP (glyph))
2448     {
2449       Lisp_Object keymap = Fextent_property (glyph, Qkeymap, Qnil);
2450       if (!NILP (keymap))
2451         relevant_map_push (get_keymap (keymap, 1, 1), closure);
2452     }
2453
2454   /* Next check the extents at the text position, if any */
2455   if (!NILP (pos))
2456     {
2457       Lisp_Object extent;
2458       for (extent = Fextent_at (pos, buffer_or_string, Qkeymap, Qnil, Qnil);
2459            !NILP (extent);
2460            extent = Fextent_at (pos, buffer_or_string, Qkeymap, extent, Qnil))
2461         {
2462           Lisp_Object keymap = Fextent_property (extent, Qkeymap, Qnil);
2463           if (!NILP (keymap))
2464             relevant_map_push (get_keymap (keymap, 1, 1), closure);
2465           QUIT;
2466         }
2467     }
2468 }
2469
2470 static Lisp_Object
2471 minor_mode_keymap_predicate (Lisp_Object assoc, Lisp_Object buffer)
2472 {
2473   /* This function can GC */
2474   if (CONSP (assoc))
2475     {
2476       Lisp_Object sym = XCAR (assoc);
2477       if (SYMBOLP (sym))
2478         {
2479           Lisp_Object val = symbol_value_in_buffer (sym, buffer);
2480           if (!NILP (val) && !UNBOUNDP (val))
2481             {
2482               Lisp_Object map = get_keymap (XCDR (assoc), 0, 1);
2483               return map;
2484             }
2485         }
2486     }
2487   return Qnil;
2488 }
2489
2490 static void
2491 get_relevant_minor_maps (Lisp_Object buffer, struct relevant_maps *closure)
2492 {
2493   /* This function can GC */
2494   Lisp_Object alist;
2495
2496   /* Will you ever lose badly if you make this circular! */
2497   for (alist = symbol_value_in_buffer (Qminor_mode_map_alist, buffer);
2498        CONSP (alist);
2499        alist = XCDR (alist))
2500     {
2501       Lisp_Object m = minor_mode_keymap_predicate (XCAR (alist),
2502                                                    buffer);
2503       if (!NILP (m)) relevant_map_push (m, closure);
2504       QUIT;
2505     }
2506 }
2507
2508 /* #### Would map-current-keymaps be a better thing?? */
2509 DEFUN ("current-keymaps", Fcurrent_keymaps, 0, 1, 0, /*
2510 Return a list of the current keymaps that will be searched for bindings.
2511 This lists keymaps such as the current local map and the minor-mode maps,
2512  but does not list the parents of those keymaps.
2513 EVENT-OR-KEYS controls which keymaps will be listed.
2514 If EVENT-OR-KEYS is a mouse event (or a vector whose last element is a
2515  mouse event), the keymaps for that mouse event will be listed (see
2516  `key-binding').  Otherwise, the keymaps for key presses will be listed.
2517 */
2518        (event_or_keys))
2519 {
2520   /* This function can GC */
2521   struct gcpro gcpro1;
2522   Lisp_Object maps[100];
2523   Lisp_Object *gubbish = maps;
2524   int nmaps;
2525
2526   GCPRO1 (event_or_keys);
2527   nmaps = get_relevant_keymaps (event_or_keys, countof (maps),
2528                                 gubbish);
2529   if (nmaps > countof (maps))
2530     {
2531       gubbish = alloca_array (Lisp_Object, nmaps);
2532       nmaps = get_relevant_keymaps (event_or_keys, nmaps, gubbish);
2533     }
2534   UNGCPRO;
2535   return Flist (nmaps, gubbish);
2536 }
2537
2538 DEFUN ("key-binding", Fkey_binding, 1, 2, 0, /*
2539 Return the binding for command KEYS in current keymaps.
2540 KEYS is a string, a vector of events, or a vector of key-description lists
2541 as described in the documentation for the `define-key' function.
2542 The binding is probably a symbol with a function definition; see
2543 the documentation for `lookup-key' for more information.
2544
2545 For key-presses, the order of keymaps searched is:
2546   - the `keymap' property of any extent(s) at point;
2547   - any applicable minor-mode maps;
2548   - the current local map of the current-buffer;
2549   - the current global map.
2550
2551 For mouse-clicks, the order of keymaps searched is:
2552   - the current-local-map of the `mouse-grabbed-buffer' if any;
2553   - vertical-divider-map, if the event happened over a vertical divider
2554   - the `keymap' property of any extent(s) at the position of the click
2555     (this includes modeline extents);
2556   - the modeline-map of the buffer corresponding to the modeline under
2557     the mouse (if the click happened over a modeline);
2558   - the value of `toolbar-map' in the current-buffer (if the click
2559     happened over a toolbar);
2560   - the current local map of the buffer under the mouse (does not
2561     apply to toolbar clicks);
2562   - any applicable minor-mode maps;
2563   - the current global map.
2564
2565 Note that if `overriding-local-map' or `overriding-terminal-local-map'
2566 is non-nil, *only* those two maps and the current global map are searched.
2567 */
2568        (keys, accept_default))
2569 {
2570   /* This function can GC */
2571   int i;
2572   Lisp_Object maps[100];
2573   int nmaps;
2574   struct gcpro gcpro1, gcpro2;
2575   GCPRO2 (keys, accept_default); /* get_relevant_keymaps may autoload */
2576
2577   nmaps = get_relevant_keymaps (keys, countof (maps), maps);
2578
2579   UNGCPRO;
2580
2581   if (EVENTP (keys))           /* unadvertised "feature" for the future */
2582     return lookup_events (keys, nmaps, maps, !NILP (accept_default));
2583
2584   for (i = 0; i < nmaps; i++)
2585     {
2586       Lisp_Object tem = Flookup_key (maps[i], keys,
2587                                      accept_default);
2588       if (INTP (tem))
2589         {
2590           /* Too long in some local map means don't look at global map */
2591           return Qnil;
2592         }
2593       else if (!NILP (tem))
2594         return tem;
2595     }
2596   return Qnil;
2597 }
2598
2599 static Lisp_Object
2600 process_event_binding_result (Lisp_Object result)
2601 {
2602   if (EQ (result, Qundefined))
2603     /* The suppress-keymap function binds keys to 'undefined - special-case
2604        that here, so that being bound to that has the same error-behavior as
2605        not being defined at all.
2606        */
2607     result = Qnil;
2608   if (!NILP (result))
2609     {
2610       Lisp_Object map;
2611       /* Snap out possible keymap indirections */
2612       map = get_keymap (result, 0, 1);
2613       if (!NILP (map))
2614         result = map;
2615     }
2616
2617   return result;
2618 }
2619
2620 /* Attempts to find a command corresponding to the event-sequence
2621    whose head is event0 (sequence is threaded though event_next).
2622
2623    The return value will be
2624
2625       -- nil (there is no binding; this will also be returned
2626               whenever the event chain is "too long", i.e. there
2627               is a non-nil, non-keymap binding for a prefix of
2628               the event chain)
2629       -- a keymap (part of a command has been specified)
2630       -- a command (anything that satisfies `commandp'; this includes
2631                     some symbols, lists, subrs, strings, vectors, and
2632                     compiled-function objects) */
2633 Lisp_Object
2634 event_binding (Lisp_Object event0, int accept_default)
2635 {
2636   /* This function can GC */
2637   Lisp_Object maps[100];
2638   int nmaps;
2639
2640   assert (EVENTP (event0));
2641
2642   nmaps = get_relevant_keymaps (event0, countof (maps), maps);
2643   if (nmaps > countof (maps))
2644     nmaps = countof (maps);
2645   return process_event_binding_result (lookup_events (event0, nmaps, maps,
2646                                                       accept_default));
2647 }
2648
2649 /* like event_binding, but specify a keymap to search */
2650
2651 Lisp_Object
2652 event_binding_in (Lisp_Object event0, Lisp_Object keymap, int accept_default)
2653 {
2654   /* This function can GC */
2655   if (!KEYMAPP (keymap))
2656     return Qnil;
2657
2658   return process_event_binding_result (lookup_events (event0, 1, &keymap,
2659                                                       accept_default));
2660 }
2661
2662 /* Attempts to find a function key mapping corresponding to the
2663    event-sequence whose head is event0 (sequence is threaded through
2664    event_next).  The return value will be the same as for event_binding(). */
2665 Lisp_Object
2666 munging_key_map_event_binding (Lisp_Object event0,
2667                                enum munge_me_out_the_door munge)
2668 {
2669   Lisp_Object keymap = (munge == MUNGE_ME_FUNCTION_KEY) ?
2670     CONSOLE_FUNCTION_KEY_MAP (event_console_or_selected (event0)) :
2671     Vkey_translation_map;
2672
2673   if (NILP (keymap))
2674     return Qnil;
2675
2676   return process_event_binding_result (lookup_events (event0, 1, &keymap, 1));
2677 }
2678
2679 \f
2680 /************************************************************************/
2681 /*               Setting/querying the global and local maps             */
2682 /************************************************************************/
2683
2684 DEFUN ("use-global-map", Fuse_global_map, 1, 1, 0, /*
2685 Select KEYMAP as the global keymap.
2686 */
2687        (keymap))
2688 {
2689   /* This function can GC */
2690   keymap = get_keymap (keymap, 1, 1);
2691   Vcurrent_global_map = keymap;
2692   return Qnil;
2693 }
2694
2695 DEFUN ("use-local-map", Fuse_local_map, 1, 2, 0, /*
2696 Select KEYMAP as the local keymap in BUFFER.
2697 If KEYMAP is nil, that means no local keymap.
2698 If BUFFER is nil, the current buffer is assumed.
2699 */
2700        (keymap, buffer))
2701 {
2702   /* This function can GC */
2703   struct buffer *b = decode_buffer (buffer, 0);
2704   if (!NILP (keymap))
2705     keymap = get_keymap (keymap, 1, 1);
2706
2707   b->keymap = keymap;
2708
2709   return Qnil;
2710 }
2711
2712 DEFUN ("current-local-map", Fcurrent_local_map, 0, 1, 0, /*
2713 Return BUFFER's local keymap, or nil if it has none.
2714 If BUFFER is nil, the current buffer is assumed.
2715 */
2716        (buffer))
2717 {
2718   struct buffer *b = decode_buffer (buffer, 0);
2719   return b->keymap;
2720 }
2721
2722 DEFUN ("current-global-map", Fcurrent_global_map, 0, 0, 0, /*
2723 Return the current global keymap.
2724 */
2725        ())
2726 {
2727   return Vcurrent_global_map;
2728 }
2729
2730 \f
2731 /************************************************************************/
2732 /*                    Mapping over keymap elements                      */
2733 /************************************************************************/
2734
2735 /* Since keymaps are arranged in a hierarchy, one keymap per bucky bit or
2736    prefix key, it's not entirely obvious what map-keymap should do, but
2737    what it does is: map over all keys in this map; then recursively map
2738    over all submaps of this map that are "bucky" submaps.  This means that,
2739    when mapping over a keymap, it appears that "x" and "C-x" are in the
2740    same map, although "C-x" is really in the "control" submap of this one.
2741    However, since we don't recursively descend the submaps that are bound
2742    to prefix keys (like C-x, C-h, etc) the caller will have to recurse on
2743    those explicitly, if that's what they want.
2744
2745    So the end result of this is that the bucky keymaps (the ones indexed
2746    under the large integers returned from MAKE_MODIFIER_HASH_KEY()) are
2747    invisible from elisp.  They're just an implementation detail that code
2748    outside of this file doesn't need to know about.
2749  */
2750
2751 struct map_keymap_unsorted_closure
2752 {
2753   void (*fn) (const struct key_data *, Lisp_Object binding, void *arg);
2754   void *arg;
2755   int modifiers;
2756 };
2757
2758 /* used by map_keymap() */
2759 static int
2760 map_keymap_unsorted_mapper (Lisp_Object keysym, Lisp_Object value,
2761                             void *map_keymap_unsorted_closure)
2762 {
2763   /* This function can GC */
2764   struct map_keymap_unsorted_closure *closure =
2765     (struct map_keymap_unsorted_closure *) map_keymap_unsorted_closure;
2766   int modifiers = closure->modifiers;
2767   int mod_bit;
2768   mod_bit = MODIFIER_HASH_KEY_BITS (keysym);
2769   if (mod_bit != 0)
2770     {
2771       int omod = modifiers;
2772       closure->modifiers = (modifiers | mod_bit);
2773       value = get_keymap (value, 1, 0);
2774       elisp_maphash (map_keymap_unsorted_mapper,
2775                      XKEYMAP (value)->table,
2776                      map_keymap_unsorted_closure);
2777       closure->modifiers = omod;
2778     }
2779   else
2780     {
2781       struct key_data key;
2782       key.keysym = keysym;
2783       key.modifiers = modifiers;
2784       ((*closure->fn) (&key, value, closure->arg));
2785     }
2786   return 0;
2787 }
2788
2789
2790 struct map_keymap_sorted_closure
2791 {
2792   Lisp_Object *result_locative;
2793 };
2794
2795 /* used by map_keymap_sorted() */
2796 static int
2797 map_keymap_sorted_mapper (Lisp_Object key, Lisp_Object value,
2798                           void *map_keymap_sorted_closure)
2799 {
2800   struct map_keymap_sorted_closure *cl =
2801     (struct map_keymap_sorted_closure *) map_keymap_sorted_closure;
2802   Lisp_Object *list = cl->result_locative;
2803   *list = Fcons (Fcons (key, value), *list);
2804   return 0;
2805 }
2806
2807
2808 /* used by map_keymap_sorted(), describe_map_sort_predicate(),
2809    and keymap_submaps().
2810  */
2811 static int
2812 map_keymap_sort_predicate (Lisp_Object obj1, Lisp_Object obj2,
2813                            Lisp_Object pred)
2814 {
2815   /* obj1 and obj2 are conses with keysyms in their cars.  Cdrs are ignored.
2816    */
2817   int bit1, bit2;
2818   int sym1_p = 0;
2819   int sym2_p = 0;
2820   obj1 = XCAR (obj1);
2821   obj2 = XCAR (obj2);
2822
2823   if (EQ (obj1, obj2))
2824     return -1;
2825   bit1 = MODIFIER_HASH_KEY_BITS (obj1);
2826   bit2 = MODIFIER_HASH_KEY_BITS (obj2);
2827
2828   /* If either is a symbol with a character-set-property, then sort it by
2829      that code instead of alphabetically.
2830      */
2831   if (! bit1 && SYMBOLP (obj1))
2832     {
2833       Lisp_Object code = Fget (obj1, Vcharacter_set_property, Qnil);
2834       if (CHAR_OR_CHAR_INTP (code))
2835         {
2836           obj1 = code;
2837           CHECK_CHAR_COERCE_INT (obj1);
2838           sym1_p = 1;
2839         }
2840     }
2841   if (! bit2 && SYMBOLP (obj2))
2842     {
2843       Lisp_Object code = Fget (obj2, Vcharacter_set_property, Qnil);
2844       if (CHAR_OR_CHAR_INTP (code))
2845         {
2846           obj2 = code;
2847           CHECK_CHAR_COERCE_INT (obj2);
2848           sym2_p = 1;
2849         }
2850     }
2851
2852   /* all symbols (non-ASCIIs) come after characters (ASCIIs) */
2853   if (XTYPE (obj1) != XTYPE (obj2))
2854     return SYMBOLP (obj2) ? 1 : -1;
2855
2856   if (! bit1 && CHARP (obj1)) /* they're both ASCII */
2857     {
2858       int o1 = XCHAR (obj1);
2859       int o2 = XCHAR (obj2);
2860       if (o1 == o2 &&           /* If one started out as a symbol and the */
2861           sym1_p != sym2_p)     /* other didn't, the symbol comes last. */
2862         return sym2_p ? 1 : -1;
2863
2864       return o1 < o2 ? 1 : -1;  /* else just compare them */
2865     }
2866
2867   /* else they're both symbols.  If they're both buckys, then order them. */
2868   if (bit1 && bit2)
2869     return bit1 < bit2 ? 1 : -1;
2870
2871   /* if only one is a bucky, then it comes later */
2872   if (bit1 || bit2)
2873     return bit2 ? 1 : -1;
2874
2875   /* otherwise, string-sort them. */
2876   {
2877     char *s1 = (char *) string_data (XSYMBOL (obj1)->name);
2878     char *s2 = (char *) string_data (XSYMBOL (obj2)->name);
2879 #ifdef I18N2
2880     return 0 > strcoll (s1, s2) ? 1 : -1;
2881 #else
2882     return 0 > strcmp  (s1, s2) ? 1 : -1;
2883 #endif
2884   }
2885 }
2886
2887
2888 /* used by map_keymap() */
2889 static void
2890 map_keymap_sorted (Lisp_Object keymap_table,
2891                    int modifiers,
2892                    void (*function) (const struct key_data *key,
2893                                      Lisp_Object binding,
2894                                      void *map_keymap_sorted_closure),
2895                    void *map_keymap_sorted_closure)
2896 {
2897   /* This function can GC */
2898   struct gcpro gcpro1;
2899   Lisp_Object contents = Qnil;
2900
2901   if (XINT (Fhash_table_count (keymap_table)) == 0)
2902     return;
2903
2904   GCPRO1 (contents);
2905
2906   {
2907     struct map_keymap_sorted_closure c1;
2908     c1.result_locative = &contents;
2909     elisp_maphash (map_keymap_sorted_mapper, keymap_table, &c1);
2910   }
2911   contents = list_sort (contents, Qnil, map_keymap_sort_predicate);
2912   for (; !NILP (contents); contents = XCDR (contents))
2913     {
2914       Lisp_Object keysym = XCAR (XCAR (contents));
2915       Lisp_Object binding = XCDR (XCAR (contents));
2916       int sub_bits = MODIFIER_HASH_KEY_BITS (keysym);
2917       if (sub_bits != 0)
2918         map_keymap_sorted (XKEYMAP (get_keymap (binding,
2919                                                 1, 1))->table,
2920                            (modifiers | sub_bits),
2921                            function,
2922                            map_keymap_sorted_closure);
2923       else
2924         {
2925           struct key_data k;
2926           k.keysym = keysym;
2927           k.modifiers = modifiers;
2928           ((*function) (&k, binding, map_keymap_sorted_closure));
2929         }
2930     }
2931   UNGCPRO;
2932 }
2933
2934
2935 /* used by Fmap_keymap() */
2936 static void
2937 map_keymap_mapper (const struct key_data *key,
2938                    Lisp_Object binding,
2939                    void *function)
2940 {
2941   /* This function can GC */
2942   Lisp_Object fn;
2943   VOID_TO_LISP (fn, function);
2944   call2 (fn, make_key_description (key, 1), binding);
2945 }
2946
2947
2948 static void
2949 map_keymap (Lisp_Object keymap_table, int sort_first,
2950             void (*function) (const struct key_data *key,
2951                               Lisp_Object binding,
2952                               void *fn_arg),
2953             void *fn_arg)
2954 {
2955   /* This function can GC */
2956   if (sort_first)
2957     map_keymap_sorted (keymap_table, 0, function, fn_arg);
2958   else
2959     {
2960       struct map_keymap_unsorted_closure map_keymap_unsorted_closure;
2961       map_keymap_unsorted_closure.fn = function;
2962       map_keymap_unsorted_closure.arg = fn_arg;
2963       map_keymap_unsorted_closure.modifiers = 0;
2964       elisp_maphash (map_keymap_unsorted_mapper, keymap_table,
2965                      &map_keymap_unsorted_closure);
2966     }
2967 }
2968
2969 DEFUN ("map-keymap", Fmap_keymap, 2, 3, 0, /*
2970 Apply FUNCTION to each element of KEYMAP.
2971 FUNCTION will be called with two arguments: a key-description list, and
2972 the binding.  The order in which the elements of the keymap are passed to
2973 the function is unspecified.  If the function inserts new elements into
2974 the keymap, it may or may not be called with them later.  No element of
2975 the keymap will ever be passed to the function more than once.
2976
2977 The function will not be called on elements of this keymap's parents
2978 \(see the function `keymap-parents') or upon keymaps which are contained
2979 within this keymap (multi-character definitions).
2980 It will be called on "meta" characters since they are not really
2981 two-character sequences.
2982
2983 If the optional third argument SORT-FIRST is non-nil, then the elements of
2984 the keymap will be passed to the mapper function in a canonical order.
2985 Otherwise, they will be passed in hash (that is, random) order, which is
2986 faster.
2987 */
2988      (function, keymap, sort_first))
2989 {
2990   /* This function can GC */
2991   struct gcpro gcpro1, gcpro2, gcpro3;
2992   Lisp_Object table = Qnil;
2993
2994  /* tolerate obviously transposed args */
2995   if (!NILP (Fkeymapp (function)))
2996     {
2997       Lisp_Object tmp = function;
2998       function = keymap;
2999       keymap = tmp;
3000     }
3001
3002   GCPRO3 (function, keymap, table);
3003   keymap = get_keymap (keymap, 1, 1);
3004
3005   /* elisp_maphash does not allow mapping functions to modify the hash
3006      table being mapped over.  Since map-keymap explicitly allows a
3007      mapping function to modify KEYMAP, we map over a copy of the hash
3008      table instead.  */
3009   table = Fcopy_hash_table (XKEYMAP (keymap)->table);
3010
3011   map_keymap (table, !NILP (sort_first),
3012               map_keymap_mapper, LISP_TO_VOID (function));
3013   UNGCPRO;
3014   return Qnil;
3015 }
3016
3017
3018 \f
3019 /************************************************************************/
3020 /*                          Accessible keymaps                          */
3021 /************************************************************************/
3022
3023 struct accessible_keymaps_closure
3024   {
3025     Lisp_Object tail;
3026   };
3027
3028
3029 static void
3030 accessible_keymaps_mapper_1 (Lisp_Object keysym, Lisp_Object contents,
3031                              int modifiers,
3032                              struct accessible_keymaps_closure *closure)
3033 {
3034   /* This function can GC */
3035   int subbits = MODIFIER_HASH_KEY_BITS (keysym);
3036
3037   if (subbits != 0)
3038     {
3039       Lisp_Object submaps;
3040
3041       contents = get_keymap (contents, 1, 1);
3042       submaps = keymap_submaps (contents);
3043       for (; !NILP (submaps); submaps = XCDR (submaps))
3044         {
3045           accessible_keymaps_mapper_1 (XCAR (XCAR (submaps)),
3046                                        XCDR (XCAR (submaps)),
3047                                        (subbits | modifiers),
3048                                        closure);
3049         }
3050     }
3051   else
3052     {
3053       Lisp_Object thisseq = Fcar (Fcar (closure->tail));
3054       Lisp_Object cmd = get_keyelt (contents, 1);
3055       Lisp_Object vec;
3056       int j;
3057       int len;
3058       struct key_data key;
3059       key.keysym = keysym;
3060       key.modifiers = modifiers;
3061
3062       if (NILP (cmd))
3063         ABORT ();
3064       cmd = get_keymap (cmd, 0, 1);
3065       if (!KEYMAPP (cmd))
3066         ABORT ();
3067
3068       vec = make_vector (XVECTOR_LENGTH (thisseq) + 1, Qnil);
3069       len = XVECTOR_LENGTH (thisseq);
3070       for (j = 0; j < len; j++)
3071         XVECTOR_DATA (vec) [j] = XVECTOR_DATA (thisseq) [j];
3072       XVECTOR_DATA (vec) [j] = make_key_description (&key, 1);
3073
3074       nconc2 (closure->tail, list1 (Fcons (vec, cmd)));
3075     }
3076 }
3077
3078
3079 static Lisp_Object
3080 accessible_keymaps_keymap_mapper (Lisp_Object thismap, void *arg)
3081 {
3082   /* This function can GC */
3083   struct accessible_keymaps_closure *closure =
3084     (struct accessible_keymaps_closure *) arg;
3085   Lisp_Object submaps = keymap_submaps (thismap);
3086
3087   for (; !NILP (submaps); submaps = XCDR (submaps))
3088     {
3089       accessible_keymaps_mapper_1 (XCAR (XCAR (submaps)),
3090                                    XCDR (XCAR (submaps)),
3091                                    0,
3092                                    closure);
3093     }
3094   return Qnil;
3095 }
3096
3097
3098 DEFUN ("accessible-keymaps", Faccessible_keymaps, 1, 2, 0, /*
3099 Find all keymaps accessible via prefix characters from KEYMAP.
3100 Returns a list of elements of the form (KEYS . MAP), where the sequence
3101 KEYS starting from KEYMAP gets you to MAP.  These elements are ordered
3102 so that the KEYS increase in length.  The first element is ([] . KEYMAP).
3103 An optional argument PREFIX, if non-nil, should be a key sequence;
3104 then the value includes only maps for prefixes that start with PREFIX.
3105 */
3106        (keymap, prefix))
3107 {
3108   /* This function can GC */
3109   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3110   Lisp_Object accessible_keymaps = Qnil;
3111   struct accessible_keymaps_closure c;
3112   c.tail = Qnil;
3113   GCPRO4 (accessible_keymaps, c.tail, prefix, keymap);
3114
3115   keymap = get_keymap (keymap, 1, 1);
3116
3117  retry:
3118   if (NILP (prefix))
3119     {
3120       prefix = make_vector (0, Qnil);
3121     }
3122   else if (VECTORP (prefix) || STRINGP (prefix))
3123     {
3124       int len = XINT (Flength (prefix));
3125       Lisp_Object def;
3126       Lisp_Object p;
3127       int iii;
3128       struct gcpro ngcpro1;
3129
3130       if (len == 0)
3131         {
3132           prefix = Qnil;
3133           goto retry;
3134         }
3135
3136       def = Flookup_key (keymap, prefix, Qnil);
3137       def = get_keymap (def, 0, 1);
3138       if (!KEYMAPP (def))
3139         goto RETURN;
3140
3141       keymap = def;
3142       p = make_vector (len, Qnil);
3143       NGCPRO1 (p);
3144       for (iii = 0; iii < len; iii++)
3145         {
3146           struct key_data key;
3147           define_key_parser (Faref (prefix, make_int (iii)), &key);
3148           XVECTOR_DATA (p)[iii] = make_key_description (&key, 1);
3149         }
3150       NUNGCPRO;
3151       prefix = p;
3152     }
3153   else
3154     {
3155       prefix = wrong_type_argument (Qarrayp, prefix);
3156       goto retry;
3157     }
3158
3159   accessible_keymaps = list1 (Fcons (prefix, keymap));
3160
3161   /* For each map in the list maps, look at any other maps it points
3162      to and stick them at the end if they are not already in the list */
3163
3164   for (c.tail = accessible_keymaps;
3165        !NILP (c.tail);
3166        c.tail = XCDR (c.tail))
3167     {
3168       Lisp_Object thismap = Fcdr (Fcar (c.tail));
3169       CHECK_KEYMAP (thismap);
3170       traverse_keymaps (thismap, Qnil,
3171                         accessible_keymaps_keymap_mapper, &c);
3172     }
3173  RETURN:
3174   UNGCPRO;
3175   return accessible_keymaps;
3176 }
3177
3178
3179 \f
3180 /************************************************************************/
3181 /*              Pretty descriptions of key sequences                    */
3182 /************************************************************************/
3183
3184 DEFUN ("key-description", Fkey_description, 1, 1, 0, /*
3185 Return a pretty description of key-sequence KEYS.
3186 Control characters turn into "C-foo" sequences, meta into "M-foo",
3187 spaces are put between sequence elements, etc...
3188 */
3189        (keys))
3190 {
3191   if (CHAR_OR_CHAR_INTP (keys) || CONSP (keys) || SYMBOLP (keys)
3192       || EVENTP (keys))
3193     {
3194       return Fsingle_key_description (keys);
3195     }
3196   else if (VECTORP (keys) ||
3197            STRINGP (keys))
3198     {
3199       Lisp_Object string = Qnil;
3200       /* Lisp_Object sep = Qnil; */
3201       int size = XINT (Flength (keys));
3202       int i;
3203
3204       for (i = 0; i < size; i++)
3205         {
3206           Lisp_Object s2 = Fsingle_key_description
3207             (STRINGP (keys)
3208              ? make_char (string_char (XSTRING (keys), i))
3209              : XVECTOR_DATA (keys)[i]);
3210
3211           if (i == 0)
3212             string = s2;
3213           else
3214             {
3215               /* if (NILP (sep)) Lisp_Object sep = build_string (" ") */;
3216               string = concat2 (string, concat2 (Vsingle_space_string, s2));
3217             }
3218         }
3219       return string;
3220     }
3221   return Fkey_description (wrong_type_argument (Qsequencep, keys));
3222 }
3223
3224 DEFUN ("single-key-description", Fsingle_key_description, 1, 1, 0, /*
3225 Return a pretty description of command character KEY.
3226 Control characters turn into C-whatever, etc.
3227 This differs from `text-char-description' in that it returns a description
3228 of a key read from the user rather than a character from a buffer.
3229 */
3230        (key))
3231 {
3232   if (SYMBOLP (key))
3233     key = Fcons (key, Qnil); /* sleaze sleaze */
3234
3235   if (EVENTP (key) || CHAR_OR_CHAR_INTP (key))
3236     {
3237       char buf [255];
3238       if (!EVENTP (key))
3239         {
3240           Lisp_Event event;
3241           event.event_type = empty_event;
3242           CHECK_CHAR_COERCE_INT (key);
3243           character_to_event (XCHAR (key), &event,
3244                               XCONSOLE (Vselected_console), 0, 1);
3245           format_event_object (buf, &event, 1);
3246         }
3247       else
3248         format_event_object (buf, XEVENT (key), 1);
3249       return build_string (buf);
3250     }
3251
3252   if (CONSP (key))
3253     {
3254       char buf[255];
3255       char *bufp = buf;
3256       Lisp_Object rest;
3257       buf[0] = 0;
3258       LIST_LOOP (rest, key)
3259         {
3260           Lisp_Object keysym = XCAR (rest);
3261           if (EQ (keysym, Qcontrol))    strcpy (bufp, "C-"), bufp += 2;
3262           else if (EQ (keysym, Qctrl))  strcpy (bufp, "C-"), bufp += 2;
3263           else if (EQ (keysym, Qmeta))  strcpy (bufp, "M-"), bufp += 2;
3264           else if (EQ (keysym, Qsuper)) strcpy (bufp, "S-"), bufp += 2;
3265           else if (EQ (keysym, Qhyper)) strcpy (bufp, "H-"), bufp += 2;
3266           else if (EQ (keysym, Qalt))   strcpy (bufp, "A-"), bufp += 2;
3267           else if (EQ (keysym, Qshift)) strcpy (bufp, "Sh-"), bufp += 3;
3268           else if (CHAR_OR_CHAR_INTP (keysym))
3269             {
3270               bufp += set_charptr_emchar ((Bufbyte *) bufp,
3271                                           XCHAR_OR_CHAR_INT (keysym));
3272               *bufp = 0;
3273             }
3274           else
3275             {
3276               CHECK_SYMBOL (keysym);
3277 #if 0                           /* This is bogus */
3278               if (EQ (keysym, QKlinefeed))       strcpy (bufp, "LFD");
3279               else if (EQ (keysym, QKtab))       strcpy (bufp, "TAB");
3280               else if (EQ (keysym, QKreturn))    strcpy (bufp, "RET");
3281               else if (EQ (keysym, QKescape))    strcpy (bufp, "ESC");
3282               else if (EQ (keysym, QKdelete))    strcpy (bufp, "DEL");
3283               else if (EQ (keysym, QKspace))     strcpy (bufp, "SPC");
3284               else if (EQ (keysym, QKbackspace)) strcpy (bufp, "BS");
3285               else
3286 #endif
3287                 strcpy (bufp, (char *) string_data (XSYMBOL (keysym)->name));
3288               if (!NILP (XCDR (rest)))
3289                 signal_simple_error ("Invalid key description",
3290                                      key);
3291             }
3292         }
3293       return build_string (buf);
3294     }
3295   return Fsingle_key_description
3296     (wrong_type_argument (intern ("char-or-event-p"), key));
3297 }
3298
3299 DEFUN ("text-char-description", Ftext_char_description, 1, 1, 0, /*
3300 Return a pretty description of file-character CHR.
3301 Unprintable characters turn into "^char" or \\NNN, depending on the value
3302 of the `ctl-arrow' variable.
3303 This differs from `single-key-description' in that it returns a description
3304 of a character from a buffer rather than a key read from the user.
3305 */
3306        (chr))
3307 {
3308   Bufbyte buf[200];
3309   Bufbyte *p;
3310   Emchar c;
3311   Lisp_Object ctl_arrow = current_buffer->ctl_arrow;
3312   int ctl_p = !NILP (ctl_arrow);
3313   Emchar printable_min = (CHAR_OR_CHAR_INTP (ctl_arrow)
3314                           ? XCHAR_OR_CHAR_INT (ctl_arrow)
3315                           : ((EQ (ctl_arrow, Qt) || NILP (ctl_arrow))
3316                              ? 256 : 160));
3317
3318   if (EVENTP (chr))
3319     {
3320       Lisp_Object ch = Fevent_to_character (chr, Qnil, Qnil, Qt);
3321       if (NILP (ch))
3322         return
3323           signal_simple_continuable_error
3324             ("character has no ASCII equivalent", Fcopy_event (chr, Qnil));
3325       chr = ch;
3326     }
3327
3328   CHECK_CHAR_COERCE_INT (chr);
3329
3330   c = XCHAR (chr);
3331   p = buf;
3332
3333   if (c >= printable_min)
3334     {
3335       p += set_charptr_emchar (p, c);
3336     }
3337   else if (c < 040 && ctl_p)
3338     {
3339       *p++ = '^';
3340       *p++ = c + 64;            /* 'A' - 1 */
3341     }
3342   else if (c == 0177)
3343     {
3344       *p++ = '^';
3345       *p++ = '?';
3346     }
3347   else if (c >= 0200 || c < 040)
3348     {
3349       *p++ = '\\';
3350 #ifdef MULE
3351       /* !!#### This syntax is not readable.  It will
3352          be interpreted as a 3-digit octal number rather
3353          than a 7-digit octal number. */
3354       if (c >= 0400)
3355         {
3356           *p++ = '0' + ((c & 07000000) >> 18);
3357           *p++ = '0' + ((c & 0700000) >> 15);
3358           *p++ = '0' + ((c & 070000) >> 12);
3359           *p++ = '0' + ((c & 07000) >> 9);
3360         }
3361 #endif
3362       *p++ = '0' + ((c & 0700) >> 6);
3363       *p++ = '0' + ((c & 0070) >> 3);
3364       *p++ = '0' + ((c & 0007));
3365     }
3366   else
3367     {
3368       p += set_charptr_emchar (p, c);
3369     }
3370
3371   *p = 0;
3372   return build_string ((char *) buf);
3373 }
3374
3375 \f
3376 /************************************************************************/
3377 /*              where-is (mapping bindings to keys)                     */
3378 /************************************************************************/
3379
3380 static Lisp_Object
3381 where_is_internal (Lisp_Object definition, Lisp_Object *maps, int nmaps,
3382                    Lisp_Object firstonly, char *target_buffer);
3383
3384 DEFUN ("where-is-internal", Fwhere_is_internal, 1, 5, 0, /*
3385 Return list of keys that invoke DEFINITION in KEYMAPS.
3386 KEYMAPS can be either a keymap (meaning search in that keymap and the
3387 current global keymap) or a list of keymaps (meaning search in exactly
3388 those keymaps and no others).  If KEYMAPS is nil, search in the currently
3389 applicable maps for EVENT-OR-KEYS (this is equivalent to specifying
3390 `(current-keymaps EVENT-OR-KEYS)' as the argument to KEYMAPS).
3391
3392 If optional 3rd arg FIRSTONLY is non-nil, return a vector representing
3393  the first key sequence found, rather than a list of all possible key
3394  sequences.
3395
3396 If optional 4th arg NOINDIRECT is non-nil, don't follow indirections
3397  to other keymaps or slots.  This makes it possible to search for an
3398  indirect definition itself.
3399 */
3400        (definition, keymaps, firstonly, noindirect, event_or_keys))
3401 {
3402   /* This function can GC */
3403   Lisp_Object maps[100];
3404   Lisp_Object *gubbish = maps;
3405   int nmaps;
3406
3407   /* Get keymaps as an array */
3408   if (NILP (keymaps))
3409     {
3410       nmaps = get_relevant_keymaps (event_or_keys, countof (maps),
3411                                     gubbish);
3412       if (nmaps > countof (maps))
3413         {
3414           gubbish = alloca_array (Lisp_Object, nmaps);
3415           nmaps = get_relevant_keymaps (event_or_keys, nmaps, gubbish);
3416         }
3417     }
3418   else if (CONSP (keymaps))
3419     {
3420       Lisp_Object rest;
3421       int i;
3422
3423       nmaps = XINT (Flength (keymaps));
3424       if (nmaps > countof (maps))
3425         {
3426           gubbish = alloca_array (Lisp_Object, nmaps);
3427         }
3428       for (rest = keymaps, i = 0; !NILP (rest);
3429            rest = XCDR (keymaps), i++)
3430         {
3431           gubbish[i] = get_keymap (XCAR (keymaps), 1, 1);
3432         }
3433     }
3434   else
3435     {
3436       nmaps = 1;
3437       gubbish[0] = get_keymap (keymaps, 1, 1);
3438       if (!EQ (gubbish[0], Vcurrent_global_map))
3439         {
3440           gubbish[1] = Vcurrent_global_map;
3441           nmaps++;
3442         }
3443     }
3444
3445   return where_is_internal (definition, gubbish, nmaps, firstonly, 0);
3446 }
3447
3448 /* This function is like
3449    (key-description (where-is-internal definition nil t))
3450    except that it writes its output into a (char *) buffer that you
3451    provide; it doesn't cons (or allocate memory) at all, so it's
3452    very fast.  This is used by menubar.c.
3453  */
3454 void
3455 where_is_to_char (Lisp_Object definition, char *buffer)
3456 {
3457   /* This function can GC */
3458   Lisp_Object maps[100];
3459   Lisp_Object *gubbish = maps;
3460   int nmaps;
3461
3462   /* Get keymaps as an array */
3463   nmaps = get_relevant_keymaps (Qnil, countof (maps), gubbish);
3464   if (nmaps > countof (maps))
3465     {
3466       gubbish = alloca_array (Lisp_Object, nmaps);
3467       nmaps = get_relevant_keymaps (Qnil, nmaps, gubbish);
3468     }
3469
3470   buffer[0] = 0;
3471   where_is_internal (definition, maps, nmaps, Qt, buffer);
3472 }
3473
3474
3475 static Lisp_Object
3476 raw_keys_to_keys (struct key_data *keys, int count)
3477 {
3478   Lisp_Object result = make_vector (count, Qnil);
3479   while (count--)
3480     XVECTOR_DATA (result) [count] = make_key_description (&(keys[count]), 1);
3481   return result;
3482 }
3483
3484
3485 static void
3486 format_raw_keys (struct key_data *keys, int count, char *buf)
3487 {
3488   int i;
3489   Lisp_Event event;
3490   event.event_type = key_press_event;
3491   event.channel = Vselected_console;
3492   for (i = 0; i < count; i++)
3493     {
3494       event.event.key.keysym    = keys[i].keysym;
3495       event.event.key.modifiers = keys[i].modifiers;
3496       format_event_object (buf, &event, 1);
3497       buf += strlen (buf);
3498       if (i < count-1)
3499         buf[0] = ' ', buf++;
3500     }
3501 }
3502
3503
3504 /* definition is the thing to look for.
3505    map is a keymap.
3506    shadow is an array of shadow_count keymaps; if there is a different
3507    binding in any of the keymaps of a key that we are considering
3508    returning, then we reconsider.
3509    firstonly means give up after finding the first match;
3510    keys_so_far and modifiers_so_far describe which map we're looking in;
3511    If we're in the "meta" submap of the map that "C-x 4" is bound to,
3512    then keys_so_far will be {(control x), \4}, and modifiers_so_far
3513    will be XEMACS_MOD_META.  That is, keys_so_far is the chain of keys that we
3514    have followed, and modifiers_so_far_so_far is the bits (partial keys)
3515    beyond that.
3516
3517    (keys_so_far is a global buffer and the keys_count arg says how much
3518    of it we're currently interested in.)
3519
3520    If target_buffer is provided, then we write a key-description into it,
3521    to avoid consing a string.  This only works with firstonly on.
3522    */
3523
3524 struct where_is_closure
3525   {
3526     Lisp_Object definition;
3527     Lisp_Object *shadow;
3528     int shadow_count;
3529     int firstonly;
3530     int keys_count;
3531     int modifiers_so_far;
3532     char *target_buffer;
3533     struct key_data *keys_so_far;
3534     int keys_so_far_total_size;
3535     int keys_so_far_malloced;
3536   };
3537
3538 static Lisp_Object where_is_recursive_mapper (Lisp_Object map, void *arg);
3539
3540 static Lisp_Object
3541 where_is_recursive_mapper (Lisp_Object map, void *arg)
3542 {
3543   /* This function can GC */
3544   struct where_is_closure *c = (struct where_is_closure *) arg;
3545   Lisp_Object definition = c->definition;
3546   const int firstonly = c->firstonly;
3547   const int keys_count = c->keys_count;
3548   const int modifiers_so_far = c->modifiers_so_far;
3549   char *target_buffer = c->target_buffer;
3550   Lisp_Object keys = Fgethash (definition,
3551                                XKEYMAP (map)->inverse_table,
3552                                Qnil);
3553   Lisp_Object submaps;
3554   Lisp_Object result = Qnil;
3555
3556   if (!NILP (keys))
3557     {
3558       /* One or more keys in this map match the definition we're looking for.
3559          Verify that these bindings aren't shadowed by other bindings
3560          in the shadow maps.  Either nil or number as value from
3561          raw_lookup_key() means undefined.  */
3562       struct key_data *so_far = c->keys_so_far;
3563
3564       for (;;) /* loop over all keys that match */
3565         {
3566           Lisp_Object k = CONSP (keys) ? XCAR (keys) : keys;
3567           int i;
3568
3569           so_far [keys_count].keysym = k;
3570           so_far [keys_count].modifiers = modifiers_so_far;
3571
3572           /* now loop over all shadow maps */
3573           for (i = 0; i < c->shadow_count; i++)
3574             {
3575               Lisp_Object shadowed = raw_lookup_key (c->shadow[i],
3576                                                      so_far,
3577                                                      keys_count + 1,
3578                                                      0, 1);
3579
3580               if (NILP (shadowed) || CHARP (shadowed) ||
3581                   EQ (shadowed, definition))
3582                 continue; /* we passed this test; it's not shadowed here. */
3583               else
3584                 /* ignore this key binding, since it actually has a
3585                    different binding in a shadowing map */
3586                 goto c_doesnt_have_proper_loop_exit_statements;
3587             }
3588
3589           /* OK, the key is for real */
3590           if (target_buffer)
3591             {
3592               if (!firstonly) ABORT ();
3593               format_raw_keys (so_far, keys_count + 1, target_buffer);
3594               return make_int (1);
3595             }
3596           else if (firstonly)
3597             return raw_keys_to_keys (so_far, keys_count + 1);
3598           else
3599             result = Fcons (raw_keys_to_keys (so_far, keys_count + 1),
3600                             result);
3601
3602         c_doesnt_have_proper_loop_exit_statements:
3603           /* now on to the next matching key ... */
3604           if (!CONSP (keys)) break;
3605           keys = XCDR (keys);
3606         }
3607     }
3608
3609   /* Now search the sub-keymaps of this map.
3610      If we're in "firstonly" mode and have already found one, this
3611      point is not reached.  If we get one from lower down, either
3612      return it immediately (in firstonly mode) or tack it onto the
3613      end of the ones we've gotten so far.
3614      */
3615   for (submaps = keymap_submaps (map);
3616        !NILP (submaps);
3617        submaps = XCDR (submaps))
3618     {
3619       Lisp_Object key    = XCAR (XCAR (submaps));
3620       Lisp_Object submap = XCDR (XCAR (submaps));
3621       int lower_modifiers;
3622       int lower_keys_count = keys_count;
3623       int bucky;
3624
3625       submap = get_keymap (submap, 0, 0);
3626
3627       if (EQ (submap, map))
3628         /* Arrgh!  Some loser has introduced a loop... */
3629         continue;
3630
3631       /* If this is not a keymap, then that's probably because someone
3632          did an `fset' of a symbol that used to point to a map such that
3633          it no longer does.  Sigh.  Ignore this, and invalidate the cache
3634          so that it doesn't happen to us next time too.
3635          */
3636       if (NILP (submap))
3637         {
3638           XKEYMAP (map)->sub_maps_cache = Qt;
3639           continue;
3640         }
3641
3642       /* If the map is a "bucky" map, then add a bit to the
3643          modifiers_so_far list.
3644          Otherwise, add a new raw_key onto the end of keys_so_far.
3645          */
3646       bucky = MODIFIER_HASH_KEY_BITS (key);
3647       if (bucky != 0)
3648         lower_modifiers = (modifiers_so_far | bucky);
3649       else
3650         {
3651           struct key_data *so_far = c->keys_so_far;
3652           lower_modifiers = 0;
3653           so_far [lower_keys_count].keysym = key;
3654           so_far [lower_keys_count].modifiers = modifiers_so_far;
3655           lower_keys_count++;
3656         }
3657
3658       if (lower_keys_count >= c->keys_so_far_total_size)
3659         {
3660           int size = lower_keys_count + 50;
3661           if (! c->keys_so_far_malloced)
3662             {
3663               struct key_data *new = xnew_array (struct key_data, size);
3664               memcpy ((void *)new, (const void *)c->keys_so_far,
3665                       c->keys_so_far_total_size * sizeof (struct key_data));
3666               xfree (c->keys_so_far);
3667               c->keys_so_far = new;
3668             }
3669           else
3670             XREALLOC_ARRAY (c->keys_so_far, struct key_data, size);
3671
3672           c->keys_so_far_total_size = size;
3673           c->keys_so_far_malloced = 1;
3674         }
3675
3676       {
3677         Lisp_Object lower;
3678
3679         c->keys_count = lower_keys_count;
3680         c->modifiers_so_far = lower_modifiers;
3681
3682         lower = traverse_keymaps (submap, Qnil, where_is_recursive_mapper, c);
3683
3684         c->keys_count = keys_count;
3685         c->modifiers_so_far = modifiers_so_far;
3686
3687         if (!firstonly)
3688           result = nconc2 (lower, result);
3689         else if (!NILP (lower))
3690           return lower;
3691       }
3692     }
3693   return result;
3694 }
3695
3696
3697 static Lisp_Object
3698 where_is_internal (Lisp_Object definition, Lisp_Object *maps, int nmaps,
3699                    Lisp_Object firstonly, char *target_buffer)
3700 {
3701   /* This function can GC */
3702   Lisp_Object result = Qnil;
3703   int i;
3704   struct key_data raw[20];
3705   struct where_is_closure c;
3706
3707   c.definition = definition;
3708   c.shadow = maps;
3709   c.firstonly = !NILP (firstonly);
3710   c.target_buffer = target_buffer;
3711   c.keys_so_far = raw;
3712   c.keys_so_far_total_size = countof (raw);
3713   c.keys_so_far_malloced = 0;
3714
3715   /* Loop over each of the maps, accumulating the keys found.
3716      For each map searched, all previous maps shadow this one
3717      so that bogus keys aren't listed. */
3718   for (i = 0; i < nmaps; i++)
3719     {
3720       Lisp_Object this_result;
3721       c.shadow_count = i;
3722       /* Reset the things set in each iteration */
3723       c.keys_count = 0;
3724       c.modifiers_so_far = 0;
3725
3726       this_result = traverse_keymaps (maps[i], Qnil, where_is_recursive_mapper,
3727                                       &c);
3728       if (!NILP (firstonly))
3729         {
3730           result = this_result;
3731           if (!NILP (result))
3732             break;
3733         }
3734       else
3735         result = nconc2 (this_result, result);
3736     }
3737
3738   if (NILP (firstonly))
3739     result = Fnreverse (result);
3740
3741   if (c.keys_so_far_malloced)
3742     xfree (c.keys_so_far);
3743   return result;
3744 }
3745
3746 \f
3747 /************************************************************************/
3748 /*                         Describing keymaps                           */
3749 /************************************************************************/
3750
3751 DEFUN ("describe-bindings-internal", Fdescribe_bindings_internal, 1, 5, 0, /*
3752 Insert a list of all defined keys and their definitions in MAP.
3753 Optional second argument ALL says whether to include even "uninteresting"
3754 definitions (ie symbols with a non-nil `suppress-keymap' property.
3755 Third argument SHADOW is a list of keymaps whose bindings shadow those
3756 of map; if a binding is present in any shadowing map, it is not printed.
3757 Fourth argument PREFIX, if non-nil, should be a key sequence;
3758 only bindings which start with that key sequence will be printed.
3759 Fifth argument MOUSE-ONLY-P says to only print bindings for mouse clicks.
3760 */
3761        (map, all, shadow, prefix, mouse_only_p))
3762 {
3763   /* This function can GC */
3764
3765   /* #### At some point, this function should be changed to accept a
3766      BUFFER argument.  Currently, the BUFFER argument to
3767      describe_map_tree is being used only internally.  */
3768   describe_map_tree (map, NILP (all), shadow, prefix,
3769                      !NILP (mouse_only_p), Fcurrent_buffer ());
3770   return Qnil;
3771 }
3772
3773
3774 /* Insert a description of the key bindings in STARTMAP,
3775     followed by those of all maps reachable through STARTMAP.
3776    If PARTIAL is nonzero, omit certain "uninteresting" commands
3777     (such as `undefined').
3778    If SHADOW is non-nil, it is a list of other maps;
3779     don't mention keys which would be shadowed by any of them
3780    If PREFIX is non-nil, only list bindings which start with those keys.
3781  */
3782
3783 void
3784 describe_map_tree (Lisp_Object startmap, int partial, Lisp_Object shadow,
3785                    Lisp_Object prefix, int mice_only_p, Lisp_Object buffer)
3786 {
3787   /* This function can GC */
3788   Lisp_Object maps = Qnil;
3789   struct gcpro gcpro1, gcpro2;  /* get_keymap may autoload */
3790   GCPRO2 (maps, shadow);
3791
3792   maps = Faccessible_keymaps (startmap, prefix);
3793
3794   for (; !NILP (maps); maps = Fcdr (maps))
3795     {
3796       Lisp_Object sub_shadow = Qnil;
3797       Lisp_Object elt = Fcar (maps);
3798       Lisp_Object tail;
3799       int no_prefix = (VECTORP (Fcar (elt))
3800                        && XINT (Flength (Fcar (elt))) == 0);
3801       struct gcpro ngcpro1, ngcpro2, ngcpro3;
3802       NGCPRO3 (sub_shadow, elt, tail);
3803
3804       for (tail = shadow; CONSP (tail); tail = XCDR (tail))
3805         {
3806           Lisp_Object shmap = XCAR (tail);
3807
3808           /* If the sequence by which we reach this keymap is zero-length,
3809              then the shadow maps for this keymap are just SHADOW.  */
3810           if (no_prefix)
3811             ;
3812           /* If the sequence by which we reach this keymap actually has
3813              some elements, then the sequence's definition in SHADOW is
3814              what we should use.  */
3815           else
3816             {
3817               shmap = Flookup_key (shmap, Fcar (elt), Qt);
3818               if (CHARP (shmap))
3819                 shmap = Qnil;
3820             }
3821
3822           if (!NILP (shmap))
3823             {
3824               Lisp_Object shm = get_keymap (shmap, 0, 1);
3825               /* If shmap is not nil and not a keymap, it completely
3826                  shadows this map, so don't describe this map at all.  */
3827               if (!KEYMAPP (shm))
3828                 goto SKIP;
3829               sub_shadow = Fcons (shm, sub_shadow);
3830             }
3831         }
3832
3833       {
3834         /* Describe the contents of map MAP, assuming that this map
3835            itself is reached by the sequence of prefix keys KEYS (a vector).
3836            PARTIAL and SHADOW are as in `describe_map_tree'.  */
3837         Lisp_Object keysdesc
3838           = ((!no_prefix)
3839              ? concat2 (Fkey_description (Fcar (elt)), Vsingle_space_string)
3840              : Qnil);
3841         describe_map (Fcdr (elt), keysdesc,
3842                       describe_command,
3843                       partial,
3844                       sub_shadow,
3845                       mice_only_p,
3846                       buffer);
3847       }
3848     SKIP:
3849       NUNGCPRO;
3850     }
3851   UNGCPRO;
3852 }
3853
3854
3855 static void
3856 describe_command (Lisp_Object definition, Lisp_Object buffer)
3857 {
3858   /* This function can GC */
3859   int keymapp = !NILP (Fkeymapp (definition));
3860   struct gcpro gcpro1;
3861   GCPRO1 (definition);
3862
3863   Findent_to (make_int (16), make_int (3), buffer);
3864   if (keymapp)
3865     buffer_insert_c_string (XBUFFER (buffer), "<< ");
3866
3867   if (SYMBOLP (definition))
3868     {
3869       buffer_insert1 (XBUFFER (buffer), Fsymbol_name (definition));
3870     }
3871   else if (STRINGP (definition) || VECTORP (definition))
3872     {
3873       buffer_insert_c_string (XBUFFER (buffer), "Kbd Macro: ");
3874       buffer_insert1 (XBUFFER (buffer), Fkey_description (definition));
3875     }
3876   else if (COMPILED_FUNCTIONP (definition))
3877     buffer_insert_c_string (XBUFFER (buffer), "Anonymous Compiled Function");
3878   else if (CONSP (definition) && EQ (XCAR (definition), Qlambda))
3879     buffer_insert_c_string (XBUFFER (buffer), "Anonymous Lambda");
3880   else if (KEYMAPP (definition))
3881     {
3882       Lisp_Object name = XKEYMAP (definition)->name;
3883       if (STRINGP (name) || (SYMBOLP (name) && !NILP (name)))
3884         {
3885           buffer_insert_c_string (XBUFFER (buffer), "Prefix command ");
3886           if (SYMBOLP (name)
3887               && EQ (find_symbol_value (name), definition))
3888             buffer_insert1 (XBUFFER (buffer), Fsymbol_name (name));
3889           else
3890             {
3891               buffer_insert1 (XBUFFER (buffer), Fprin1_to_string (name, Qnil));
3892             }
3893         }
3894       else
3895         buffer_insert_c_string (XBUFFER (buffer), "Prefix Command");
3896     }
3897   else
3898     buffer_insert_c_string (XBUFFER (buffer), "??");
3899
3900   if (keymapp)
3901     buffer_insert_c_string (XBUFFER (buffer), " >>");
3902   buffer_insert_c_string (XBUFFER (buffer), "\n");
3903   UNGCPRO;
3904 }
3905
3906 struct describe_map_closure
3907   {
3908     Lisp_Object *list;   /* pointer to the list to update */
3909     Lisp_Object partial; /* whether to ignore suppressed commands */
3910     Lisp_Object shadow;  /* list of maps shadowing this one */
3911     Lisp_Object self;    /* this map */
3912     Lisp_Object self_root; /* this map, or some map that has this map as
3913                               a parent.  this is the base of the tree */
3914     int mice_only_p;     /* whether we are to display only button bindings */
3915   };
3916
3917 struct describe_map_shadow_closure
3918   {
3919     const struct key_data *raw_key;
3920     Lisp_Object self;
3921   };
3922
3923 static Lisp_Object
3924 describe_map_mapper_shadow_search (Lisp_Object map, void *arg)
3925 {
3926   struct describe_map_shadow_closure *c =
3927     (struct describe_map_shadow_closure *) arg;
3928
3929   if (EQ (map, c->self))
3930     return Qzero;               /* Not shadowed; terminate search */
3931
3932   return !NILP (keymap_lookup_directly (map,
3933                                         c->raw_key->keysym,
3934                                         c->raw_key->modifiers))
3935     ? Qt : Qnil;
3936 }
3937
3938
3939 static Lisp_Object
3940 keymap_lookup_inherited_mapper (Lisp_Object km, void *arg)
3941 {
3942   struct key_data *k = (struct key_data *) arg;
3943   return keymap_lookup_directly (km, k->keysym, k->modifiers);
3944 }
3945
3946
3947 static void
3948 describe_map_mapper (const struct key_data *key,
3949                      Lisp_Object binding,
3950                      void *describe_map_closure)
3951 {
3952   /* This function can GC */
3953   struct describe_map_closure *closure =
3954     (struct describe_map_closure *) describe_map_closure;
3955   Lisp_Object keysym = key->keysym;
3956   int modifiers = key->modifiers;
3957
3958   /* Don't mention suppressed commands.  */
3959   if (SYMBOLP (binding)
3960       && !NILP (closure->partial)
3961       && !NILP (Fget (binding, closure->partial, Qnil)))
3962     return;
3963
3964   /* If we're only supposed to display mouse bindings and this isn't one,
3965      then bug out. */
3966   if (closure->mice_only_p &&
3967       (! (EQ (keysym, Qbutton0) ||
3968           EQ (keysym, Qbutton1) ||
3969           EQ (keysym, Qbutton2) ||
3970           EQ (keysym, Qbutton3) ||
3971           EQ (keysym, Qbutton4) ||
3972           EQ (keysym, Qbutton5) ||
3973           EQ (keysym, Qbutton6) ||
3974           EQ (keysym, Qbutton7) ||
3975           EQ (keysym, Qbutton0up) ||
3976           EQ (keysym, Qbutton1up) ||
3977           EQ (keysym, Qbutton2up) ||
3978           EQ (keysym, Qbutton3up) ||
3979           EQ (keysym, Qbutton4up) ||
3980           EQ (keysym, Qbutton5up) ||
3981           EQ (keysym, Qbutton6up) ||
3982           EQ (keysym, Qbutton7up))))
3983     return;
3984
3985   /* If this command in this map is shadowed by some other map, ignore it. */
3986   {
3987     Lisp_Object tail;
3988
3989     for (tail = closure->shadow; CONSP (tail); tail = XCDR (tail))
3990       {
3991         QUIT;
3992         if (!NILP (traverse_keymaps (XCAR (tail), Qnil,
3993                                      keymap_lookup_inherited_mapper,
3994                                      /* Cast to discard `const' */
3995                                      (void *)key)))
3996           return;
3997       }
3998   }
3999
4000   /* If this key is in some map of which this map is a parent, then ignore
4001      it (in that case, it has been shadowed).
4002      */
4003   {
4004     Lisp_Object sh;
4005     struct describe_map_shadow_closure c;
4006     c.raw_key = key;
4007     c.self = closure->self;
4008
4009     sh = traverse_keymaps (closure->self_root, Qnil,
4010                            describe_map_mapper_shadow_search, &c);
4011     if (!NILP (sh) && !ZEROP (sh))
4012       return;
4013   }
4014
4015   /* Otherwise add it to the list to be sorted. */
4016   *(closure->list) = Fcons (Fcons (Fcons (keysym, make_int (modifiers)),
4017                                    binding),
4018                             *(closure->list));
4019 }
4020
4021
4022 static int
4023 describe_map_sort_predicate (Lisp_Object obj1, Lisp_Object obj2,
4024                              Lisp_Object pred)
4025 {
4026   /* obj1 and obj2 are conses of the form
4027      ( ( <keysym> . <modifiers> ) . <binding> )
4028      keysym and modifiers are used, binding is ignored.
4029    */
4030   int bit1, bit2;
4031   obj1 = XCAR (obj1);
4032   obj2 = XCAR (obj2);
4033   bit1 = XINT (XCDR (obj1));
4034   bit2 = XINT (XCDR (obj2));
4035   if (bit1 != bit2)
4036     return bit1 < bit2 ? 1 : -1;
4037   else
4038     return map_keymap_sort_predicate (obj1, obj2, pred);
4039 }
4040
4041 /* Elide 2 or more consecutive numeric keysyms bound to the same thing,
4042    or 2 or more symbolic keysyms that are bound to the same thing and
4043    have consecutive character-set-properties.
4044  */
4045 static int
4046 elide_next_two_p (Lisp_Object list)
4047 {
4048   Lisp_Object s1, s2;
4049
4050   if (NILP (XCDR (list)))
4051     return 0;
4052
4053   /* next two bindings differ */
4054   if (!EQ (XCDR (XCAR (list)),
4055            XCDR (XCAR (XCDR (list)))))
4056     return 0;
4057
4058   /* next two modifier-sets differ */
4059   if (!EQ (XCDR (XCAR (XCAR (list))),
4060            XCDR (XCAR (XCAR (XCDR (list))))))
4061     return 0;
4062
4063   s1 = XCAR (XCAR (XCAR (list)));
4064   s2 = XCAR (XCAR (XCAR (XCDR (list))));
4065
4066   if (SYMBOLP (s1))
4067     {
4068       Lisp_Object code = Fget (s1, Vcharacter_set_property, Qnil);
4069       if (CHAR_OR_CHAR_INTP (code))
4070         {
4071           s1 = code;
4072           CHECK_CHAR_COERCE_INT (s1);
4073         }
4074       else return 0;
4075     }
4076   if (SYMBOLP (s2))
4077     {
4078       Lisp_Object code = Fget (s2, Vcharacter_set_property, Qnil);
4079       if (CHAR_OR_CHAR_INTP (code))
4080         {
4081           s2 = code;
4082           CHECK_CHAR_COERCE_INT (s2);
4083         }
4084       else return 0;
4085     }
4086
4087   return (XCHAR (s1)     == XCHAR (s2) ||
4088           XCHAR (s1) + 1 == XCHAR (s2));
4089 }
4090
4091
4092 static Lisp_Object
4093 describe_map_parent_mapper (Lisp_Object keymap, void *arg)
4094 {
4095   /* This function can GC */
4096   struct describe_map_closure *describe_map_closure =
4097     (struct describe_map_closure *) arg;
4098   describe_map_closure->self = keymap;
4099   map_keymap (XKEYMAP (keymap)->table,
4100               0, /* don't sort: we'll do it later */
4101               describe_map_mapper, describe_map_closure);
4102   return Qnil;
4103 }
4104
4105
4106 /* Describe the contents of map MAP, assuming that this map itself is
4107    reached by the sequence of prefix keys KEYS (a string or vector).
4108    PARTIAL, SHADOW, NOMENU are as in `describe_map_tree' above.  */
4109
4110 static void
4111 describe_map (Lisp_Object keymap, Lisp_Object elt_prefix,
4112               void (*elt_describer) (Lisp_Object, Lisp_Object),
4113               int partial,
4114               Lisp_Object shadow,
4115               int mice_only_p,
4116               Lisp_Object buffer)
4117 {
4118   /* This function can GC */
4119   struct describe_map_closure describe_map_closure;
4120   Lisp_Object list = Qnil;
4121   struct buffer *buf = XBUFFER (buffer);
4122   Emchar printable_min = (CHAR_OR_CHAR_INTP (buf->ctl_arrow)
4123                           ? XCHAR_OR_CHAR_INT (buf->ctl_arrow)
4124                           : ((EQ (buf->ctl_arrow, Qt)
4125                               || EQ (buf->ctl_arrow, Qnil))
4126                              ? 256 : 160));
4127   int elided = 0;
4128   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4129
4130   keymap = get_keymap (keymap, 1, 1);
4131   describe_map_closure.partial = (partial ? Qsuppress_keymap : Qnil);
4132   describe_map_closure.shadow = shadow;
4133   describe_map_closure.list = &list;
4134   describe_map_closure.self_root = keymap;
4135   describe_map_closure.mice_only_p = mice_only_p;
4136
4137   GCPRO4 (keymap, elt_prefix, shadow, list);
4138
4139   traverse_keymaps (keymap, Qnil,
4140                     describe_map_parent_mapper, &describe_map_closure);
4141
4142   if (!NILP (list))
4143     {
4144       list = list_sort (list, Qnil, describe_map_sort_predicate);
4145       buffer_insert_c_string (buf, "\n");
4146       while (!NILP (list))
4147         {
4148           Lisp_Object elt = XCAR (XCAR (list));
4149           Lisp_Object keysym = XCAR (elt);
4150           int modifiers = XINT (XCDR (elt));
4151
4152           if (!NILP (elt_prefix))
4153             buffer_insert_lisp_string (buf, elt_prefix);
4154
4155           if (modifiers & XEMACS_MOD_META)
4156             buffer_insert_c_string (buf, "M-");
4157           if (modifiers & XEMACS_MOD_CONTROL)
4158             buffer_insert_c_string (buf, "C-");
4159           if (modifiers & XEMACS_MOD_SUPER)
4160             buffer_insert_c_string (buf, "S-");
4161           if (modifiers & XEMACS_MOD_HYPER)
4162             buffer_insert_c_string (buf, "H-");
4163           if (modifiers & XEMACS_MOD_ALT)
4164             buffer_insert_c_string (buf, "Alt-");
4165           if (modifiers & XEMACS_MOD_SHIFT)
4166             buffer_insert_c_string (buf, "Sh-");
4167           if (SYMBOLP (keysym))
4168             {
4169               Lisp_Object code = Fget (keysym, Vcharacter_set_property, Qnil);
4170               Emchar c = (CHAR_OR_CHAR_INTP (code)
4171                           ? XCHAR_OR_CHAR_INT (code) : (Emchar) -1);
4172               /* Calling Fsingle_key_description() would cons more */
4173 #if 0                           /* This is bogus */
4174               if (EQ (keysym, QKlinefeed))
4175                 buffer_insert_c_string (buf, "LFD");
4176               else if (EQ (keysym, QKtab))
4177                 buffer_insert_c_string (buf, "TAB");
4178               else if (EQ (keysym, QKreturn))
4179                 buffer_insert_c_string (buf, "RET");
4180               else if (EQ (keysym, QKescape))
4181                 buffer_insert_c_string (buf, "ESC");
4182               else if (EQ (keysym, QKdelete))
4183                 buffer_insert_c_string (buf, "DEL");
4184               else if (EQ (keysym, QKspace))
4185                 buffer_insert_c_string (buf, "SPC");
4186               else if (EQ (keysym, QKbackspace))
4187                 buffer_insert_c_string (buf, "BS");
4188               else
4189 #endif
4190                 if (c >= printable_min)
4191                   buffer_insert_emacs_char (buf, c);
4192                 else buffer_insert1 (buf, Fsymbol_name (keysym));
4193             }
4194           else if (CHARP (keysym))
4195             buffer_insert_emacs_char (buf, XCHAR (keysym));
4196           else
4197             buffer_insert_c_string (buf, "---bad keysym---");
4198
4199           if (elided)
4200             elided = 0;
4201           else
4202             {
4203               int k = 0;
4204
4205               while (elide_next_two_p (list))
4206                 {
4207                   k++;
4208                   list = XCDR (list);
4209                 }
4210               if (k != 0)
4211                 {
4212                   if (k == 1)
4213                     buffer_insert_c_string (buf, ", ");
4214                   else
4215                     buffer_insert_c_string (buf, " .. ");
4216                   elided = 1;
4217                   continue;
4218                 }
4219             }
4220
4221           /* Print a description of the definition of this character.  */
4222           (*elt_describer) (XCDR (XCAR (list)), buffer);
4223           list = XCDR (list);
4224         }
4225     }
4226   UNGCPRO;
4227 }
4228
4229 \f
4230 void
4231 syms_of_keymap (void)
4232 {
4233   INIT_LRECORD_IMPLEMENTATION (keymap);
4234
4235   defsymbol (&Qminor_mode_map_alist, "minor-mode-map-alist");
4236
4237   defsymbol (&Qkeymapp, "keymapp");
4238
4239   defsymbol (&Qsuppress_keymap, "suppress-keymap");
4240
4241   defsymbol (&Qmodeline_map, "modeline-map");
4242   defsymbol (&Qtoolbar_map, "toolbar-map");
4243
4244   DEFSUBR (Fkeymap_parents);
4245   DEFSUBR (Fset_keymap_parents);
4246   DEFSUBR (Fkeymap_name);
4247   DEFSUBR (Fset_keymap_name);
4248   DEFSUBR (Fkeymap_prompt);
4249   DEFSUBR (Fset_keymap_prompt);
4250   DEFSUBR (Fkeymap_default_binding);
4251   DEFSUBR (Fset_keymap_default_binding);
4252
4253   DEFSUBR (Fkeymapp);
4254   DEFSUBR (Fmake_keymap);
4255   DEFSUBR (Fmake_sparse_keymap);
4256
4257   DEFSUBR (Fcopy_keymap);
4258   DEFSUBR (Fkeymap_fullness);
4259   DEFSUBR (Fmap_keymap);
4260   DEFSUBR (Fevent_matches_key_specifier_p);
4261   DEFSUBR (Fdefine_key);
4262   DEFSUBR (Flookup_key);
4263   DEFSUBR (Fkey_binding);
4264   DEFSUBR (Fuse_global_map);
4265   DEFSUBR (Fuse_local_map);
4266   DEFSUBR (Fcurrent_local_map);
4267   DEFSUBR (Fcurrent_global_map);
4268   DEFSUBR (Fcurrent_keymaps);
4269   DEFSUBR (Faccessible_keymaps);
4270   DEFSUBR (Fkey_description);
4271   DEFSUBR (Fsingle_key_description);
4272   DEFSUBR (Fwhere_is_internal);
4273   DEFSUBR (Fdescribe_bindings_internal);
4274
4275   DEFSUBR (Ftext_char_description);
4276
4277   defsymbol (&Qcontrol, "control");
4278   defsymbol (&Qctrl, "ctrl");
4279   defsymbol (&Qmeta, "meta");
4280   defsymbol (&Qsuper, "super");
4281   defsymbol (&Qhyper, "hyper");
4282   defsymbol (&Qalt, "alt");
4283   defsymbol (&Qshift, "shift");
4284   defsymbol (&Qbutton0, "button0");
4285   defsymbol (&Qbutton1, "button1");
4286   defsymbol (&Qbutton2, "button2");
4287   defsymbol (&Qbutton3, "button3");
4288   defsymbol (&Qbutton4, "button4");
4289   defsymbol (&Qbutton5, "button5");
4290   defsymbol (&Qbutton6, "button6");
4291   defsymbol (&Qbutton7, "button7");
4292   defsymbol (&Qbutton0up, "button0up");
4293   defsymbol (&Qbutton1up, "button1up");
4294   defsymbol (&Qbutton2up, "button2up");
4295   defsymbol (&Qbutton3up, "button3up");
4296   defsymbol (&Qbutton4up, "button4up");
4297   defsymbol (&Qbutton5up, "button5up");
4298   defsymbol (&Qbutton6up, "button6up");
4299   defsymbol (&Qbutton7up, "button7up");
4300   defsymbol (&Qmouse_1, "mouse-1");
4301   defsymbol (&Qmouse_2, "mouse-2");
4302   defsymbol (&Qmouse_3, "mouse-3");
4303   defsymbol (&Qmouse_4, "mouse-4");
4304   defsymbol (&Qmouse_5, "mouse-5");
4305   defsymbol (&Qmouse_6, "mouse-6");
4306   defsymbol (&Qmouse_7, "mouse-7");
4307   defsymbol (&Qdown_mouse_1, "down-mouse-1");
4308   defsymbol (&Qdown_mouse_2, "down-mouse-2");
4309   defsymbol (&Qdown_mouse_3, "down-mouse-3");
4310   defsymbol (&Qdown_mouse_4, "down-mouse-4");
4311   defsymbol (&Qdown_mouse_5, "down-mouse-5");
4312   defsymbol (&Qdown_mouse_6, "down-mouse-6");
4313   defsymbol (&Qdown_mouse_7, "down-mouse-7");
4314   defsymbol (&Qmenu_selection, "menu-selection");
4315   defsymbol (&QLFD, "LFD");
4316   defsymbol (&QTAB, "TAB");
4317   defsymbol (&QRET, "RET");
4318   defsymbol (&QESC, "ESC");
4319   defsymbol (&QDEL, "DEL");
4320   defsymbol (&QSPC, "SPC");
4321   defsymbol (&QBS, "BS");
4322 }
4323
4324 void
4325 vars_of_keymap (void)
4326 {
4327   DEFVAR_LISP ("meta-prefix-char", &Vmeta_prefix_char /*
4328 Meta-prefix character.
4329 This character followed by some character `foo' turns into `Meta-foo'.
4330 This can be any form recognized as a single key specifier.
4331 To disable the meta-prefix-char, set it to a negative number.
4332 */ );
4333   Vmeta_prefix_char = make_char (033);
4334
4335   DEFVAR_LISP ("mouse-grabbed-buffer", &Vmouse_grabbed_buffer /*
4336 A buffer which should be consulted first for all mouse activity.
4337 When a mouse-click is processed, it will first be looked up in the
4338 local-map of this buffer, and then through the normal mechanism if there
4339 is no binding for that click.  This buffer's value of `mode-motion-hook'
4340 will be consulted instead of the `mode-motion-hook' of the buffer of the
4341 window under the mouse.  You should *bind* this, not set it.
4342 */ );
4343   Vmouse_grabbed_buffer = Qnil;
4344
4345   DEFVAR_LISP ("overriding-local-map", &Voverriding_local_map /*
4346 Keymap that overrides all other local keymaps.
4347 If this variable is non-nil, it is used as a keymap instead of the
4348 buffer's local map, and the minor mode keymaps and extent-local keymaps.
4349 You should *bind* this, not set it.
4350 */ );
4351   Voverriding_local_map = Qnil;
4352
4353   Fset (Qminor_mode_map_alist, Qnil);
4354
4355   DEFVAR_LISP ("key-translation-map", &Vkey_translation_map /*
4356 Keymap of key translations that can override keymaps.
4357
4358 This keymap works like `function-key-map', but is searched before it,
4359 and applies even for keys that have ordinary bindings.
4360
4361 The `read-key-sequence' function replaces any subsequence bound by
4362 `key-translation-map' with its binding.  More precisely, when the active
4363 keymaps have no binding for the current key sequence but
4364 `key-translation-map' binds a suffix of the sequence to a vector or string,
4365 `read-key-sequence' replaces the matching suffix with its binding, and
4366 continues with the new sequence.  See `key-binding' for details.
4367
4368 The events that come from bindings in `key-translation-map' are not
4369 themselves looked up in `key-translation-map'.
4370
4371 #### FIXME: stolen from `function-key-map'; need better example.
4372 #### I guess you could implement a Dvorak keyboard with this?
4373 For example, suppose `key-translation-map' binds `ESC O P' to [f1].
4374 Typing `ESC O P' to `read-key-sequence' would return
4375 \[#<keypress-event f1>].  Typing `C-x ESC O P' would return
4376 \[#<keypress-event control-X> #<keypress-event f1>].  If [f1]
4377 were a prefix key, typing `ESC O P x' would return
4378 \[#<keypress-event f1> #<keypress-event x>].
4379 */ );
4380   Vkey_translation_map = Qnil;
4381
4382   DEFVAR_LISP ("vertical-divider-map", &Vvertical_divider_map /*
4383 Keymap which handles mouse clicks over vertical dividers.
4384 */ );
4385   Vvertical_divider_map = Qnil;
4386
4387   DEFVAR_INT ("keymap-tick", &keymap_tick /*
4388 Incremented for each change to any keymap.
4389 */ );
4390   keymap_tick = 0;
4391
4392   staticpro (&Vcurrent_global_map);
4393
4394   Vsingle_space_string = make_string ((const Bufbyte *) " ", 1);
4395   staticpro (&Vsingle_space_string);
4396 }
4397
4398 void
4399 complex_vars_of_keymap (void)
4400 {
4401   /* This function can GC */
4402   Lisp_Object ESC_prefix = intern ("ESC-prefix");
4403   Lisp_Object meta_disgustitute;
4404
4405   Vcurrent_global_map = Fmake_keymap (Qnil);
4406
4407   meta_disgustitute = Fmake_keymap (Qnil);
4408   Ffset (ESC_prefix, meta_disgustitute);
4409   /* no need to protect meta_disgustitute, though */
4410   keymap_store_internal (MAKE_MODIFIER_HASH_KEY (XEMACS_MOD_META),
4411                          XKEYMAP (Vcurrent_global_map),
4412                          meta_disgustitute);
4413   XKEYMAP (Vcurrent_global_map)->sub_maps_cache = Qt;
4414
4415   Vkey_translation_map = Fmake_sparse_keymap (intern ("key-translation-map"));
4416 }