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
/* The number of elements in keymap vectors.  */
Jim Blandy's avatar
Jim Blandy committed
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
#define DENSE_TABLE_SIZE (0200)

/* 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 */
62
Lisp_Object Qkeymapp, Qkeymap, Qnon_ascii, Qmenu_item, Qremap;
63
Lisp_Object QCadvertised_binding;
Jim Blandy's avatar
Jim Blandy committed
64

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

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

71 72 73 74 75
/* 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;

76 77 78 79 80 81 82 83 84 85 86 87 88 89
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,
                             Lisp_Object, Lisp_Object, int *,
                             int, int, int);
static void silly_event_symbol_error (Lisp_Object);
Andreas Schwab's avatar
Andreas Schwab committed
90
static Lisp_Object get_keyelt (Lisp_Object, int);
Jim Blandy's avatar
Jim Blandy committed
91

Jim Blandy's avatar
Jim Blandy committed
92 93
/* Keymap object support - constructors and predicates.			*/

94
DEFUN ("make-keymap", Fmake_keymap, Smake_keymap, 0, 1, 0,
95
       doc: /* Construct and return a new keymap, of the form (keymap CHARTABLE . ALIST).
96 97 98 99 100
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.
101 102 103

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
104
  (Lisp_Object string)
Jim Blandy's avatar
Jim Blandy committed
105
{
106 107 108 109 110
  Lisp_Object tail;
  if (!NILP (string))
    tail = Fcons (string, Qnil);
  else
    tail = Qnil;
Jim Blandy's avatar
Jim Blandy committed
111
  return Fcons (Qkeymap,
112
		Fcons (Fmake_char_table (Qkeymap, Qnil), tail));
Jim Blandy's avatar
Jim Blandy committed
113 114
}

115
DEFUN ("make-sparse-keymap", Fmake_sparse_keymap, Smake_sparse_keymap, 0, 1, 0,
116 117 118 119 120 121 122 123
       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
124
  (Lisp_Object string)
Jim Blandy's avatar
Jim Blandy committed
125
{
126
  if (!NILP (string))
127 128 129 130 131
    {
      if (!NILP (Vpurify_flag))
	string = Fpurecopy (string);
      return Fcons (Qkeymap, Fcons (string, Qnil));
    }
Jim Blandy's avatar
Jim Blandy committed
132 133 134 135 136 137 138 139
  return Fcons (Qkeymap, Qnil);
}

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

   For example:

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

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

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

Jim Blandy's avatar
Jim Blandy committed
154
DEFUN ("keymapp", Fkeymapp, Skeymapp, 1, 1, 0,
155 156 157 158 159 160 161
       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
162
  (Lisp_Object object)
Jim Blandy's avatar
Jim Blandy committed
163
{
164
  return (KEYMAPP (object) ? Qt : Qnil);
Jim Blandy's avatar
Jim Blandy committed
165 166
}

167
DEFUN ("keymap-prompt", Fkeymap_prompt, Skeymap_prompt, 1, 1, 0,
168 169 170
       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
171
  (Lisp_Object map)
172
{
173
  map = get_keymap (map, 0, 0);
174 175
  while (CONSP (map))
    {
176
      Lisp_Object tem = XCAR (map);
177 178
      if (STRINGP (tem))
	return tem;
179
      map = XCDR (map);
180 181 182 183
    }
  return Qnil;
}

Jim Blandy's avatar
Jim Blandy committed
184
/* Check that OBJECT is a keymap (after dereferencing through any
185 186 187 188
   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.
189
   If AUTOLOAD is nonzero, callers must assume GC is possible.
190

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

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

   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
201 202 203 204
   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.  */
205

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

306 307 308 309 310 311 312 313 314
  /* 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;

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

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

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

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

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

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

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

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

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

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

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

/* 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.  */

381
static void
382
fix_submap_inheritance (Lisp_Object map, Lisp_Object event, Lisp_Object submap)
383 384 385 386 387 388
{
  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.  */

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

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

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

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

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

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

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

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

439 440 441
   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
442 443

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

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

Jim Blandy's avatar
Jim Blandy committed
451 452 453
  /* 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.  */
454
  idx = EVENT_HEAD (idx);
Jim Blandy's avatar
Jim Blandy committed
455

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

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

494 495 496
  /* 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.  */
497 498
  {
    Lisp_Object tail;
499 500
    Lisp_Object t_binding = Qnil;
    struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
501

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

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

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

523
	    if (EQ (key, idx))
524
	      val = XCDR (binding);
525
	    else if (t_ok && EQ (key, Qt))
526 527
	      {
		t_binding = XCDR (binding);
528
		t_ok = 0;
529
	      }
530 531 532
	  }
	else if (VECTORP (binding))
	  {
533 534
	    if (NATNUMP (idx) && XFASTINT (idx) < ASIZE (binding))
	      val = AREF (binding, XFASTINT (idx));
535
	  }
536 537
	else if (CHAR_TABLE_P (binding))
	  {
538 539 540
	    /* Character codes with modifiers
	       are not included in a char-table.
	       All character codes without modifiers are included.  */
541 542 543 544 545 546 547 548 549
	    if (NATNUMP (idx) && (XFASTINT (idx) & CHAR_MODIFIER_MASK) == 0)
	      {
		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;
	      }
550
	  }
551

552 553 554
	/* If we found a binding, clean it up and return it.  */
	if (!EQ (val, Qunbound))
	  {
555 556 557 558 559
	    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;
560 561 562
	    val = get_keyelt (val, autoload);
	    if (KEYMAPP (val))
	      fix_submap_inheritance (map, idx, val);
563
	    RETURN_UNGCPRO (val);
564
	  }
565
	QUIT;
Jim Blandy's avatar
Jim Blandy committed
566
      }
567
    UNGCPRO;
568
    return get_keyelt (t_binding, autoload);
569
  }
Jim Blandy's avatar
Jim Blandy committed
570 571
}

572
static void
573
map_keymap_item (map_keymap_function_t fun, Lisp_Object args, Lisp_Object key, Lisp_Object val, void *data)
574 575 576 577 578 579 580 581 582
{
  /* 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
583
map_keymap_char_table_item (Lisp_Object args, Lisp_Object key, Lisp_Object val)
584 585 586
{
  if (!NILP (val))
    {
587 588
      map_keymap_function_t fun =
	(map_keymap_function_t) XSAVE_VALUE (XCAR (args))->pointer;
589
      args = XCDR (args);
590 591 592 593
      /* 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));
594 595 596 597 598
      map_keymap_item (fun, XCDR (args), key, val,
		       XSAVE_VALUE (XCAR (args))->pointer);
    }
}

599 600 601 602 603 604 605
/* 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).  */
Lisp_Object
map_keymap_internal (Lisp_Object map,
		     map_keymap_function_t fun,
		     Lisp_Object args,
		     void *data)
606 607
{
  struct gcpro gcpro1, gcpro2, gcpro3;
608 609
  Lisp_Object tail
    = (CONSP (map) && EQ (Qkeymap, XCAR (map))) ? XCDR (map) : map;
610 611

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

616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631
      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
632
	  map_char_table (map_keymap_char_table_item, Qnil, binding,
633
			  Fcons (make_save_value ((void *) fun, 0),
634
				 Fcons (make_save_value (data, 0),
Kenichi Handa's avatar
Kenichi Handa committed
635
					args)));
636 637 638
	}
    }
  UNGCPRO;
639
  return tail;
640 641 642
}

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

648 649 650
/* 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
651
map_keymap (Lisp_Object map, map_keymap_function_t fun, Lisp_Object args, void *data, int autoload)
652 653 654 655 656 657 658 659 660 661 662 663
{
  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;
}

664 665 666 667 668
Lisp_Object Qkeymap_canonicalize;

/* Same as map_keymap, but does it right, properly eliminating duplicate
   bindings due to inheritance.   */
void
669
map_keymap_canonical (Lisp_Object map, map_keymap_function_t fun, Lisp_Object args, void *data)
670 671 672 673 674 675 676 677 678 679 680
{
  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;
}

681 682 683 684 685
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
686
  (Lisp_Object function, Lisp_Object keymap)
687 688 689 690 691 692 693 694 695
{
  struct gcpro gcpro1;
  GCPRO1 (function);
  keymap = get_keymap (keymap, 1, 1);
  keymap = map_keymap_internal (keymap, map_keymap_call, function, NULL);
  UNGCPRO;
  return keymap;
}

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

701 702
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
703 704
grandparent's bindings are also included and so on.
usage: (map-keymap FUNCTION KEYMAP)  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
705
  (Lisp_Object function, Lisp_Object keymap, Lisp_Object sort_first)
706
{
707
  if (! NILP (sort_first))
708
    return call2 (intern ("map-keymap-sorted"), function, keymap);
709

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

Jim Blandy's avatar
Jim Blandy committed
714 715 716 717 718 719 720
/* 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,
721 722 723
   remove that.  Also remove a menu help string as second element.

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

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

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

737 738 739 740 741 742 743
      /* 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.
744
	 This is a new format menu item.  */
745
      else if (EQ (XCAR (object), Qmenu_item))
746
	{
747
	  if (CONSP (XCDR (object)))
748
	    {
749 750
	      Lisp_Object tem;

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

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

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

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

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

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

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

824 825 826 827 828 829 830 831 832
  /* 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
833

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

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

847 848 849 850 851 852
    /* 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.  */
853
    Lisp_Object insertion_point;
Jim Blandy's avatar
Jim Blandy committed
854

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

860
	elt = XCAR (tail);
861
	if (VECTORP (elt))
862
	  {
863
	    if (NATNUMP (idx) && XFASTINT (idx) < ASIZE (elt))
864
	      {
865
		CHECK_IMPURE (elt);
866
		ASET (elt, XFASTINT (idx), def);
867 868
		return def;
	      }
869 870 871 872 873 874 875 876 877 878 879 880 881
	    else if (CONSP (idx) && CHARACTERP (XCAR (idx)))
	      {
		int from = XFASTINT (XCAR (idx));
		int to = XFASTINT (XCDR (idx));

		if (to >= ASIZE (elt))
		  to = ASIZE (elt) - 1;
		for (; from <= to; from++)
		  ASET (elt, from, def);
		if (to == XFASTINT (XCDR (idx)))
		  /* We have defined all keys in IDX.  */
		  return def;
	      }
882
	    insertion_point = tail;
883
	  }
884 885
	else if (CHAR_TABLE_P (elt))
	  {
886 887 888
	    /* Character codes with modifiers
	       are not included in a char-table.
	       All character codes without modifiers are included.  */
889
	    if (NATNUMP (idx) && !(XFASTINT (idx) & CHAR_MODIFIER_MASK))
890
	      {
891 892 893 894 895
		Faset (elt, idx,
		       /*