subr.el 166 KB
Newer Older
1
;;; subr.el --- basic lisp subroutines for Emacs  -*- coding: utf-8 -*-
Eric S. Raymond's avatar
Eric S. Raymond committed
2

3
;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2012
4
;;   Free Software Foundation, Inc.
David Lawrence's avatar
David Lawrence committed
5

Pavel Janík's avatar
Pavel Janík committed
6 7
;; Maintainer: FSF
;; Keywords: internal
8
;; Package: emacs
Pavel Janík's avatar
Pavel Janík committed
9

David Lawrence's avatar
David Lawrence committed
10 11
;; This file is part of GNU Emacs.

12
;; GNU Emacs is free software: you can redistribute it and/or modify
David Lawrence's avatar
David Lawrence committed
13
;; it under the terms of the GNU General Public License as published by
14 15
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
David Lawrence's avatar
David Lawrence committed
16 17 18 19 20 21 22

;; 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
23
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
David Lawrence's avatar
David Lawrence committed
24

25 26
;;; Commentary:

Eric S. Raymond's avatar
Eric S. Raymond committed
27
;;; Code:
28

29 30 31 32
(defvar custom-declare-variable-list nil
  "Record `defcustom' calls made before `custom.el' is loaded to handle them.
Each element of this list holds the arguments to one call to `defcustom'.")

Richard M. Stallman's avatar
Richard M. Stallman committed
33
;; Use this, rather than defcustom, in subr.el and other files loaded
34 35 36 37
;; before custom.el.
(defun custom-declare-variable-early (&rest arguments)
  (setq custom-declare-variable-list
	(cons arguments custom-declare-variable-list)))
38

39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
(defmacro declare-function (fn file &optional arglist fileonly)
  "Tell the byte-compiler that function FN is defined, in FILE.
Optional ARGLIST is the argument list used by the function.  The
FILE argument is not used by the byte-compiler, but by the
`check-declare' package, which checks that FILE contains a
definition for FN.  ARGLIST is used by both the byte-compiler and
`check-declare' to check for consistency.

FILE can be either a Lisp file (in which case the \".el\"
extension is optional), or a C file.  C files are expanded
relative to the Emacs \"src/\" directory.  Lisp files are
searched for using `locate-library', and if that fails they are
expanded relative to the location of the file containing the
declaration.  A FILE with an \"ext:\" prefix is an external file.
`check-declare' will check such files if they are found, and skip
them without error if they are not.

FILEONLY non-nil means that `check-declare' will only check that
FILE exists, not that it defines FN.  This is intended for
function-definitions that `check-declare' does not recognize, e.g.
`defstruct'.

To specify a value for FILEONLY without passing an argument list,
62
set ARGLIST to t.  This is necessary because nil means an
63 64 65
empty argument list, rather than an unspecified one.

Note that for the purposes of `check-declare', this statement
Glenn Morris's avatar
Glenn Morris committed
66
must be the first non-whitespace on a line.
67

Glenn Morris's avatar
Glenn Morris committed
68
For more information, see Info node `(elisp)Declaring Functions'."
69 70
  ;; Does nothing - byte-compile-declare-function does the work.
  nil)
Eli Zaretskii's avatar
Eli Zaretskii committed
71

72

73
;;;; Basic Lisp macros.
74

Stefan Monnier's avatar
Stefan Monnier committed
75 76
(defalias 'not 'null)

Kenichi Handa's avatar
Kenichi Handa committed
77
(defmacro noreturn (form)
Luc Teirlinck's avatar
Luc Teirlinck committed
78 79
  "Evaluate FORM, expecting it not to return.
If FORM does return, signal an error."
Kenichi Handa's avatar
Kenichi Handa committed
80 81 82 83
  `(prog1 ,form
     (error "Form marked with `noreturn' did return")))

(defmacro 1value (form)
Luc Teirlinck's avatar
Luc Teirlinck committed
84 85 86
  "Evaluate FORM, expecting a constant return value.
This is the global do-nothing version.  There is also `testcover-1value'
that complains if FORM ever does return differing values."
Kenichi Handa's avatar
Kenichi Handa committed
87 88
  form)

89 90
(defmacro def-edebug-spec (symbol spec)
  "Set the `edebug-form-spec' property of SYMBOL according to SPEC.
Glenn Morris's avatar
Glenn Morris committed
91 92 93 94
Both SYMBOL and SPEC are unevaluated.  The SPEC can be:
0 (instrument no arguments); t (instrument all arguments);
a symbol (naming a function with an Edebug specification); or a list.
The elements of the list describe the argument types; see
95
Info node `(elisp)Specification List' for details."
96 97
  `(put (quote ,symbol) 'edebug-form-spec (quote ,spec)))

98 99 100 101 102
(defmacro lambda (&rest cdr)
  "Return a lambda expression.
A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
self-quoting; the result of evaluating the lambda expression is the
expression itself.  The lambda expression may then be treated as a
Richard M. Stallman's avatar
Richard M. Stallman committed
103
function, i.e., stored as the function value of a symbol, passed to
104
`funcall' or `mapcar', etc.
Richard M. Stallman's avatar
Richard M. Stallman committed
105

106
ARGS should take the same form as an argument list for a `defun'.
Richard M. Stallman's avatar
Richard M. Stallman committed
107 108 109
DOCSTRING is an optional documentation string.
 If present, it should describe how to call the function.
 But documentation strings are usually not useful in nameless functions.
110 111
INTERACTIVE should be a call to the function `interactive', which see.
It may also be omitted.
112 113 114
BODY should be a list of Lisp expressions.

\(fn ARGS [DOCSTRING] [INTERACTIVE] BODY)"
115 116 117 118
  ;; Note that this definition should not use backquotes; subr.el should not
  ;; depend on backquote.el.
  (list 'function (cons 'lambda cdr)))

119 120 121 122 123 124
(defun apply-partially (fun &rest args)
  "Return a function that is a partial application of FUN to ARGS.
ARGS is a list of the first N arguments to pass to FUN.
The result is a new function which does the same as FUN, except that
the first N arguments are fixed at the values with which this function
was called."
125
  `(closure (t) (&rest args)
126 127
            (apply ',fun ,@(mapcar (lambda (arg) `',arg) args) args)))

128 129
(if (null (featurep 'cl))
    (progn
130 131 132
  ;; If we reload subr.el after having loaded CL, be careful not to
  ;; overwrite CL's extended definition of `dolist', `dotimes',
  ;; `declare', `push' and `pop'.
Richard M. Stallman's avatar
Richard M. Stallman committed
133
(defmacro push (newelt listname)
Richard M. Stallman's avatar
Richard M. Stallman committed
134
  "Add NEWELT to the list stored in the symbol LISTNAME.
Richard M. Stallman's avatar
Richard M. Stallman committed
135
This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)).
Richard M. Stallman's avatar
Richard M. Stallman committed
136
LISTNAME must be a symbol."
137
  (declare (debug (form sexp)))
Dave Love's avatar
Dave Love committed
138
  (list 'setq listname
139
        (list 'cons newelt listname)))
Richard M. Stallman's avatar
Richard M. Stallman committed
140 141 142 143 144 145

(defmacro pop (listname)
  "Return the first element of LISTNAME's value, and remove it from the list.
LISTNAME must be a symbol whose value is a list.
If the value is nil, `pop' returns nil but does not actually
change the list."
146
  (declare (debug (sexp)))
147
  (list 'car
148
        (list 'prog1 listname
149 150
              (list 'setq listname (list 'cdr listname)))))
))
Richard M. Stallman's avatar
Richard M. Stallman committed
151

152
(defmacro when (cond &rest body)
Kim F. Storm's avatar
Kim F. Storm committed
153 154 155 156
  "If COND yields non-nil, do BODY, else return nil.
When COND yields non-nil, eval BODY forms sequentially and return
value of last one, or nil if there are none.

Juanma Barranquero's avatar
Juanma Barranquero committed
157
\(fn COND BODY...)"
158
  (declare (indent 1) (debug t))
159
  (list 'if cond (cons 'progn body)))
160

161
(defmacro unless (cond &rest body)
Kim F. Storm's avatar
Kim F. Storm committed
162 163 164 165
  "If COND yields nil, do BODY, else return nil.
When COND yields nil, eval BODY forms sequentially and return
value of last one, or nil if there are none.

Juanma Barranquero's avatar
Juanma Barranquero committed
166
\(fn COND BODY...)"
167
  (declare (indent 1) (debug t))
168
  (cons 'if (cons cond (cons nil body))))
169

170 171
(if (null (featurep 'cl))
    (progn
172 173
  ;; If we reload subr.el after having loaded CL, be careful not to
  ;; overwrite CL's extended definition of `dolist', `dotimes',
174
  ;; `declare', `push' and `pop'.
175

176
(defmacro dolist (spec &rest body)
177
  "Loop over a list.
178
Evaluate BODY with VAR bound to each car from LIST, in turn.
179 180
Then evaluate RESULT to get return value, default nil.

Markus Rost's avatar
Markus Rost committed
181
\(fn (VAR LIST [RESULT]) BODY...)"
182
  (declare (indent 1) (debug ((symbolp form &optional form) body)))
183 184 185
  ;; It would be cleaner to create an uninterned symbol,
  ;; but that uses a lot more space when many functions in many files
  ;; use dolist.
186
  ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
187
  (let ((temp '--dolist-tail--))
188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208
    ;; This is not a reliable test, but it does not matter because both
    ;; semantics are acceptable, tho one is slightly faster with dynamic
    ;; scoping and the other is slightly faster (and has cleaner semantics)
    ;; with lexical scoping.
    (if lexical-binding
        `(let ((,temp ,(nth 1 spec)))
           (while ,temp
             (let ((,(car spec) (car ,temp)))
               ,@body
               (setq ,temp (cdr ,temp))))
           ,@(if (cdr (cdr spec))
                 ;; FIXME: This let often leads to "unused var" warnings.
                 `((let ((,(car spec) nil)) ,@(cdr (cdr spec))))))
      `(let ((,temp ,(nth 1 spec))
             ,(car spec))
         (while ,temp
           (setq ,(car spec) (car ,temp))
           ,@body
           (setq ,temp (cdr ,temp)))
         ,@(if (cdr (cdr spec))
               `((setq ,(car spec) nil) ,@(cdr (cdr spec))))))))
209

210
(defmacro dotimes (spec &rest body)
211
  "Loop a certain number of times.
212 213
Evaluate BODY with VAR bound to successive integers running from 0,
inclusive, to COUNT, exclusive.  Then evaluate RESULT to get
214 215
the return value (nil if RESULT is omitted).

Markus Rost's avatar
Markus Rost committed
216
\(fn (VAR COUNT [RESULT]) BODY...)"
217
  (declare (indent 1) (debug dolist))
218 219 220
  ;; It would be cleaner to create an uninterned symbol,
  ;; but that uses a lot more space when many functions in many files
  ;; use dotimes.
221
  ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
222
  (let ((temp '--dotimes-limit--)
223 224
	(start 0)
	(end (nth 1 spec)))
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
    ;; This is not a reliable test, but it does not matter because both
    ;; semantics are acceptable, tho one is slightly faster with dynamic
    ;; scoping and the other has cleaner semantics.
    (if lexical-binding
        (let ((counter '--dotimes-counter--))
          `(let ((,temp ,end)
                 (,counter ,start))
             (while (< ,counter ,temp)
               (let ((,(car spec) ,counter))
                 ,@body)
               (setq ,counter (1+ ,counter)))
             ,@(if (cddr spec)
                   ;; FIXME: This let often leads to "unused var" warnings.
                   `((let ((,(car spec) ,counter)) ,@(cddr spec))))))
      `(let ((,temp ,end)
             (,(car spec) ,start))
         (while (< ,(car spec) ,temp)
           ,@body
           (setq ,(car spec) (1+ ,(car spec))))
         ,@(cdr (cdr spec))))))
245

246
(defmacro declare (&rest _specs)
Kenichi Handa's avatar
Kenichi Handa committed
247 248
  "Do not evaluate any arguments and return nil.
Treated as a declaration when used at the right place in a
249
`defmacro' form.  \(See Info anchor `(elisp)Definition of declare'.)"
250 251
  nil)
))
252 253 254 255

(defmacro ignore-errors (&rest body)
  "Execute BODY; if an error occurs, return nil.
Otherwise, return result of last form in BODY."
256
  (declare (debug t) (indent 0))
257
  `(condition-case nil (progn ,@body) (error nil)))
258 259 260

;;;; Basic Lisp functions.

261
(defun ignore (&rest _ignore)
262 263 264 265 266
  "Do nothing and return nil.
This function accepts any number of arguments, but ignores them."
  (interactive)
  nil)

267
;; Signal a compile-error if the first arg is missing.
268 269 270 271
(defun error (&rest args)
  "Signal an error, making error message by passing all args to `format'.
In Emacs, the convention is that error messages start with a capital
letter but *do not* end with a period.  Please follow this convention
272
for the sake of consistency."
273 274
  (while t
    (signal 'error (list (apply 'format args)))))
275
(set-advertised-calling-convention 'error '(string &rest args) "23.1")
276 277 278 279 280 281 282 283 284 285 286

;; We put this here instead of in frame.el so that it's defined even on
;; systems where frame.el isn't loaded.
(defun frame-configuration-p (object)
  "Return non-nil if OBJECT seems to be a frame configuration.
Any list whose car is `frame-configuration' is assumed to be a frame
configuration."
  (and (consp object)
       (eq (car object) 'frame-configuration)))

;;;; List functions.
Kenichi Handa's avatar
Kenichi Handa committed
287

288 289 290 291 292 293 294 295 296 297 298 299 300 301 302
(defsubst caar (x)
  "Return the car of the car of X."
  (car (car x)))

(defsubst cadr (x)
  "Return the car of the cdr of X."
  (car (cdr x)))

(defsubst cdar (x)
  "Return the cdr of the car of X."
  (cdr (car x)))

(defsubst cddr (x)
  "Return the cdr of the cdr of X."
  (cdr (cdr x)))
Richard M. Stallman's avatar
Richard M. Stallman committed
303

304 305 306 307 308
(defun last (list &optional n)
  "Return the last link of LIST.  Its car is the last element.
If LIST is nil, return nil.
If N is non-nil, return the Nth-to-last link of LIST.
If N is bigger than the length of LIST, return LIST."
309
  (if n
310
      (and (>= n 0)
311
           (let ((m (safe-length list)))
312 313
             (if (< n m) (nthcdr (- m n) list) list)))
    (and list
314
         (nthcdr (1- (safe-length list)) list))))
315

316
(defun butlast (list &optional n)
317
  "Return a copy of LIST with the last N elements removed."
318 319
  (if (and n (<= n 0)) list
    (nbutlast (copy-sequence list) n)))
320

321
(defun nbutlast (list &optional n)
322
  "Modifies LIST to remove the last N elements."
323
  (let ((m (length list)))
324 325 326
    (or n (setq n 1))
    (and (< n m)
	 (progn
327 328
	   (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
	   list))))
329

Kenichi Handa's avatar
Kenichi Handa committed
330 331 332 333 334 335 336 337 338 339 340
(defun delete-dups (list)
  "Destructively remove `equal' duplicates from LIST.
Store the result in LIST and return it.  LIST must be a proper list.
Of several `equal' occurrences of an element in LIST, the first
one is kept."
  (let ((tail list))
    (while tail
      (setcdr tail (delete (car tail) (cdr tail)))
      (setq tail (cdr tail))))
  list)

341
(defun number-sequence (from &optional to inc)
342
  "Return a sequence of numbers from FROM to TO (both inclusive) as a list.
Kenichi Handa's avatar
Kenichi Handa committed
343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364
INC is the increment used between numbers in the sequence and defaults to 1.
So, the Nth element of the list is \(+ FROM \(* N INC)) where N counts from
zero.  TO is only included if there is an N for which TO = FROM + N * INC.
If TO is nil or numerically equal to FROM, return \(FROM).
If INC is positive and TO is less than FROM, or INC is negative
and TO is larger than FROM, return nil.
If INC is zero and TO is neither nil nor numerically equal to
FROM, signal an error.

This function is primarily designed for integer arguments.
Nevertheless, FROM, TO and INC can be integer or float.  However,
floating point arithmetic is inexact.  For instance, depending on
the machine, it may quite well happen that
\(number-sequence 0.4 0.6 0.2) returns the one element list \(0.4),
whereas \(number-sequence 0.4 0.8 0.2) returns a list with three
elements.  Thus, if some of the arguments are floats and one wants
to make sure that TO is included, one may have to explicitly write
TO as \(+ FROM \(* N INC)) or use a variable whose value was
computed with this exact expression.  Alternatively, you can,
of course, also replace TO with a slightly larger value
\(or a slightly more negative value if INC is negative)."
  (if (or (not to) (= from to))
365 366
      (list from)
    (or inc (setq inc 1))
Kenichi Handa's avatar
Kenichi Handa committed
367 368 369 370 371 372 373 374 375 376 377
    (when (zerop inc) (error "The increment can not be zero"))
    (let (seq (n 0) (next from))
      (if (> inc 0)
          (while (<= next to)
            (setq seq (cons next seq)
                  n (1+ n)
                  next (+ from (* n inc))))
        (while (>= next to)
          (setq seq (cons next seq)
                n (1+ n)
                next (+ from (* n inc)))))
378
      (nreverse seq))))
379

380 381 382
(defun copy-tree (tree &optional vecp)
  "Make a copy of TREE.
If TREE is a cons cell, this recursively copies both its car and its cdr.
383
Contrast to `copy-sequence', which copies only along the cdrs.  With second
384 385
argument VECP, this copies vectors as well as conses."
  (if (consp tree)
386 387 388 389 390 391 392
      (let (result)
	(while (consp tree)
	  (let ((newcar (car tree)))
	    (if (or (consp (car tree)) (and vecp (vectorp (car tree))))
		(setq newcar (copy-tree (car tree) vecp)))
	    (push newcar result))
	  (setq tree (cdr tree)))
393
	(nconc (nreverse result) tree))
394 395 396
    (if (and vecp (vectorp tree))
	(let ((i (length (setq tree (copy-sequence tree)))))
	  (while (>= (setq i (1- i)) 0)
397 398 399
	    (aset tree i (copy-tree (aref tree i) vecp)))
	  tree)
      tree)))
400 401

;;;; Various list-search functions.
402

403 404
(defun assoc-default (key alist &optional test default)
  "Find object KEY in a pseudo-alist ALIST.
405 406 407 408 409 410 411
ALIST is a list of conses or objects.  Each element
 (or the element's car, if it is a cons) is compared with KEY by
 calling TEST, with two arguments: (i) the element or its car,
 and (ii) KEY.
If that is non-nil, the element matches; then `assoc-default'
 returns the element's cdr, if it is a cons, or DEFAULT if the
 element is not a cons.
412 413 414 415 416 417 418 419 420 421

If no element matches, the value is nil.
If TEST is omitted or nil, `equal' is used."
  (let (found (tail alist) value)
    (while (and tail (not found))
      (let ((elt (car tail)))
	(when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
	  (setq found t value (if (consp elt) (cdr elt) default))))
      (setq tail (cdr tail)))
    value))
422

423
(make-obsolete 'assoc-ignore-case 'assoc-string "22.1")
424 425 426 427
(defun assoc-ignore-case (key alist)
  "Like `assoc', but ignores differences in case and text representation.
KEY must be a string.  Upper-case and lower-case letters are treated as equal.
Unibyte strings are converted to multibyte for comparison."
Kenichi Handa's avatar
Kenichi Handa committed
428
  (assoc-string key alist t))
429

430
(make-obsolete 'assoc-ignore-representation 'assoc-string "22.1")
431 432
(defun assoc-ignore-representation (key alist)
  "Like `assoc', but ignores differences in text representation.
Juanma Barranquero's avatar
Juanma Barranquero committed
433
KEY must be a string.
434
Unibyte strings are converted to multibyte for comparison."
Kenichi Handa's avatar
Kenichi Handa committed
435
  (assoc-string key alist nil))
436 437

(defun member-ignore-case (elt list)
Glenn Morris's avatar
Glenn Morris committed
438
  "Like `member', but ignore differences in case and text representation.
439
ELT must be a string.  Upper-case and lower-case letters are treated as equal.
440 441 442 443 444
Unibyte strings are converted to multibyte for comparison.
Non-strings in LIST are ignored."
  (while (and list
	      (not (and (stringp (car list))
			(eq t (compare-strings elt 0 nil (car list) 0 nil t)))))
445 446
    (setq list (cdr list)))
  list)
447

448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490
(defun assq-delete-all (key alist)
  "Delete from ALIST all elements whose car is `eq' to KEY.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
  (while (and (consp (car alist))
	      (eq (car (car alist)) key))
    (setq alist (cdr alist)))
  (let ((tail alist) tail-cdr)
    (while (setq tail-cdr (cdr tail))
      (if (and (consp (car tail-cdr))
	       (eq (car (car tail-cdr)) key))
	  (setcdr tail (cdr tail-cdr))
	(setq tail tail-cdr))))
  alist)

(defun rassq-delete-all (value alist)
  "Delete from ALIST all elements whose cdr is `eq' to VALUE.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
  (while (and (consp (car alist))
	      (eq (cdr (car alist)) value))
    (setq alist (cdr alist)))
  (let ((tail alist) tail-cdr)
    (while (setq tail-cdr (cdr tail))
      (if (and (consp (car tail-cdr))
	       (eq (cdr (car tail-cdr)) value))
	  (setcdr tail (cdr tail-cdr))
	(setq tail tail-cdr))))
  alist)

(defun remove (elt seq)
  "Return a copy of SEQ with all occurrences of ELT removed.
SEQ must be a list, vector, or string.  The comparison is done with `equal'."
  (if (nlistp seq)
      ;; If SEQ isn't a list, there's no need to copy SEQ because
      ;; `delete' will return a new object.
      (delete elt seq)
    (delete elt (copy-sequence seq))))

(defun remq (elt list)
  "Return LIST with all occurrences of ELT removed.
The comparison is done with `eq'.  Contrary to `delq', this does not use
side-effects, and the argument LIST is not modified."
491
  (while (and (eq elt (car list)) (setq list (cdr list))))
492 493 494
  (if (memq elt list)
      (delq elt (copy-sequence list))
    list))
495 496

;;;; Keymap support.
David Lawrence's avatar
David Lawrence committed
497

498 499 500 501 502 503
(defmacro kbd (keys)
  "Convert KEYS to the internal Emacs key representation.
KEYS should be a string constant in the format used for
saving keyboard macros (see `edmacro-mode')."
  (read-kbd-macro keys))

David Lawrence's avatar
David Lawrence committed
504
(defun undefined ()
505
  "Beep to tell the user this binding is undefined."
David Lawrence's avatar
David Lawrence committed
506 507 508
  (interactive)
  (ding))

509 510
;; Prevent the \{...} documentation construct
;; from mentioning keys that run this command.
David Lawrence's avatar
David Lawrence committed
511 512 513 514 515 516
(put 'undefined 'suppress-keymap t)

(defun suppress-keymap (map &optional nodigits)
  "Make MAP override all normally self-inserting keys to be undefined.
Normally, as an exception, digits and minus-sign are set to make prefix args,
but optional second arg NODIGITS non-nil treats them like other chars."
517
  (define-key map [remap self-insert-command] 'undefined)
David Lawrence's avatar
David Lawrence committed
518 519 520 521 522 523 524 525 526
  (or nodigits
      (let (loop)
	(define-key map "-" 'negative-argument)
	;; Make plain numbers do numeric args.
	(setq loop ?0)
	(while (<= loop ?9)
	  (define-key map (char-to-string loop) 'digit-argument)
	  (setq loop (1+ loop))))))

527 528 529 530 531 532 533 534 535 536 537 538 539 540
(defun make-composed-keymap (maps &optional parent)
  "Construct a new keymap composed of MAPS and inheriting from PARENT.
When looking up a key in the returned map, the key is looked in each
keymap of MAPS in turn until a binding is found.
If no binding is found in MAPS, the lookup continues in PARENT, if non-nil.
As always with keymap inheritance, a nil binding in MAPS overrides
any corresponding binding in PARENT, but it does not override corresponding
bindings in other keymaps of MAPS.
MAPS can be a list of keymaps or a single keymap.
PARENT if non-nil should be a keymap."
  `(keymap
    ,@(if (keymapp maps) (list maps) maps)
    ,@parent))

541
(defun define-key-after (keymap key definition &optional after)
542 543 544
  "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
This is like `define-key' except that the binding for KEY is placed
just after the binding for the event AFTER, instead of at the beginning
545 546 547
of the map.  Note that AFTER must be an event type (like KEY), NOT a command
\(like DEFINITION).

548
If AFTER is t or omitted, the new binding goes at the end of the keymap.
549
AFTER should be a single event type--a symbol or a character, not a sequence.
550

551
Bindings are always added before any inherited map.
552

553 554
The order of bindings in a keymap only matters when it is used as
a menu, so this function is not useful for non-menu keymaps."
555
  (unless after (setq after t))
556 557
  (or (keymapp keymap)
      (signal 'wrong-type-argument (list 'keymapp keymap)))
558 559 560 561 562 563 564
  (setq key
	(if (<= (length key) 1) (aref key 0)
	  (setq keymap (lookup-key keymap
				   (apply 'vector
					  (butlast (mapcar 'identity key)))))
	  (aref key (1- (length key)))))
  (let ((tail keymap) done inserted)
565 566
    (while (and (not done) tail)
      ;; Delete any earlier bindings for the same key.
567
      (if (eq (car-safe (car (cdr tail))) key)
568
	  (setcdr tail (cdr (cdr tail))))
569 570
      ;; If we hit an included map, go down that one.
      (if (keymapp (car tail)) (setq tail (car tail)))
571 572
      ;; When we reach AFTER's binding, insert the new binding after.
      ;; If we reach an inherited keymap, insert just before that.
573
      ;; If we reach the end of this keymap, insert at the end.
574 575
      (if (or (and (eq (car-safe (car tail)) after)
		   (not (eq after t)))
576 577
	      (eq (car (cdr tail)) 'keymap)
	      (null (cdr tail)))
578
	  (progn
579 580 581 582 583 584 585
	    ;; Stop the scan only if we find a parent keymap.
	    ;; Keep going past the inserted element
	    ;; so we can delete any duplications that come later.
	    (if (eq (car (cdr tail)) 'keymap)
		(setq done t))
	    ;; Don't insert more than once.
	    (or inserted
586
		(setcdr tail (cons (cons key definition) (cdr tail))))
587
	    (setq inserted t)))
588 589
      (setq tail (cdr tail)))))

590
(defun map-keymap-sorted (function keymap)
591 592
  "Implement `map-keymap' with sorting.
Don't call this function; it is for internal use only."
593 594 595 596 597 598 599 600 601 602 603 604 605 606
  (let (list)
    (map-keymap (lambda (a b) (push (cons a b) list))
                keymap)
    (setq list (sort list
                     (lambda (a b)
                       (setq a (car a) b (car b))
                       (if (integerp a)
                           (if (integerp b) (< a b)
                             t)
                         (if (integerp b) t
                           ;; string< also accepts symbols.
                           (string< a b))))))
    (dolist (p list)
      (funcall function (car p) (cdr p)))))
607

608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626
(defun keymap--menu-item-binding (val)
  "Return the binding part of a menu-item."
  (cond
   ((not (consp val)) val)              ;Not a menu-item.
   ((eq 'menu-item (car val))
    (let* ((binding (nth 2 val))
           (plist (nthcdr 3 val))
           (filter (plist-get plist :filter)))
      (if filter (funcall filter binding)
        binding)))
   ((and (consp (cdr val)) (stringp (cadr val)))
    (cddr val))
   ((stringp (car val))
    (cdr val))
   (t val)))                            ;Not a menu-item either.

(defun keymap--menu-item-with-binding (item binding)
  "Build a menu-item like ITEM but with its binding changed to BINDING."
  (cond
627
   ((not (consp item)) binding)		;Not a menu-item.
628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650
   ((eq 'menu-item (car item))
    (setq item (copy-sequence item))
    (let ((tail (nthcdr 2 item)))
      (setcar tail binding)
      ;; Remove any potential filter.
      (if (plist-get (cdr tail) :filter)
          (setcdr tail (plist-put (cdr tail) :filter nil))))
    item)
   ((and (consp (cdr item)) (stringp (cadr item)))
    (cons (car item) (cons (cadr item) binding)))
   (t (cons (car item) binding))))

(defun keymap--merge-bindings (val1 val2)
  "Merge bindings VAL1 and VAL2."
  (let ((map1 (keymap--menu-item-binding val1))
        (map2 (keymap--menu-item-binding val2)))
    (if (not (and (keymapp map1) (keymapp map2)))
        ;; There's nothing to merge: val1 takes precedence.
        val1
      (let ((map (list 'keymap map1 map2))
            (item (if (keymapp val1) (if (keymapp val2) nil val2) val1)))
        (keymap--menu-item-with-binding item map)))))

651
(defun keymap-canonicalize (map)
652 653 654 655 656 657 658 659 660 661
  "Return a simpler equivalent keymap.
This resolves inheritance and redefinitions.  The returned keymap
should behave identically to a copy of KEYMAP w.r.t `lookup-key'
and use in active keymaps and menus.
Subkeymaps may be modified but are not canonicalized."
  ;; FIXME: Problem with the difference between a nil binding
  ;; that hides a binding in an inherited map and a nil binding that's ignored
  ;; to let some further binding visible.  Currently a nil binding hides all.
  ;; FIXME: we may want to carefully (re)order elements in case they're
  ;; menu-entries.
662
  (let ((bindings ())
663 664
        (ranges ())
	(prompt (keymap-prompt map)))
665
    (while (keymapp map)
666
      (setq map (map-keymap ;; -internal
667 668 669 670 671 672
                 (lambda (key item)
                   (if (consp key)
                       ;; Treat char-ranges specially.
                       (push (cons key item) ranges)
                     (push (cons key item) bindings)))
                 map)))
673
    ;; Create the new map.
674
    (setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap) prompt))
675
    (dolist (binding ranges)
676
      ;; Treat char-ranges specially.  FIXME: need to merge as well.
Stefan Monnier's avatar
Stefan Monnier committed
677
      (define-key map (vector (car binding)) (cdr binding)))
678
    ;; Process the bindings starting from the end.
679 680 681 682
    (dolist (binding (prog1 bindings (setq bindings ())))
      (let* ((key (car binding))
             (item (cdr binding))
             (oldbind (assq key bindings)))
683 684 685 686 687 688 689 690
        (push (if (not oldbind)
                  ;; The normal case: no duplicate bindings.
                  binding
                ;; This is the second binding for this key.
                (setq bindings (delq oldbind bindings))
                (cons key (keymap--merge-bindings (cdr binding)
                                                  (cdr oldbind))))
              bindings)))
691 692
    (nconc map bindings)))

693 694
(put 'keyboard-translate-table 'char-table-extra-slots 0)

695 696 697 698
(defun keyboard-translate (from to)
  "Translate character FROM to TO at a low level.
This function creates a `keyboard-translate-table' if necessary
and then modifies one entry in it."
699 700 701
  (or (char-table-p keyboard-translate-table)
      (setq keyboard-translate-table
	    (make-char-table 'keyboard-translate-table nil)))
702 703
  (aset keyboard-translate-table from to))

704
;;;; Key binding commands.
705

706 707 708 709 710 711 712
(defun global-set-key (key command)
  "Give KEY a global binding as COMMAND.
COMMAND is the command definition to use; usually it is
a symbol naming an interactively-callable function.
KEY is a key sequence; noninteractively, it is a string or vector
of characters or event types, and non-ASCII characters with codes
above 127 (such as ISO Latin-1) can be included if you use a vector.
713

714 715 716 717 718 719 720
Note that if KEY has a local binding in the current buffer,
that local binding will continue to shadow any global binding
that you make with this function."
  (interactive "KSet key globally: \nCSet key %s to command: ")
  (or (vectorp key) (stringp key)
      (signal 'wrong-type-argument (list 'arrayp key)))
  (define-key (current-global-map) key command))
721

722 723 724 725 726 727 728
(defun local-set-key (key command)
  "Give KEY a local binding as COMMAND.
COMMAND is the command definition to use; usually it is
a symbol naming an interactively-callable function.
KEY is a key sequence; noninteractively, it is a string or vector
of characters or event types, and non-ASCII characters with codes
above 127 (such as ISO Latin-1) can be included if you use a vector.
729

730 731 732 733 734 735 736 737 738
The binding goes in the current buffer's local map,
which in most cases is shared with all other buffers in the same major mode."
  (interactive "KSet key locally: \nCSet key %s locally to command: ")
  (let ((map (current-local-map)))
    (or map
	(use-local-map (setq map (make-sparse-keymap))))
    (or (vectorp key) (stringp key)
	(signal 'wrong-type-argument (list 'arrayp key)))
    (define-key map key command)))
739

740 741 742 743 744
(defun global-unset-key (key)
  "Remove global binding of KEY.
KEY is a string or vector representing a sequence of keystrokes."
  (interactive "kUnset key globally: ")
  (global-set-key key nil))
745

746 747 748 749 750 751 752 753 754 755 756
(defun local-unset-key (key)
  "Remove local binding of KEY.
KEY is a string or vector representing a sequence of keystrokes."
  (interactive "kUnset key locally: ")
  (if (current-local-map)
      (local-set-key key nil))
  nil)

;;;; substitute-key-definition and its subroutines.

(defvar key-substitution-in-progress nil
Vinicius Jose Latorre's avatar
Vinicius Jose Latorre committed
757
  "Used internally by `substitute-key-definition'.")
758 759 760 761 762 763 764

(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
  "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
In other words, OLDDEF is replaced with NEWDEF where ever it appears.
Alternatively, if optional fourth argument OLDMAP is specified, we redefine
in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP.

765 766
If you don't specify OLDMAP, you can usually get the same results
in a cleaner way with command remapping, like this:
767 768
  \(define-key KEYMAP [remap OLDDEF] NEWDEF)
\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)"
769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812
  ;; Don't document PREFIX in the doc string because we don't want to
  ;; advertise it.  It's meant for recursive calls only.  Here's its
  ;; meaning

  ;; If optional argument PREFIX is specified, it should be a key
  ;; prefix, a string.  Redefined bindings will then be bound to the
  ;; original key, with PREFIX added at the front.
  (or prefix (setq prefix ""))
  (let* ((scan (or oldmap keymap))
	 (prefix1 (vconcat prefix [nil]))
	 (key-substitution-in-progress
	  (cons scan key-substitution-in-progress)))
    ;; Scan OLDMAP, finding each char or event-symbol that
    ;; has any definition, and act on it with hack-key.
    (map-keymap
     (lambda (char defn)
       (aset prefix1 (length prefix) char)
       (substitute-key-definition-key defn olddef newdef prefix1 keymap))
     scan)))

(defun substitute-key-definition-key (defn olddef newdef prefix keymap)
  (let (inner-def skipped menu-item)
    ;; Find the actual command name within the binding.
    (if (eq (car-safe defn) 'menu-item)
	(setq menu-item defn defn (nth 2 defn))
      ;; Skip past menu-prompt.
      (while (stringp (car-safe defn))
	(push (pop defn) skipped))
      ;; Skip past cached key-equivalence data for menu items.
      (if (consp (car-safe defn))
	  (setq defn (cdr defn))))
    (if (or (eq defn olddef)
	    ;; Compare with equal if definition is a key sequence.
	    ;; That is useful for operating on function-key-map.
	    (and (or (stringp defn) (vectorp defn))
		 (equal defn olddef)))
	(define-key keymap prefix
	  (if menu-item
	      (let ((copy (copy-sequence menu-item)))
		(setcar (nthcdr 2 copy) newdef)
		copy)
	    (nconc (nreverse skipped) newdef)))
      ;; Look past a symbol that names a keymap.
      (setq inner-def
813
	    (or (indirect-function defn t) defn))
814 815 816 817 818 819 820 821 822 823 824 825
      ;; For nested keymaps, we use `inner-def' rather than `defn' so as to
      ;; avoid autoloading a keymap.  This is mostly done to preserve the
      ;; original non-autoloading behavior of pre-map-keymap times.
      (if (and (keymapp inner-def)
	       ;; Avoid recursively scanning
	       ;; where KEYMAP does not have a submap.
	       (let ((elt (lookup-key keymap prefix)))
		 (or (null elt) (natnump elt) (keymapp elt)))
	       ;; Avoid recursively rescanning keymap being scanned.
	       (not (memq inner-def key-substitution-in-progress)))
	  ;; If this one isn't being scanned already, scan it now.
	  (substitute-key-definition olddef newdef keymap inner-def prefix)))))
826 827


Juanma Barranquero's avatar
Juanma Barranquero committed
828
;;;; The global keymap tree.
829

830 831
;; global-map, esc-map, and ctl-x-map have their values set up in
;; keymap.c; we just give them docstrings here.
832 833 834 835 836 837 838 839 840 841 842 843 844 845 846

(defvar global-map nil
  "Default global keymap mapping Emacs keyboard input into commands.
The value is a keymap which is usually (but not necessarily) Emacs's
global map.")

(defvar esc-map nil
  "Default keymap for ESC (meta) commands.
The normal global definition of the character ESC indirects to this keymap.")

(defvar ctl-x-map nil
  "Default keymap for C-x commands.
The normal global definition of the character C-x indirects to this keymap.")

(defvar ctl-x-4-map (make-sparse-keymap)
Pavel Janík's avatar
Pavel Janík committed
847
  "Keymap for subcommands of C-x 4.")
848
(defalias 'ctl-x-4-prefix ctl-x-4-map)
849 850 851 852
(define-key ctl-x-map "4" 'ctl-x-4-prefix)

(defvar ctl-x-5-map (make-sparse-keymap)
  "Keymap for frame commands.")
853
(defalias 'ctl-x-5-prefix ctl-x-5-map)
854 855
(define-key ctl-x-map "5" 'ctl-x-5-prefix)

856

857 858
;;;; Event manipulation functions.

859
(defconst listify-key-sequence-1 (logior 128 ?\M-\C-@))
860

861 862 863 864 865 866
(defun listify-key-sequence (key)
  "Convert a key sequence to a list of events."
  (if (vectorp key)
      (append key nil)
    (mapcar (function (lambda (c)
			(if (> c 127)
867
			    (logxor c listify-key-sequence-1)
868
			  c)))
869
	    key)))
870

871 872
(defsubst eventp (obj)
  "True if the argument is an event object."
873 874 875 876
  (or (and (integerp obj)
	   ;; Filter out integers too large to be events.
	   ;; M is the biggest modifier.
	   (zerop (logand obj (lognot (1- (lsh ?\M-\^@ 1)))))
877
	   (characterp (event-basic-type obj)))
878 879 880 881 882 883 884
      (and (symbolp obj)
	   (get obj 'event-symbol-elements))
      (and (consp obj)
	   (symbolp (car obj))
	   (get (car obj) 'event-symbol-elements))))

(defun event-modifiers (event)
885
  "Return a list of symbols representing the modifier keys in event EVENT.
886
The elements of the list may include `meta', `control',
887
`shift', `hyper', `super', `alt', `click', `double', `triple', `drag',
888 889 890
and `down'.
EVENT may be an event or an event type.  If EVENT is a symbol
that has never been used in an event that has been read as input
891 892
in the current Emacs session, then this function may fail to include
the `click' modifier."
893 894 895 896
  (let ((type event))
    (if (listp type)
	(setq type (car type)))
    (if (symbolp type)
897 898 899
        ;; Don't read event-symbol-elements directly since we're not
        ;; sure the symbol has already been parsed.
	(cdr (internal-event-symbol-parse-modifiers type))
900 901 902 903
      (let ((list nil)
	    (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
					       ?\H-\^@ ?\s-\^@ ?\A-\^@)))))
	(if (not (zerop (logand type ?\M-\^@)))
904
	    (push 'meta list))
905 906
	(if (or (not (zerop (logand type ?\C-\^@)))
		(< char 32))
907
	    (push 'control list))
908 909
	(if (or (not (zerop (logand type ?\S-\^@)))
		(/= char (downcase char)))
910
	    (push 'shift list))
911
	(or (zerop (logand type ?\H-\^@))
912
	    (push 'hyper list))
913
	(or (zerop (logand type ?\s-\^@))
914
	    (push 'super list))
915
	(or (zerop (logand type ?\A-\^@))
916
	    (push 'alt list))
917 918
	list))))

919
(defun event-basic-type (event)
920
  "Return the basic type of the given event (all modifiers removed).
921 922 923 924
The value is a printing character (not upper case) or a symbol.
EVENT may be an event or an event type.  If EVENT is a symbol
that has never been used in an event that has been read as input
in the current Emacs session, then this function may return nil."
925 926
  (if (consp event)
      (setq event (car event)))
927 928
  (if (symbolp event)
      (car (get event 'event-symbol-elements))
929 930 931 932 933 934 935
    (let* ((base (logand event (1- ?\A-\^@)))
	   (uncontrolled (if (< base 32) (logior base 64) base)))
      ;; There are some numbers that are invalid characters and
      ;; cause `downcase' to get an error.
      (condition-case ()
	  (downcase uncontrolled)
	(error uncontrolled)))))
936

937 938
(defsubst mouse-movement-p (object)
  "Return non-nil if OBJECT is a mouse movement event."
939
  (eq (car-safe object) 'mouse-movement))
940

941 942 943 944 945
(defun mouse-event-p (object)
  "Return non-nil if OBJECT is a mouse click event."
  ;; is this really correct? maybe remove mouse-movement?
  (memq (event-basic-type object) '(mouse-1 mouse-2 mouse-3 mouse-movement)))

946 947
(defsubst event-start (event)
  "Return the starting position of EVENT.
948 949 950 951
EVENT should be a click, drag, or key press event.
If it is a key press event, the return value has the form
    (WINDOW POS (0 . 0) 0)
If it is a click or drag event, it has the form
Kenichi Handa's avatar
Kenichi Handa committed
952 953
   (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
    IMAGE (DX . DY) (WIDTH . HEIGHT))
954 955 956 957 958 959
The `posn-' functions access elements of such lists.
For more information, see Info node `(elisp)Click Events'.

If EVENT is a mouse or key press or a mouse click, this is the
position of the event.  If EVENT is a drag, this is the starting
position of the drag."
960 961
  (if (consp event) (nth 1 event)
    (list (selected-window) (point) '(0 . 0) 0)))
962 963

(defsubst event-end (event)
Kenichi Handa's avatar
Kenichi Handa committed
964 965
  "Return the ending location of EVENT.
EVENT should be a click, drag, or key press event.
966 967 968 969 970
If EVENT is a key press event, the return value has the form
    (WINDOW POS (0 . 0) 0)
If EVENT is a click event, this function is the same as
`event-start'.  For click and drag events, the return value has
the form
Kenichi Handa's avatar
Kenichi Handa committed
971 972
   (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
    IMAGE (DX . DY) (WIDTH . HEIGHT))
973 974 975 976 977 978
The `posn-' functions access elements of such lists.
For more information, see Info node `(elisp)Click Events'.

If EVENT is a mouse or key press or a mouse click, this is the
position of the event.  If EVENT is a drag, this is the starting
position of the drag."
979 980
  (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event)
    (list (selected-window) (point) '(0 . 0) 0)))
981

982 983 984
(defsubst event-click-count (event)
  "Return the multi-click count of EVENT, a click or drag event.
The return value is a positive integer."
985
  (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1))
986 987

;;;; Extracting fields of the positions in an event.
988

989 990
(defsubst posn-window (position)
  "Return the window in POSITION.
Kenichi Handa's avatar
Kenichi Handa committed
991 992
POSITION should be a list of the form returned by the `event-start'
and `event-end' functions."
993 994
  (nth 0 position))

Kenichi Handa's avatar
Kenichi Handa committed
995 996 997 998 999 1000 1001 1002 1003
(defsubst posn-area (position)
  "Return the window area recorded in POSITION, or nil for the text area.
POSITION should be a list of the form returned by the `event-start'
and `event-end' functions."
  (let ((area (if (consp (nth 1 position))
		  (car (nth 1 position))
		(nth 1 position))))
    (and (symbolp area) area)))

1004 1005
(defsubst posn-point (position)
  "Return the buffer location in POSITION.
Kenichi Handa's avatar
Kenichi Handa committed
1006 1007 1008