keymap.c 116 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* Manipulation of keymaps
2
   Copyright (C) 1985-1988, 1993-1995, 1998-2011 Free Software Foundation, Inc.
Jim Blandy's avatar
Jim Blandy committed
3 4 5

This file is part of GNU Emacs.

6
GNU Emacs is free software: you can redistribute it and/or modify
Jim Blandy's avatar
Jim Blandy committed
7
it under the terms of the GNU General Public License as published by
8 9
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Jim Blandy's avatar
Jim Blandy committed
10 11 12 13 14 15 16

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
17
along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
Jim Blandy's avatar
Jim Blandy committed
18 19


20
#include <config.h>
Jim Blandy's avatar
Jim Blandy committed
21
#include <stdio.h>
22
#include <setjmp.h>
Jim Blandy's avatar
Jim Blandy committed
23 24 25
#include "lisp.h"
#include "commands.h"
#include "buffer.h"
Kenichi Handa's avatar
Kenichi Handa committed
26
#include "character.h"
Karl Heuer's avatar
Karl Heuer committed
27
#include "charset.h"
Jim Blandy's avatar
Jim Blandy committed
28
#include "keyboard.h"
29
#include "frame.h"
Richard M. Stallman's avatar
Richard M. Stallman committed
30
#include "termhooks.h"
31
#include "blockinput.h"
32
#include "puresize.h"
Dave Love's avatar
Dave Love committed
33
#include "intervals.h"
Stefan Monnier's avatar
Stefan Monnier committed
34
#include "keymap.h"
35
#include "window.h"
Jim Blandy's avatar
Jim Blandy committed
36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58

/* Actually allocate storage for these variables */

Lisp_Object current_global_map;	/* Current global keymap */

Lisp_Object global_map;		/* default global key bindings */

Lisp_Object meta_map;		/* The keymap used for globally bound
				   ESC-prefixed default commands */

Lisp_Object control_x_map;	/* The keymap used for globally bound
				   C-x-prefixed default commands */

				/* The keymap used by the minibuf for local
				   bindings when spaces are allowed in the
				   minibuf */

				/* The keymap used by the minibuf for local
				   bindings when spaces are not encouraged
				   in the minibuf */

/* keymap used for minibuffers when doing completion */
/* keymap used for minibuffers when doing completion and require a match */
59 60 61
static Lisp_Object Qkeymapp, Qnon_ascii;
Lisp_Object Qkeymap, Qmenu_item, Qremap;
static Lisp_Object QCadvertised_binding;
Jim Blandy's avatar
Jim Blandy committed
62

63 64 65
/* Alist of elements like (DEL . "\d").  */
static Lisp_Object exclude_keys;

66 67
/* Pre-allocated 2-element vector for Fcommand_remapping to use.  */
static Lisp_Object command_remapping_vector;
68

69 70 71 72 73
/* Hash table used to cache a reverse-map to speed up calls to where-is.  */
static Lisp_Object where_is_cache;
/* Which keymaps are reverse-stored in the cache.  */
static Lisp_Object where_is_cache_keymaps;

74
static Lisp_Object Flookup_key (Lisp_Object, Lisp_Object, Lisp_Object);
75 76 77 78 79 80 81 82 83 84 85
static Lisp_Object store_in_keymap (Lisp_Object, Lisp_Object, Lisp_Object);
static void fix_submap_inheritance (Lisp_Object, Lisp_Object, Lisp_Object);

static Lisp_Object define_as_prefix (Lisp_Object, Lisp_Object);
static void describe_command (Lisp_Object, Lisp_Object);
static void describe_translation (Lisp_Object, Lisp_Object);
static void describe_map (Lisp_Object, Lisp_Object,
                          void (*) (Lisp_Object, Lisp_Object),
			  int, Lisp_Object, Lisp_Object*, int, int);
static void describe_vector (Lisp_Object, Lisp_Object, Lisp_Object,
                             void (*) (Lisp_Object, Lisp_Object), int,
86
                             Lisp_Object, Lisp_Object, int, int);
87
static void silly_event_symbol_error (Lisp_Object);
Andreas Schwab's avatar
Andreas Schwab committed
88
static Lisp_Object get_keyelt (Lisp_Object, int);
Jim Blandy's avatar
Jim Blandy committed
89

Jim Blandy's avatar
Jim Blandy committed
90 91
/* Keymap object support - constructors and predicates.			*/

92
DEFUN ("make-keymap", Fmake_keymap, Smake_keymap, 0, 1, 0,
93
       doc: /* Construct and return a new keymap, of the form (keymap CHARTABLE . ALIST).
94 95 96 97 98
CHARTABLE is a char-table that holds the bindings for all characters
without modifiers.  All entries in it are initially nil, meaning
"command undefined".  ALIST is an assoc-list which holds bindings for
function keys, mouse events, and any other things that appear in the
input stream.  Initially, ALIST is nil.
99 100 101

The optional arg STRING supplies a menu name for the keymap
in case you use it as a menu with `x-popup-menu'.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
102
  (Lisp_Object string)
Jim Blandy's avatar
Jim Blandy committed
103
{
104 105 106 107 108
  Lisp_Object tail;
  if (!NILP (string))
    tail = Fcons (string, Qnil);
  else
    tail = Qnil;
Jim Blandy's avatar
Jim Blandy committed
109
  return Fcons (Qkeymap,
110
		Fcons (Fmake_char_table (Qkeymap, Qnil), tail));
Jim Blandy's avatar
Jim Blandy committed
111 112
}

Paul Eggert's avatar
Paul Eggert committed
113
DEFUN ("make-sparse-keymap", Fmake_sparse_keymap, Smake_sparse_keymap, 0, 1, 0,
114 115 116 117 118 119 120 121
       doc: /* Construct and return a new sparse keymap.
Its car is `keymap' and its cdr is an alist of (CHAR . DEFINITION),
which binds the character CHAR to DEFINITION, or (SYMBOL . DEFINITION),
which binds the function key or mouse event SYMBOL to DEFINITION.
Initially the alist is nil.

The optional arg STRING supplies a menu name for the keymap
in case you use it as a menu with `x-popup-menu'.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
122
  (Lisp_Object string)
Jim Blandy's avatar
Jim Blandy committed
123
{
124
  if (!NILP (string))
125 126 127 128 129
    {
      if (!NILP (Vpurify_flag))
	string = Fpurecopy (string);
      return Fcons (Qkeymap, Fcons (string, Qnil));
    }
Jim Blandy's avatar
Jim Blandy committed
130 131 132 133 134 135 136 137
  return Fcons (Qkeymap, Qnil);
}

/* This function is used for installing the standard key bindings
   at initialization time.

   For example:

138
   initial_define_key (control_x_map, Ctl('X'), "exchange-point-and-mark");  */
Jim Blandy's avatar
Jim Blandy committed
139 140

void
141
initial_define_key (Lisp_Object keymap, int key, const char *defname)
Jim Blandy's avatar
Jim Blandy committed
142
{
Dan Nicolaescu's avatar
Dan Nicolaescu committed
143
  store_in_keymap (keymap, make_number (key), intern_c_string (defname));
Jim Blandy's avatar
Jim Blandy committed
144 145
}

146
void
147
initial_define_lispy_key (Lisp_Object keymap, const char *keyname, const char *defname)
148
{
Dan Nicolaescu's avatar
Dan Nicolaescu committed
149
  store_in_keymap (keymap, intern_c_string (keyname), intern_c_string (defname));
150 151
}

Jim Blandy's avatar
Jim Blandy committed
152
DEFUN ("keymapp", Fkeymapp, Skeymapp, 1, 1, 0,
153 154 155 156 157 158 159
       doc: /* Return t if OBJECT is a keymap.

A keymap is a list (keymap . ALIST),
or a symbol whose function definition is itself a keymap.
ALIST elements look like (CHAR . DEFN) or (SYMBOL . DEFN);
a vector of densely packed bindings for small character codes
is also allowed as an element.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
160
  (Lisp_Object object)
Jim Blandy's avatar
Jim Blandy committed
161
{
162
  return (KEYMAPP (object) ? Qt : Qnil);
Jim Blandy's avatar
Jim Blandy committed
163 164
}

Paul Eggert's avatar
Paul Eggert committed
165
DEFUN ("keymap-prompt", Fkeymap_prompt, Skeymap_prompt, 1, 1, 0,
166 167 168
       doc: /* Return the prompt-string of a keymap MAP.
If non-nil, the prompt is shown in the echo-area
when reading a key-sequence to be looked-up in this keymap.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
169
  (Lisp_Object map)
170
{
171
  map = get_keymap (map, 0, 0);
172 173
  while (CONSP (map))
    {
174
      Lisp_Object tem = XCAR (map);
175 176
      if (STRINGP (tem))
	return tem;
177
      map = XCDR (map);
178 179 180 181
    }
  return Qnil;
}

Jim Blandy's avatar
Jim Blandy committed
182
/* Check that OBJECT is a keymap (after dereferencing through any
183 184 185 186
   symbols).  If it is, return it.

   If AUTOLOAD is non-zero and OBJECT is a symbol whose function value
   is an autoload form, do the autoload and try again.
187
   If AUTOLOAD is nonzero, callers must assume GC is possible.
188

189 190 191
   If the map needs to be autoloaded, but AUTOLOAD is zero (and ERROR
   is zero as well), return Qt.

192 193 194
   ERROR_IF_NOT_KEYMAP controls how we respond if OBJECT isn't a keymap.
   If ERROR_IF_NOT_KEYMAP is non-zero, signal an error; otherwise,
   just return Qnil.
195 196 197 198 199

   Note that most of the time, we don't want to pursue autoloads.
   Functions like Faccessible_keymaps which scan entire keymap trees
   shouldn't load every autoloaded keymap.  I'm not sure about this,
   but it seems to me that only read_key_sequence, Flookup_key, and
200 201 202 203
   Fdefine_key should cause keymaps to be autoloaded.

   This function can GC when AUTOLOAD is non-zero, because it calls
   do_autoload which can GC.  */
204

Jim Blandy's avatar
Jim Blandy committed
205
Lisp_Object
206
get_keymap (Lisp_Object object, int error_if_not_keymap, int autoload)
Jim Blandy's avatar
Jim Blandy committed
207
{
208
  Lisp_Object tem;
Jim Blandy's avatar
Jim Blandy committed
209

210
 autoload_retry:
211 212 213 214
  if (NILP (object))
    goto end;
  if (CONSP (object) && EQ (XCAR (object), Qkeymap))
    return object;
215

216 217
  tem = indirect_function (object);
  if (CONSP (tem))
218
    {
219 220
      if (EQ (XCAR (tem), Qkeymap))
	return tem;
221

222 223
      /* Should we do an autoload?  Autoload forms for keymaps have
	 Qkeymap as their fifth element.  */
224
      if ((autoload || !error_if_not_keymap) && EQ (XCAR (tem), Qautoload)
225
	  && SYMBOLP (object))
226
	{
227
	  Lisp_Object tail;
228

229 230 231 232 233 234
	  tail = Fnth (make_number (4), tem);
	  if (EQ (tail, Qkeymap))
	    {
	      if (autoload)
		{
		  struct gcpro gcpro1, gcpro2;
235

236 237 238
		  GCPRO2 (tem, object);
		  do_autoload (tem, object);
		  UNGCPRO;
239

240 241 242
		  goto autoload_retry;
		}
	      else
243
	      	return object;
244
	    }
245
	}
246 247
    }

248
 end:
249
  if (error_if_not_keymap)
Jim Blandy's avatar
Jim Blandy committed
250
    wrong_type_argument (Qkeymapp, object);
251
  return Qnil;
Jim Blandy's avatar
Jim Blandy committed
252
}
253

254 255
/* Return the parent map of KEYMAP, or nil if it has none.
   We assume that KEYMAP is a valid keymap.  */
256

257
static Lisp_Object
258
keymap_parent (Lisp_Object keymap, int autoload)
259 260 261
{
  Lisp_Object list;

262
  keymap = get_keymap (keymap, 1, autoload);
263 264

  /* Skip past the initial element `keymap'.  */
265 266
  list = XCDR (keymap);
  for (; CONSP (list); list = XCDR (list))
267 268
    {
      /* See if there is another `keymap'.  */
269
      if (KEYMAPP (list))
270 271 272
	return list;
    }

273
  return get_keymap (list, 0, autoload);
274 275
}

276
DEFUN ("keymap-parent", Fkeymap_parent, Skeymap_parent, 1, 1, 0,
277 278
       doc: /* Return the parent keymap of KEYMAP.
If KEYMAP has no parent, return nil.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
279
  (Lisp_Object keymap)
280 281 282
{
  return keymap_parent (keymap, 1);
}
283

284
/* Check whether MAP is one of MAPS parents.  */
285
static int
286
keymap_memberp (Lisp_Object map, Lisp_Object maps)
287
{
288
  if (NILP (map)) return 0;
289
  while (KEYMAPP (maps) && !EQ (map, maps))
290
    maps = keymap_parent (maps, 0);
291 292 293
  return (EQ (map, maps));
}

294 295
/* Set the parent keymap of MAP to PARENT.  */

Paul Eggert's avatar
Paul Eggert committed
296
DEFUN ("set-keymap-parent", Fset_keymap_parent, Sset_keymap_parent, 2, 2, 0,
297
       doc: /* Modify KEYMAP to set its parent map to PARENT.
298
Return PARENT.  PARENT should be nil or another keymap.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
299
  (Lisp_Object keymap, Lisp_Object parent)
300 301
{
  Lisp_Object list, prev;
302
  struct gcpro gcpro1, gcpro2;
303
  int i;
Jim Blandy's avatar
Jim Blandy committed
304

305 306 307 308 309 310 311 312 313
  /* Force a keymap flush for the next call to where-is.
     Since this can be called from within where-is, we don't set where_is_cache
     directly but only where_is_cache_keymaps, since where_is_cache shouldn't
     be changed during where-is, while where_is_cache_keymaps is only used at
     the very beginning of where-is and can thus be changed here without any
     adverse effect.
     This is a very minor correctness (rather than safety) issue.  */
  where_is_cache_keymaps = Qt;

314
  GCPRO2 (keymap, parent);
315
  keymap = get_keymap (keymap, 1, 1);
316

317
  if (!NILP (parent))
318
    {
319
      parent = get_keymap (parent, 1, 1);
320 321

      /* Check for cycles.  */
322
      if (keymap_memberp (keymap, parent))
323 324
	error ("Cyclic keymap inheritance");
    }
Jim Blandy's avatar
Jim Blandy committed
325

326 327 328 329
  /* Skip past the initial element `keymap'.  */
  prev = keymap;
  while (1)
    {
330
      list = XCDR (prev);
331 332
      /* If there is a parent keymap here, replace it.
	 If we came to the end, add the parent in PREV.  */
333
      if (!CONSP (list) || KEYMAPP (list))
334
	{
335 336
	  /* If we already have the right parent, return now
	     so that we avoid the loops below.  */
337
	  if (EQ (XCDR (prev), parent))
338
	    RETURN_UNGCPRO (parent);
339

340
	  CHECK_IMPURE (prev);
341
	  XSETCDR (prev, parent);
342 343 344 345 346 347 348
	  break;
	}
      prev = list;
    }

  /* Scan through for submaps, and set their parents too.  */

349
  for (list = XCDR (keymap); CONSP (list); list = XCDR (list))
350 351
    {
      /* Stop the scan when we come to the parent.  */
352
      if (EQ (XCAR (list), Qkeymap))
353 354 355
	break;

      /* If this element holds a prefix map, deal with it.  */
356 357 358 359 360 361
      if (CONSP (XCAR (list))
	  && CONSP (XCDR (XCAR (list))))
	fix_submap_inheritance (keymap, XCAR (XCAR (list)),
				XCDR (XCAR (list)));

      if (VECTORP (XCAR (list)))
362
	for (i = 0; i < ASIZE (XCAR (list)); i++)
363
	  if (CONSP (XVECTOR (XCAR (list))->contents[i]))
364
	    fix_submap_inheritance (keymap, make_number (i),
365
				    XVECTOR (XCAR (list))->contents[i]);
366

367
      if (CHAR_TABLE_P (XCAR (list)))
368
	{
369
	  map_char_table (fix_submap_inheritance, Qnil, XCAR (list), keymap);
370
	}
371 372
    }

373
  RETURN_UNGCPRO (parent);
374 375 376 377 378 379
}

/* EVENT is defined in MAP as a prefix, and SUBMAP is its definition.
   if EVENT is also a prefix in MAP's parent,
   make sure that SUBMAP inherits that definition as its own parent.  */

380
static void
381
fix_submap_inheritance (Lisp_Object map, Lisp_Object event, Lisp_Object submap)
382 383 384 385 386 387
{
  Lisp_Object map_parent, parent_entry;

  /* SUBMAP is a cons that we found as a key binding.
     Discard the other things found in a menu key binding.  */

388
  submap = get_keymap (get_keyelt (submap, 0), 0, 0);
389 390

  /* If it isn't a keymap now, there's no work to do.  */
391
  if (!CONSP (submap))
392 393
    return;

394
  map_parent = keymap_parent (map, 0);
395
  if (!NILP (map_parent))
396
    parent_entry =
397
      get_keymap (access_keymap (map_parent, event, 0, 0, 0), 0, 0);
398 399 400
  else
    parent_entry = Qnil;

401
  /* If MAP's parent has something other than a keymap,
402
     our own submap shadows it completely.  */
403
  if (!CONSP (parent_entry))
404
    return;
405

406
  if (! EQ (parent_entry, submap))
407 408 409 410 411 412
    {
      Lisp_Object submap_parent;
      submap_parent = submap;
      while (1)
	{
	  Lisp_Object tem;
413

414
	  tem = keymap_parent (submap_parent, 0);
415 416 417 418 419 420 421 422

	  if (KEYMAPP (tem))
	    {
	      if (keymap_memberp (tem, parent_entry))
		/* Fset_keymap_parent could create a cycle.  */
		return;
	      submap_parent = tem;
	    }
423 424 425 426 427
	  else
	    break;
	}
      Fset_keymap_parent (submap_parent, parent_entry);
    }
428 429
}

Jim Blandy's avatar
Jim Blandy committed
430
/* Look up IDX in MAP.  IDX may be any sort of event.
431
   Note that this does only one level of lookup; IDX must be a single
432
   event, not a sequence.
433 434 435

   If T_OK is non-zero, bindings for Qt are treated as default
   bindings; any key left unmentioned by other tables and bindings is
436
   given the binding of Qt.
437

438 439 440
   If T_OK is zero, bindings for Qt are not treated specially.

   If NOINHERIT, don't accept a subkeymap found in an inherited keymap.  */
Jim Blandy's avatar
Jim Blandy committed
441 442

Lisp_Object
443
access_keymap (Lisp_Object map, Lisp_Object idx, int t_ok, int noinherit, int autoload)
Jim Blandy's avatar
Jim Blandy committed
444
{
445 446 447 448
  Lisp_Object val;

  /* Qunbound in VAL means we have found no binding yet.  */
  val = Qunbound;
449

Jim Blandy's avatar
Jim Blandy committed
450 451 452
  /* If idx is a list (some sort of mouse click, perhaps?),
     the index we want to use is the car of the list, which
     ought to be a symbol.  */
453
  idx = EVENT_HEAD (idx);
Jim Blandy's avatar
Jim Blandy committed
454

455 456
  /* If idx is a symbol, it might have modifiers, which need to
     be put in the canonical order.  */
457
  if (SYMBOLP (idx))
458
    idx = reorder_modifiers (idx);
459 460 461
  else if (INTEGERP (idx))
    /* Clobber the high bits that can be present on a machine
       with more than 24 bits of integer.  */
462
    XSETFASTINT (idx, XINT (idx) & (CHAR_META | (CHAR_META - 1)));
Jim Blandy's avatar
Jim Blandy committed
463

464
  /* Handle the special meta -> esc mapping. */
465
  if (INTEGERP (idx) && XFASTINT (idx) & meta_modifier)
466
    {
467 468
      /* See if there is a meta-map.  If there's none, there is
         no binding for IDX, unless a default binding exists in MAP.  */
469
      struct gcpro gcpro1;
470
      Lisp_Object event_meta_map;
471
      GCPRO1 (map);
472 473
      /* A strange value in which Meta is set would cause
	 infinite recursion.  Protect against that.  */
Stefan Monnier's avatar
Stefan Monnier committed
474
      if (XINT (meta_prefix_char) & CHAR_META)
475
	meta_prefix_char = make_number (27);
476 477 478
      event_meta_map = get_keymap (access_keymap (map, meta_prefix_char,
						  t_ok, noinherit, autoload),
				   0, autoload);
479
      UNGCPRO;
480
      if (CONSP (event_meta_map))
481
	{
482
	  map = event_meta_map;
483
	  idx = make_number (XFASTINT (idx) & ~meta_modifier);
484 485 486 487 488 489 490
	}
      else if (t_ok)
	/* Set IDX to t, so that we only find a default binding.  */
	idx = Qt;
      else
	/* We know there is no binding.  */
	return Qnil;
491 492
    }

493 494 495
  /* t_binding is where we put a default binding that applies,
     to use in case we do not find a binding specifically
     for this key sequence.  */
496 497
  {
    Lisp_Object tail;
498 499
    Lisp_Object t_binding = Qnil;
    struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
500

501
    GCPRO4 (map, tail, idx, t_binding);
502

503
    for (tail = XCDR (map);
504
	 (CONSP (tail)
505
	  || (tail = get_keymap (tail, 0, autoload), CONSP (tail)));
506
	 tail = XCDR (tail))
Jim Blandy's avatar
Jim Blandy committed
507
      {
508
	Lisp_Object binding;
509

510
	binding = XCAR (tail);
511
	if (SYMBOLP (binding))
512
	  {
513 514
	    /* If NOINHERIT, stop finding prefix definitions
	       after we pass a second occurrence of the `keymap' symbol.  */
515
	    if (noinherit && EQ (binding, Qkeymap))
516
	      RETURN_UNGCPRO (Qnil);
517 518 519
	  }
	else if (CONSP (binding))
	  {
520
	    Lisp_Object key = XCAR (binding);
521

522
	    if (EQ (key, idx))
523
	      val = XCDR (binding);
524
	    else if (t_ok && EQ (key, Qt))
525 526
	      {
		t_binding = XCDR (binding);
527
		t_ok = 0;
528
	      }
529 530 531
	  }
	else if (VECTORP (binding))
	  {
532
	    if (INTEGERP (idx) && XFASTINT (idx) < ASIZE (binding))
533
	      val = AREF (binding, XFASTINT (idx));
534
	  }
535 536
	else if (CHAR_TABLE_P (binding))
	  {
537 538 539
	    /* Character codes with modifiers
	       are not included in a char-table.
	       All character codes without modifiers are included.  */
540
	    if (INTEGERP (idx) && (XFASTINT (idx) & CHAR_MODIFIER_MASK) == 0)
541 542 543 544 545 546 547 548
	      {
		val = Faref (binding, idx);
		/* `nil' has a special meaning for char-tables, so
		   we use something else to record an explicitly
		   unbound entry.  */
		if (NILP (val))
		  val = Qunbound;
	      }
549
	  }
550

551 552 553
	/* If we found a binding, clean it up and return it.  */
	if (!EQ (val, Qunbound))
	  {
554 555 556 557 558
	    if (EQ (val, Qt))
	      /* A Qt binding is just like an explicit nil binding
		 (i.e. it shadows any parent binding but not bindings in
		 keymaps of lower precedence).  */
	      val = Qnil;
559 560 561
	    val = get_keyelt (val, autoload);
	    if (KEYMAPP (val))
	      fix_submap_inheritance (map, idx, val);
562
	    RETURN_UNGCPRO (val);
563
	  }
564
	QUIT;
Jim Blandy's avatar
Jim Blandy committed
565
      }
566
    UNGCPRO;
567
    return get_keyelt (t_binding, autoload);
568
  }
Jim Blandy's avatar
Jim Blandy committed
569 570
}

571
static void
572
map_keymap_item (map_keymap_function_t fun, Lisp_Object args, Lisp_Object key, Lisp_Object val, void *data)
573 574 575 576 577 578 579 580 581
{
  /* We should maybe try to detect bindings shadowed by previous
     ones and things like that.  */
  if (EQ (val, Qt))
    val = Qnil;
  (*fun) (key, val, args, data);
}

static void
582
map_keymap_char_table_item (Lisp_Object args, Lisp_Object key, Lisp_Object val)
583 584 585
{
  if (!NILP (val))
    {
586 587
      map_keymap_function_t fun =
	(map_keymap_function_t) XSAVE_VALUE (XCAR (args))->pointer;
588
      args = XCDR (args);
589 590 591 592
      /* If the key is a range, make a copy since map_char_table modifies
	 it in place.  */
      if (CONSP (key))
	key = Fcons (XCAR (key), XCDR (key));
593 594 595 596 597
      map_keymap_item (fun, XCDR (args), key, val,
		       XSAVE_VALUE (XCAR (args))->pointer);
    }
}

598 599
/* Call FUN for every binding in MAP and stop at (and return) the parent.
   FUN is called with 4 arguments: FUN (KEY, BINDING, ARGS, DATA).  */
600
static Lisp_Object
601 602 603 604
map_keymap_internal (Lisp_Object map,
		     map_keymap_function_t fun,
		     Lisp_Object args,
		     void *data)
605 606
{
  struct gcpro gcpro1, gcpro2, gcpro3;
607 608
  Lisp_Object tail
    = (CONSP (map) && EQ (Qkeymap, XCAR (map))) ? XCDR (map) : map;
609 610

  GCPRO3 (map, args, tail);
611
  for (; CONSP (tail) && !EQ (Qkeymap, XCAR (tail)); tail = XCDR (tail))
612 613
    {
      Lisp_Object binding = XCAR (tail);
Kenichi Handa's avatar
Kenichi Handa committed
614

615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630
      if (CONSP (binding))
	map_keymap_item (fun, args, XCAR (binding), XCDR (binding), data);
      else if (VECTORP (binding))
	{
	  /* Loop over the char values represented in the vector.  */
	  int len = ASIZE (binding);
	  int c;
	  for (c = 0; c < len; c++)
	    {
	      Lisp_Object character;
	      XSETFASTINT (character, c);
	      map_keymap_item (fun, args, character, AREF (binding, c), data);
	    }
	}
      else if (CHAR_TABLE_P (binding))
	{
Kenichi Handa's avatar
Kenichi Handa committed
631
	  map_char_table (map_keymap_char_table_item, Qnil, binding,
632
			  Fcons (make_save_value ((void *) fun, 0),
633
				 Fcons (make_save_value (data, 0),
Kenichi Handa's avatar
Kenichi Handa committed
634
					args)));
635 636 637
	}
    }
  UNGCPRO;
638
  return tail;
639 640 641
}

static void
642
map_keymap_call (Lisp_Object key, Lisp_Object val, Lisp_Object fun, void *dummy)
643 644 645 646
{
  call2 (fun, key, val);
}

647 648 649
/* Same as map_keymap_internal, but doesn't traverses parent keymaps as well.
   A non-zero AUTOLOAD indicates that autoloaded keymaps should be loaded.  */
void
650
map_keymap (Lisp_Object map, map_keymap_function_t fun, Lisp_Object args, void *data, int autoload)
651 652 653 654 655 656 657 658 659 660 661 662
{
  struct gcpro gcpro1;
  GCPRO1 (args);
  map = get_keymap (map, 1, autoload);
  while (CONSP (map))
    {
      map = map_keymap_internal (map, fun, args, data);
      map = get_keymap (map, 0, autoload);
    }
  UNGCPRO;
}

663
static Lisp_Object Qkeymap_canonicalize;
664 665 666 667

/* Same as map_keymap, but does it right, properly eliminating duplicate
   bindings due to inheritance.   */
void
668
map_keymap_canonical (Lisp_Object map, map_keymap_function_t fun, Lisp_Object args, void *data)
669 670 671 672 673 674 675 676 677 678 679
{
  struct gcpro gcpro1;
  GCPRO1 (args);
  /* map_keymap_canonical may be used from redisplay (e.g. when building menus)
     so be careful to ignore errors and to inhibit redisplay.  */
  map = safe_call1 (Qkeymap_canonicalize, map);
  /* No need to use `map_keymap' here because canonical map has no parent.  */
  map_keymap_internal (map, fun, args, data);
  UNGCPRO;
}

680 681 682 683 684
DEFUN ("map-keymap-internal", Fmap_keymap_internal, Smap_keymap_internal, 2, 2, 0,
       doc: /* Call FUNCTION once for each event binding in KEYMAP.
FUNCTION is called with two arguments: the event that is bound, and
the definition it is bound to.  The event may be a character range.
If KEYMAP has a parent, this function returns it without processing it.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
685
  (Lisp_Object function, Lisp_Object keymap)
686 687 688 689 690 691 692 693 694
{
  struct gcpro gcpro1;
  GCPRO1 (function);
  keymap = get_keymap (keymap, 1, 1);
  keymap = map_keymap_internal (keymap, map_keymap_call, function, NULL);
  UNGCPRO;
  return keymap;
}

695
DEFUN ("map-keymap", Fmap_keymap, Smap_keymap, 2, 3, 0,
Richard M. Stallman's avatar
Richard M. Stallman committed
696
       doc: /* Call FUNCTION once for each event binding in KEYMAP.
Richard M. Stallman's avatar
Richard M. Stallman committed
697
FUNCTION is called with two arguments: the event that is bound, and
698
the definition it is bound to.  The event may be a character range.
Richard M. Stallman's avatar
Richard M. Stallman committed
699

700 701
If KEYMAP has a parent, the parent's bindings are included as well.
This works recursively: if the parent has itself a parent, then the
702 703
grandparent's bindings are also included and so on.
usage: (map-keymap FUNCTION KEYMAP)  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
704
  (Lisp_Object function, Lisp_Object keymap, Lisp_Object sort_first)
705
{
706
  if (! NILP (sort_first))
707
    return call2 (intern ("map-keymap-sorted"), function, keymap);
708

709 710 711 712
  map_keymap (keymap, map_keymap_call, function, NULL, 1);
  return Qnil;
}

Jim Blandy's avatar
Jim Blandy committed
713 714 715 716 717 718 719
/* Given OBJECT which was found in a slot in a keymap,
   trace indirect definitions to get the actual definition of that slot.
   An indirect definition is a list of the form
   (KEYMAP . INDEX), where KEYMAP is a keymap or a symbol defined as one
   and INDEX is the object to look up in KEYMAP to yield the definition.

   Also if OBJECT has a menu string as the first element,
720 721 722
   remove that.  Also remove a menu help string as second element.

   If AUTOLOAD is nonzero, load autoloadable keymaps
723 724 725
   that are referred to with indirection.

   This can GC because menu_item_eval_property calls Feval.  */
Jim Blandy's avatar
Jim Blandy committed
726

Andreas Schwab's avatar
Andreas Schwab committed
727
static Lisp_Object
728
get_keyelt (Lisp_Object object, int autoload)
Jim Blandy's avatar
Jim Blandy committed
729 730 731
{
  while (1)
    {
732 733 734
      if (!(CONSP (object)))
	/* This is really the value.  */
	return object;
Jim Blandy's avatar
Jim Blandy committed
735

736 737 738 739 740 741 742
      /* If the keymap contents looks like (keymap ...) or (lambda ...)
	 then use itself. */
      else if (EQ (XCAR (object), Qkeymap) || EQ (XCAR (object), Qlambda))
	return object;

      /* If the keymap contents looks like (menu-item name . DEFN)
	 or (menu-item name DEFN ...) then use DEFN.
743
	 This is a new format menu item.  */
744
      else if (EQ (XCAR (object), Qmenu_item))
745
	{
746
	  if (CONSP (XCDR (object)))
747
	    {
748 749
	      Lisp_Object tem;

750
	      object = XCDR (XCDR (object));
751
	      tem = object;
752 753
	      if (CONSP (object))
		object = XCAR (object);
754 755 756

	      /* If there's a `:filter FILTER', apply FILTER to the
		 menu-item's definition to get the real definition to
757
		 use.  */
758
	      for (; CONSP (tem) && CONSP (XCDR (tem)); tem = XCDR (tem))
759
		if (EQ (XCAR (tem), QCfilter) && autoload)
760 761 762 763 764 765 766
		  {
		    Lisp_Object filter;
		    filter = XCAR (XCDR (tem));
		    filter = list2 (filter, list2 (Qquote, object));
		    object = menu_item_eval_property (filter);
		    break;
		  }
767 768
	    }
	  else
769
	    /* Invalid keymap.  */
770
	    return object;
771 772
	}

773
      /* If the keymap contents looks like (STRING . DEFN), use DEFN.
Jim Blandy's avatar
Jim Blandy committed
774 775
	 Keymap alist elements like (CHAR MENUSTRING . DEFN)
	 will be used by HierarKey menus.  */
776
      else if (STRINGP (XCAR (object)))
777
	{
778
	  object = XCDR (object);
779 780
	  /* Also remove a menu help string, if any,
	     following the menu item name.  */
781 782
	  if (CONSP (object) && STRINGP (XCAR (object)))
	    object = XCDR (object);
783
	  /* Also remove the sublist that caches key equivalences, if any.  */
784
	  if (CONSP (object) && CONSP (XCAR (object)))
785
	    {
786
	      Lisp_Object carcar;
787
	      carcar = XCAR (XCAR (object));
788
	      if (NILP (carcar) || VECTORP (carcar))
789
		object = XCDR (object);
790
	    }
791
	}
Jim Blandy's avatar
Jim Blandy committed
792

793 794
      /* If the contents are (KEYMAP . ELEMENT), go indirect.  */
      else
795
	{
796
	  struct gcpro gcpro1;
797
	  Lisp_Object map;
798
	  GCPRO1 (object);
799
	  map = get_keymap (Fcar_safe (object), 0, autoload);
800
	  UNGCPRO;
801
	  return (!CONSP (map) ? object /* Invalid keymap */
802
		  : access_keymap (map, Fcdr (object), 0, 0, autoload));
803
	}
Jim Blandy's avatar
Jim Blandy committed
804 805 806
    }
}

807
static Lisp_Object
808
store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def)
Jim Blandy's avatar
Jim Blandy committed
809
{
810 811 812 813
  /* Flush any reverse-map cache.  */
  where_is_cache = Qnil;
  where_is_cache_keymaps = Qt;

814
  /* If we are preparing to dump, and DEF is a menu element
815 816
     with a menu item indicator, copy it to ensure it is not pure.  */
  if (CONSP (def) && PURE_P (def)
817 818
      && (EQ (XCAR (def), Qmenu_item) || STRINGP (XCAR (def))))
    def = Fcons (XCAR (def), XCDR (def));
819

820
  if (!CONSP (keymap) || !EQ (XCAR (keymap), Qkeymap))
821 822
    error ("attempt to define a key in a non-keymap");

823 824 825 826 827 828 829 830 831
  /* If idx is a cons, and the car part is a character, idx must be of
     the form (FROM-CHAR . TO-CHAR).  */
  if (CONSP (idx) && CHARACTERP (XCAR (idx)))
    CHECK_CHARACTER_CDR (idx);
  else
    /* If idx is a list (some sort of mouse click, perhaps?),
       the index we want to use is the car of the list, which
       ought to be a symbol.  */
    idx = EVENT_HEAD (idx);
Jim Blandy's avatar
Jim Blandy committed
832

833 834
  /* If idx is a symbol, it might have modifiers, which need to
     be put in the canonical order.  */
835
  if (SYMBOLP (idx))
836
    idx = reorder_modifiers (idx);
837 838 839
  else if (INTEGERP (idx))
    /* Clobber the high bits that can be present on a machine
       with more than 24 bits of integer.  */
840
    XSETFASTINT (idx, XINT (idx) & (CHAR_META | (CHAR_META - 1)));
841 842

  /* Scan the keymap for a binding of idx.  */
Jim Blandy's avatar
Jim Blandy committed
843
  {
844
    Lisp_Object tail;
Jim Blandy's avatar
Jim Blandy committed
845

846 847 848 849 850 851
    /* The cons after which we should insert new bindings.  If the
       keymap has a table element, we record its position here, so new
       bindings will go after it; this way, the table will stay
       towards the front of the alist and character lookups in dense
       keymaps will remain fast.  Otherwise, this just points at the
       front of the keymap.  */
852
    Lisp_Object insertion_point;
Jim Blandy's avatar
Jim Blandy committed
853

854
    insertion_point = keymap;
855
    for (tail = XCDR (keymap); CONSP (tail); tail = XCDR (tail))
Jim Blandy's avatar
Jim Blandy committed
856
      {
857
	Lisp_Object elt;
858

859
	elt = XCAR (tail);
860
	if (VECTORP (elt))
861
	  {
862
	    if (NATNUMP (idx) && XFASTINT (idx) < ASIZE (elt))
863
	      {
864
		CHECK_IMPURE (elt);