subr.el 230 KB
Newer Older
1
;;; subr.el --- basic lisp subroutines for Emacs  -*- lexical-binding:t -*-
Eric S. Raymond's avatar
Eric S. Raymond committed
2

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

6
;; Maintainer: emacs-devel@gnu.org
Pavel Janík's avatar
Pavel Janík committed
7
;; 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 <https://www.gnu.org/licenses/>.
David Lawrence's avatar
David Lawrence committed
24

Van L's avatar
Van L committed
25
;;; Code:
26 27 28 29

;; declare-function's args use &rest, not &optional, for compatibility
;; with byte-compile-macroexpand-declare-function.

30
(defmacro declare-function (_fn _file &rest _args)
31
  "Tell the byte-compiler that function FN is defined, in FILE.
Juanma Barranquero's avatar
Juanma Barranquero committed
32
The FILE argument is not used by the byte-compiler, but by the
33
`check-declare' package, which checks that FILE contains a
34
definition for FN.
35 36 37 38 39 40 41 42 43 44

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.

45 46
Optional ARGLIST specifies FN's arguments, or is t to not specify
FN's arguments.  An omitted ARGLIST defaults to t, not nil: a nil
47 48
ARGLIST specifies an empty argument list, and an explicit t
ARGLIST is a placeholder that allows supplying a later arg.
49 50 51 52 53

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

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

Glenn Morris's avatar
Glenn Morris committed
58
For more information, see Info node `(elisp)Declaring Functions'."
59 60
  (declare (advertised-calling-convention
	    (fn file &optional arglist fileonly) nil))
61 62
  ;; Does nothing - byte-compile-declare-function does the work.
  nil)
Eli Zaretskii's avatar
Eli Zaretskii committed
63

64

65
;;;; Basic Lisp macros.
66

Stefan Monnier's avatar
Stefan Monnier committed
67
(defalias 'not 'null)
68
(defalias 'sxhash 'sxhash-equal)
Stefan Monnier's avatar
Stefan Monnier committed
69

Kenichi Handa's avatar
Kenichi Handa committed
70
(defmacro noreturn (form)
Luc Teirlinck's avatar
Luc Teirlinck committed
71 72
  "Evaluate FORM, expecting it not to return.
If FORM does return, signal an error."
73
  (declare (debug t))
Kenichi Handa's avatar
Kenichi Handa committed
74
  `(prog1 ,form
75
     (error "Form marked with `noreturn' did return")))
Kenichi Handa's avatar
Kenichi Handa committed
76 77

(defmacro 1value (form)
Luc Teirlinck's avatar
Luc Teirlinck committed
78
  "Evaluate FORM, expecting a constant return value.
79 80
If FORM returns differing values when running under Testcover,
Testcover will raise an error."
81
  (declare (debug t))
Kenichi Handa's avatar
Kenichi Handa committed
82 83
  form)

84 85
(defmacro def-edebug-spec (symbol spec)
  "Set the `edebug-form-spec' property of SYMBOL according to SPEC.
Glenn Morris's avatar
Glenn Morris committed
86 87 88 89
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
90
Info node `(elisp)Specification List' for details."
91 92
  `(put (quote ,symbol) 'edebug-form-spec (quote ,spec)))

93
(defmacro lambda (&rest cdr)
94 95 96 97 98 99 100
  "Return an anonymous function.
Under dynamic binding, a call of the form (lambda ARGS DOCSTRING
INTERACTIVE BODY) is self-quoting; the result of evaluating the
lambda expression is the expression itself.  Under lexical
binding, the result is a closure.  Regardless, the result is a
function, i.e., it may be stored as the function value of a
symbol, passed to `funcall' or `mapcar', etc.
Richard M. Stallman's avatar
Richard M. Stallman committed
101

102
ARGS should take the same form as an argument list for a `defun'.
Richard M. Stallman's avatar
Richard M. Stallman committed
103 104 105
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.
106 107
INTERACTIVE should be a call to the function `interactive', which see.
It may also be omitted.
108 109 110
BODY should be a list of Lisp expressions.

\(fn ARGS [DOCSTRING] [INTERACTIVE] BODY)"
111
  (declare (doc-string 2) (indent defun)
112
           (debug (&define lambda-list lambda-doc
113 114
                           [&optional ("interactive" interactive)]
                           def-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 125
(defmacro prog2 (form1 form2 &rest body)
  "Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
The value of FORM2 is saved during the evaluation of the
remaining args, whose values are discarded."
  (declare (indent 2) (debug t))
  `(progn ,form1 (prog1 ,form2 ,@body)))

126 127 128 129 130 131 132 133 134 135 136 137 138
(defmacro setq-default (&rest args)
  "Set the default value of variable VAR to VALUE.
VAR, the variable name, is literal (not evaluated);
VALUE is an expression: it is evaluated and its value returned.
The default value of a variable is seen in buffers
that do not have their own values for the variable.

More generally, you can use multiple variables and values, as in
  (setq-default VAR VALUE VAR VALUE...)
This sets each VAR's default value to the corresponding VALUE.
The VALUE for the Nth VAR can refer to the new default values
of previous VARs.

139
\(fn [VAR VALUE]...)"
140 141 142 143 144 145
  (declare (debug setq))
  (let ((exps nil))
    (while args
      (push `(set-default ',(pop args) ,(pop args)) exps))
    `(progn . ,(nreverse exps))))

146 147
(defmacro setq-local (&rest pairs)
  "Make variables in PAIRS buffer-local and assign them the corresponding values.
148

149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166
PAIRS is a list of variable/value pairs.  For each variable, make
it buffer-local and assign it the corresponding value.  The
variables are literal symbols and should not be quoted.

The second VALUE is not computed until after the first VARIABLE
is set, and so on; each VALUE can use the new value of variables
set earlier in the ‘setq-local’.  The return value of the
‘setq-local’ form is the value of the last VALUE.

\(fn [VARIABLE VALUE]...)"
  (declare (debug setq))
  (unless (zerop (mod (length pairs) 2))
    (error "PAIRS must have an even number of variable/value members"))
  (let ((expr nil))
    (while pairs
      (unless (symbolp (car pairs))
        (error "Attempting to set a non-symbol: %s" (car pairs)))
      ;; Can't use backquote here, it's too early in the bootstrap.
167 168 169
      (setq expr
            (cons
             (list 'set
170 171
                   (list 'make-local-variable (list 'quote (car pairs)))
                   (car (cdr pairs)))
172
             expr))
173 174
      (setq pairs (cdr (cdr pairs))))
    (macroexp-progn (nreverse expr))))
175 176 177 178 179

(defmacro defvar-local (var val &optional docstring)
  "Define VAR as a buffer-local variable with default value VAL.
Like `defvar' but additionally marks the variable as being automatically
buffer-local wherever it is set."
180
  (declare (debug defvar) (doc-string 3))
181 182 183 184
  ;; Can't use backquote here, it's too early in the bootstrap.
  (list 'progn (list 'defvar var val docstring)
        (list 'make-variable-buffer-local (list 'quote var))))

185 186 187
(defmacro push (newelt place)
  "Add NEWELT to the list stored in the generalized variable PLACE.
This is morally equivalent to (setf PLACE (cons NEWELT PLACE)),
188
except that PLACE is evaluated only once (after NEWELT)."
189 190 191 192 193 194 195 196 197 198 199 200 201 202
  (declare (debug (form gv-place)))
  (if (symbolp place)
      ;; Important special case, to avoid triggering GV too early in
      ;; the bootstrap.
      (list 'setq place
            (list 'cons newelt place))
    (require 'macroexp)
    (macroexp-let2 macroexp-copyable-p v newelt
      (gv-letplace (getter setter) place
        (funcall setter `(cons ,v ,getter))))))

(defmacro pop (place)
  "Return the first element of PLACE's value, and remove it from the list.
PLACE must be a generalized variable whose value is a list.
Richard M. Stallman's avatar
Richard M. Stallman committed
203 204
If the value is nil, `pop' returns nil but does not actually
change the list."
205
  (declare (debug (gv-place)))
206 207 208 209 210 211 212 213 214
  ;; We use `car-safe' here instead of `car' because the behavior is the same
  ;; (if it's not a cons cell, the `cdr' would have signaled an error already),
  ;; but `car-safe' is total, so the byte-compiler can safely remove it if the
  ;; result is not used.
  `(car-safe
    ,(if (symbolp place)
         ;; So we can use `pop' in the bootstrap before `gv' can be used.
         (list 'prog1 place (list 'setq place (list 'cdr place)))
       (gv-letplace (getter setter) place
215 216
         (macroexp-let2 macroexp-copyable-p x getter
           `(prog1 ,x ,(funcall setter `(cdr ,x))))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
217

218
(defmacro when (cond &rest body)
Kim F. Storm's avatar
Kim F. Storm committed
219 220 221 222
  "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
223
\(fn COND BODY...)"
224
  (declare (indent 1) (debug t))
225
  (list 'if cond (cons 'progn body)))
226

227
(defmacro unless (cond &rest body)
Kim F. Storm's avatar
Kim F. Storm committed
228 229 230 231
  "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
232
\(fn COND BODY...)"
233
  (declare (indent 1) (debug t))
234
  (cons 'if (cons cond (cons nil body))))
235

236 237 238 239 240 241 242 243
(defsubst xor (cond1 cond2)
  "Return the boolean exclusive-or of COND1 and COND2.
If only one of the arguments is non-nil, return it; otherwise
return nil."
  (declare (pure t) (side-effect-free error-free))
  (cond ((not cond1) cond2)
        ((not cond2) cond1)))

244
(defmacro dolist (spec &rest body)
245
  "Loop over a list.
246
Evaluate BODY with VAR bound to each car from LIST, in turn.
247 248
Then evaluate RESULT to get return value, default nil.

Markus Rost's avatar
Markus Rost committed
249
\(fn (VAR LIST [RESULT]) BODY...)"
250
  (declare (indent 1) (debug ((symbolp form &optional form) body)))
251 252 253 254
  (unless (consp spec)
    (signal 'wrong-type-argument (list 'consp spec)))
  (unless (<= 2 (length spec) 3)
    (signal 'wrong-number-of-arguments (list '(2 . 3) (length spec))))
255 256 257
  ;; It would be cleaner to create an uninterned symbol,
  ;; but that uses a lot more space when many functions in many files
  ;; use dolist.
258
  ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
259
  (let ((temp '--dolist-tail--))
260 261 262 263 264 265 266 267 268 269
    ;; 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))))
270
           ,@(cdr (cdr spec)))
271 272 273 274 275 276 277 278
      `(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))))))))
279

280
(defmacro dotimes (spec &rest body)
281
  "Loop a certain number of times.
282 283
Evaluate BODY with VAR bound to successive integers running from 0,
inclusive, to COUNT, exclusive.  Then evaluate RESULT to get
284
the return value (nil if RESULT is omitted).  Its use is deprecated.
285

Markus Rost's avatar
Markus Rost committed
286
\(fn (VAR COUNT [RESULT]) BODY...)"
287
  (declare (indent 1) (debug dolist))
288 289 290
  ;; It would be cleaner to create an uninterned symbol,
  ;; but that uses a lot more space when many functions in many files
  ;; use dotimes.
291
  ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
292
  (let ((temp '--dotimes-limit--)
293 294
	(start 0)
	(end (nth 1 spec)))
295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314
    ;; 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))))))
315

316
(defmacro declare (&rest _specs)
317 318 319 320 321 322 323
  "Do not evaluate any arguments, and return nil.
If a `declare' form appears as the first form in the body of a
`defun' or `defmacro' form, SPECS specifies various additional
information about the function or macro; these go into effect
during the evaluation of the `defun' or `defmacro' form.

The possible values of SPECS are specified by
324 325 326
`defun-declarations-alist' and `macro-declarations-alist'.

For more information, see info node `(elisp)Declare Form'."
Stefan Monnier's avatar
Stefan Monnier committed
327
  ;; FIXME: edebug spec should pay attention to defun-declarations-alist.
328
  nil)
329 330 331

(defmacro ignore-errors (&rest body)
  "Execute BODY; if an error occurs, return nil.
332 333 334
Otherwise, return result of last form in BODY.
See also `with-demoted-errors' that does something similar
without silencing all errors."
335
  (declare (debug t) (indent 0))
336
  `(condition-case nil (progn ,@body) (error nil)))
337 338 339 340 341 342 343 344

(defmacro ignore-error (condition &rest body)
  "Execute BODY; if the error CONDITION occurs, return nil.
Otherwise, return result of last form in BODY.

CONDITION can also be a list of error conditions."
  (declare (debug t) (indent 1))
  `(condition-case nil (progn ,@body) (,condition nil)))
345 346 347

;;;; Basic Lisp functions.

Mark Oteiza's avatar
Mark Oteiza committed
348 349 350 351 352 353
(defvar gensym-counter 0
  "Number used to construct the name of the next symbol created by `gensym'.")

(defun gensym (&optional prefix)
  "Return a new uninterned symbol.
The name is made by appending `gensym-counter' to PREFIX.
354 355 356
PREFIX is a string, and defaults to \"g\"."
  (let ((num (prog1 gensym-counter
               (setq gensym-counter (1+ gensym-counter)))))
Mark Oteiza's avatar
Mark Oteiza committed
357
    (make-symbol (format "%s%d" (or prefix "g") num))))
Mark Oteiza's avatar
Mark Oteiza committed
358

359
(defun ignore (&rest _arguments)
360
  "Do nothing and return nil.
361
This function accepts any number of ARGUMENTS, but ignores them."
362 363 364
  (interactive)
  nil)

365
;; Signal a compile-error if the first arg is missing.
366
(defun error (&rest args)
367
  "Signal an error, making a message by passing ARGS to `format-message'.
368 369 370 371 372
Errors cause entry to the debugger when `debug-on-error' is non-nil.
This can be overridden by `debug-ignored-errors'.

To signal with MESSAGE without interpreting format characters
like `%', `\\=`' and `\\='', use (error \"%s\" MESSAGE).
373 374
In Emacs, the convention is that error messages start with a capital
letter but *do not* end with a period.  Please follow this convention
375
for the sake of consistency."
376
  (declare (advertised-calling-convention (string &rest args) "23.1"))
377
  (signal 'error (list (apply #'format-message args))))
378

379
(defun user-error (format &rest args)
380
  "Signal a user error, making a message by passing ARGS to `format-message'.
381 382
This is like `error' except that a user error (or \"pilot error\") comes
from an incorrect manipulation by the user, not from an actual problem.
383 384 385
In contrast with other errors, user errors normally do not cause
entry to the debugger, even when `debug-on-error' is non-nil.
This can be overridden by `debug-ignored-errors'.
Paul Eggert's avatar
Paul Eggert committed
386

387 388 389 390 391
To signal with MESSAGE without interpreting format characters
like `%', `\\=`' and `\\='', use (error \"%s\" MESSAGE).
In Emacs, the convention is that error messages start with a capital
letter but *do not* end with a period.  Please follow this convention
for the sake of consistency."
392
  (signal 'user-error (list (apply #'format-message format args))))
393

394 395 396 397 398 399 400 401 402
(defun define-error (name message &optional parent)
  "Define NAME as a new error signal.
MESSAGE is a string that will be output to the echo area if such an error
is signaled without being caught by a `condition-case'.
PARENT is either a signal or a list of signals from which it inherits.
Defaults to `error'."
  (unless parent (setq parent 'error))
  (let ((conditions
         (if (consp parent)
403
             (apply #'append
404 405 406
                    (mapcar (lambda (parent)
                              (cons parent
                                    (or (get parent 'error-conditions)
407
                                        (error "Unknown signal `%s'" parent))))
408 409 410 411 412 413
                            parent))
           (cons parent (get parent 'error-conditions)))))
    (put name 'error-conditions
         (delete-dups (copy-sequence (cons name conditions))))
    (when message (put name 'error-message message))))

414 415 416 417 418 419 420 421
;; 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)))
422

423 424 425 426 427 428 429 430 431
(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."
  (lambda (&rest args2)
    (apply fun (append args args2))))

432 433 434 435 436 437 438
(defun zerop (number)
  "Return t if NUMBER is zero."
  ;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because
  ;; = has a byte-code.
  (declare (compiler-macro (lambda (_) `(= 0 ,number))))
  (= 0 number))

439 440 441 442 443 444 445 446 447
(defun fixnump (object)
  "Return t if OBJECT is a fixnum."
  (and (integerp object)
       (<= most-negative-fixnum object most-positive-fixnum)))

(defun bignump (object)
  "Return t if OBJECT is a bignum."
  (and (integerp object) (not (fixnump object))))

448 449 450 451 452 453 454 455 456 457 458 459
(defun lsh (value count)
  "Return VALUE with its bits shifted left by COUNT.
If COUNT is negative, shifting is actually to the right.
In this case, if VALUE is a negative fixnum treat it as unsigned,
i.e., subtract 2 * most-negative-fixnum from VALUE before shifting it."
  (when (and (< value 0) (< count 0))
    (when (< value most-negative-fixnum)
      (signal 'args-out-of-range (list value count)))
    (setq value (logand (ash value -1) most-positive-fixnum))
    (setq count (1+ count)))
  (ash value count))

460 461

;;;; List functions.
Kenichi Handa's avatar
Kenichi Handa committed
462

463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480
;; Note: `internal--compiler-macro-cXXr' was copied from
;; `cl--compiler-macro-cXXr' in cl-macs.el.  If you amend either one,
;; you may want to amend the other, too.
(defun internal--compiler-macro-cXXr (form x)
  (let* ((head (car form))
         (n (symbol-name (car form)))
         (i (- (length n) 2)))
    (if (not (string-match "c[ad]+r\\'" n))
        (if (and (fboundp head) (symbolp (symbol-function head)))
            (internal--compiler-macro-cXXr (cons (symbol-function head) (cdr form))
                                     x)
          (error "Compiler macro for cXXr applied to non-cXXr form"))
      (while (> i (match-beginning 0))
        (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x))
        (setq i (1- i)))
      x)))

(defun caar (x)
481
  "Return the car of the car of X."
482
  (declare (compiler-macro internal--compiler-macro-cXXr))
483 484
  (car (car x)))

485
(defun cadr (x)
486
  "Return the car of the cdr of X."
487
  (declare (compiler-macro internal--compiler-macro-cXXr))
488 489
  (car (cdr x)))

490
(defun cdar (x)
491
  "Return the cdr of the car of X."
492
  (declare (compiler-macro internal--compiler-macro-cXXr))
493 494
  (cdr (car x)))

495
(defun cddr (x)
496
  "Return the cdr of the cdr of X."
497
  (declare (compiler-macro internal--compiler-macro-cXXr))
498
  (cdr (cdr x)))
Richard M. Stallman's avatar
Richard M. Stallman committed
499

Mark Oteiza's avatar
Mark Oteiza committed
500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619
(defun caaar (x)
  "Return the `car' of the `car' of the `car' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (car (car (car x))))

(defun caadr (x)
  "Return the `car' of the `car' of the `cdr' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (car (car (cdr x))))

(defun cadar (x)
  "Return the `car' of the `cdr' of the `car' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (car (cdr (car x))))

(defun caddr (x)
  "Return the `car' of the `cdr' of the `cdr' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (car (cdr (cdr x))))

(defun cdaar (x)
  "Return the `cdr' of the `car' of the `car' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (cdr (car (car x))))

(defun cdadr (x)
  "Return the `cdr' of the `car' of the `cdr' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (cdr (car (cdr x))))

(defun cddar (x)
  "Return the `cdr' of the `cdr' of the `car' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (cdr (cdr (car x))))

(defun cdddr (x)
  "Return the `cdr' of the `cdr' of the `cdr' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (cdr (cdr (cdr x))))

(defun caaaar (x)
  "Return the `car' of the `car' of the `car' of the `car' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (car (car (car (car x)))))

(defun caaadr (x)
  "Return the `car' of the `car' of the `car' of the `cdr' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (car (car (car (cdr x)))))

(defun caadar (x)
  "Return the `car' of the `car' of the `cdr' of the `car' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (car (car (cdr (car x)))))

(defun caaddr (x)
  "Return the `car' of the `car' of the `cdr' of the `cdr' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (car (car (cdr (cdr x)))))

(defun cadaar (x)
  "Return the `car' of the `cdr' of the `car' of the `car' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (car (cdr (car (car x)))))

(defun cadadr (x)
  "Return the `car' of the `cdr' of the `car' of the `cdr' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (car (cdr (car (cdr x)))))

(defun caddar (x)
  "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (car (cdr (cdr (car x)))))

(defun cadddr (x)
  "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (car (cdr (cdr (cdr x)))))

(defun cdaaar (x)
  "Return the `cdr' of the `car' of the `car' of the `car' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (cdr (car (car (car x)))))

(defun cdaadr (x)
  "Return the `cdr' of the `car' of the `car' of the `cdr' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (cdr (car (car (cdr x)))))

(defun cdadar (x)
  "Return the `cdr' of the `car' of the `cdr' of the `car' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (cdr (car (cdr (car x)))))

(defun cdaddr (x)
  "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (cdr (car (cdr (cdr x)))))

(defun cddaar (x)
  "Return the `cdr' of the `cdr' of the `car' of the `car' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (cdr (cdr (car (car x)))))

(defun cddadr (x)
  "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (cdr (cdr (car (cdr x)))))

(defun cdddar (x)
  "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (cdr (cdr (cdr (car x)))))

(defun cddddr (x)
  "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
  (declare (compiler-macro internal--compiler-macro-cXXr))
  (cdr (cdr (cdr (cdr x)))))

620 621 622 623 624
(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."
625
  (declare (side-effect-free t))
626
  (if n
627
      (and (>= n 0)
628
           (let ((m (safe-length list)))
629 630
             (if (< n m) (nthcdr (- m n) list) list)))
    (and list
631
         (nthcdr (1- (safe-length list)) list))))
632

633
(defun butlast (list &optional n)
634 635 636
  "Return a copy of LIST with the last N elements removed.
If N is omitted or nil, the last element is removed from the
copy."
637
  (declare (side-effect-free t))
638 639
  (if (and n (<= n 0)) list
    (nbutlast (copy-sequence list) n)))
640

641
(defun nbutlast (list &optional n)
642
  "Modify LIST to remove the last N elements.
643
If N is omitted or nil, remove the last element."
644
  (let ((m (length list)))
645 646 647
    (or n (setq n 1))
    (and (< n m)
	 (progn
648 649
	   (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
	   list))))
650

651 652 653 654 655
;; The function's definition was moved to fns.c,
;; but it's easier to set properties here.
(put 'proper-list-p 'pure t)
(put 'proper-list-p 'side-effect-free 'error-free)

Kenichi Handa's avatar
Kenichi Handa committed
656 657 658 659 660
(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."
661 662 663 664 665 666 667 668 669
  (let ((l (length list)))
    (if (> l 100)
        (let ((hash (make-hash-table :test #'equal :size l))
              (tail list) retail)
          (puthash (car list) t hash)
          (while (setq retail (cdr tail))
            (let ((elt (car retail)))
              (if (gethash elt hash)
                  (setcdr tail (cdr retail))
670 671
                (puthash elt t hash)
                (setq tail retail)))))
672 673 674 675
      (let ((tail list))
        (while tail
          (setcdr tail (delete (car tail) (cdr tail)))
          (setq tail (cdr tail))))))
676
  list)
Kenichi Handa's avatar
Kenichi Handa committed
677

678
;; See https://lists.gnu.org/r/emacs-devel/2013-05/msg00204.html
679 680 681 682 683
(defun delete-consecutive-dups (list &optional circular)
  "Destructively remove `equal' consecutive duplicates from LIST.
First and last elements are considered consecutive if CIRCULAR is
non-nil."
  (let ((tail list) last)
684
    (while (cdr tail)
685 686
      (if (equal (car tail) (cadr tail))
	  (setcdr tail (cddr tail))
687
	(setq last tail
688 689
	      tail (cdr tail))))
    (if (and circular
690 691 692 693
	     last
	     (equal (car tail) (car list)))
	(setcdr last nil)))
  list)
694

695
(defun number-sequence (from &optional to inc)
696
  "Return a sequence of numbers from FROM to TO (both inclusive) as a list.
Kenichi Handa's avatar
Kenichi Handa committed
697
INC is the increment used between numbers in the sequence and defaults to 1.
Juanma Barranquero's avatar
Juanma Barranquero committed
698
So, the Nth element of the list is (+ FROM (* N INC)) where N counts from
699
zero.  TO is included only if there is an N for which TO = FROM + N * INC.
Juanma Barranquero's avatar
Juanma Barranquero committed
700
If TO is nil or numerically equal to FROM, return (FROM).
Kenichi Handa's avatar
Kenichi Handa committed
701 702 703 704 705 706 707 708 709
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
Juanma Barranquero's avatar
Juanma Barranquero committed
710 711
\(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
Kenichi Handa's avatar
Kenichi Handa committed
712 713
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
Juanma Barranquero's avatar
Juanma Barranquero committed
714
TO as (+ FROM (* N INC)) or use a variable whose value was
Kenichi Handa's avatar
Kenichi Handa committed
715 716 717 718
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))
719 720
      (list from)
    (or inc (setq inc 1))
Kenichi Handa's avatar
Kenichi Handa committed
721
    (when (zerop inc) (error "The increment can not be zero"))
722
    (let (seq (n 0) (next from))
Kenichi Handa's avatar
Kenichi Handa committed
723
      (if (> inc 0)
724
          (while (<= next to)
Kenichi Handa's avatar
Kenichi Handa committed
725 726 727
            (setq seq (cons next seq)
                  n (1+ n)
                  next (+ from (* n inc))))
728
        (while (>= next to)
Kenichi Handa's avatar
Kenichi Handa committed
729 730 731
          (setq seq (cons next seq)
                n (1+ n)
                next (+ from (* n inc)))))
732
      (nreverse seq))))
733

734 735 736
(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.
737
Contrast to `copy-sequence', which copies only along the cdrs.  With second
738 739
argument VECP, this copies vectors as well as conses."
  (if (consp tree)
740 741 742 743 744 745 746
      (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)))
747 748
	(nconc (nreverse result)
               (if (and vecp (vectorp tree)) (copy-tree tree vecp) tree)))
749 750 751
    (if (and vecp (vectorp tree))
	(let ((i (length (setq tree (copy-sequence tree)))))
	  (while (>= (setq i (1- i)) 0)
752 753 754
	    (aset tree i (copy-tree (aref tree i) vecp)))
	  tree)
      tree)))
755 756

;;;; Various list-search functions.
757

758 759
(defun assoc-default (key alist &optional test default)
  "Find object KEY in a pseudo-alist ALIST.
760 761 762 763 764 765 766
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.
767 768 769

If no element matches, the value is nil.
If TEST is omitted or nil, `equal' is used."
770
  (declare (side-effect-free t))
771 772 773 774 775 776 777
  (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))
778

779
(defun member-ignore-case (elt list)
Glenn Morris's avatar
Glenn Morris committed
780
  "Like `member', but ignore differences in case and text representation.
781
ELT must be a string.  Upper-case and lower-case letters are treated as equal.
782 783
Unibyte strings are converted to multibyte for comparison.
Non-strings in LIST are ignored."
784
  (declare (side-effect-free t))
785 786 787
  (while (and list
	      (not (and (stringp (car list))
			(eq t (compare-strings elt 0 nil (car list) 0 nil t)))))
788 789
    (setq list (cdr list)))
  list)
790

791 792 793
(defun assoc-delete-all (key alist &optional test)
  "Delete from ALIST all elements whose car is KEY.
Compare keys with TEST.  Defaults to `equal'.
794 795
Return the modified alist.
Elements of ALIST that are not conses are ignored."
796
  (unless test (setq test #'equal))
797
  (while (and (consp (car alist))
798
	      (funcall test (caar alist) key))
799 800 801 802
    (setq alist (cdr alist)))
  (let ((tail alist) tail-cdr)
    (while (setq tail-cdr (cdr tail))
      (if (and (consp (car tail-cdr))
803
	       (funcall test (caar tail-cdr) key))
804 805 806 807
	  (setcdr tail (cdr tail-cdr))
	(setq tail tail-cdr))))
  alist)

808 809 810 811
(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."
812
  (assoc-delete-all key alist #'eq))
813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828

(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)

829
(defun alist-get (key alist &optional default remove testfn)
830
  "Find the first element of ALIST whose `car' equals KEY and return its `cdr'.
831
If KEY is not found in ALIST, return DEFAULT.
832
Equality with KEY is tested by TESTFN, defaulting to `eq'.
833

834 835 836 837 838 839 840
You can use `alist-get' in PLACE expressions.  This will modify
an existing association (more precisely, the first one if
multiple exist), or add a new element to the beginning of ALIST,
destructively modifying the list stored in ALIST.

Example:

841 842 843
   (setq foo \\='((a . 0)))
   (setf (alist-get \\='a foo) 1
         (alist-get \\='b foo) 2)
844 845 846 847

   foo => ((b . 2) (a . 1))


848
When using it to set a value, optional argument REMOVE non-nil
849 850 851 852 853 854
means to remove KEY from ALIST if the new value is `eql' to
DEFAULT (more precisely the first found association will be
deleted from the alist).

Example:

855 856
  (setq foo \\='((a . 1) (b . 2)))
  (setf (alist-get \\='b foo nil \\='remove) nil)
857 858

  foo => ((a . 1))"
859
  (ignore remove) ;;Silence byte-compiler.
860 861 862
  (let ((x (if (not testfn)
               (assq key alist)
             (assoc key alist testfn))))
863 864
    (if x (cdr x) default)))

865 866 867
(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'."
868
  (declare (side-effect-free t))
869 870 871 872 873
  (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))))
874 875

(defun remq (elt list)
876
  "Return LIST with all occurrences of ELT removed.
877 878
The comparison is done with `eq'.  Contrary to `delq', this does not use
side-effects, and the argument LIST is not modified."
879
  (declare (side-effect-free t))
880
  (while (and (eq elt (car list)) (setq list (cdr list))))
881 882 883
  (if (memq elt list)
      (delq elt (copy-sequence list))
    list))
884 885

;;;; Keymap support.
David Lawrence's avatar
David Lawrence committed
886

887 888
(defun kbd (keys)
  "Convert KEYS to the internal Emacs key representation.
Lars Ingebrigtsen's avatar
Lars Ingebrigtsen committed
889 890 891
KEYS should be a string in the format returned by commands such
as `C-h k' (`describe-key').
This is the same format used for saving keyboard macros (see
892 893 894
`edmacro-mode').

For an approximate inverse of this, see `key-description'."
895
  ;; Don't use a defalias, since the `pure' property is true only for
896 897
  ;; the calling convention of `kbd'.
  (read-kbd-macro keys))
898
(put 'kbd 'pure t)
899

David Lawrence's avatar
David Lawrence committed
900
(defun undefined ()
901
  "Beep to tell the user this binding is undefined."
David Lawrence's avatar
David Lawrence committed
902
  (interactive)
903
  (ding)
904 905 906
  (if defining-kbd-macro
      (error "%s is undefined" (key-description (this-single-command-keys)))
    (message "%s is undefined" (key-description (this-single-command-keys))))
907 908 909 910 911 912
  (force-mode-line-update)
  ;; If this is a down-mouse event, don't reset prefix-arg;
  ;; pass it to the command run by the up event.
  (setq prefix-arg
        (when (memq 'down (event-modifiers last-command-event))
          current-prefix-arg)))
David Lawrence's avatar
David Lawrence committed
913

914 915
;; Prevent the \{...} documentation construct
;; from mentioning keys that run this command.
David Lawrence's avatar
David Lawrence committed
916 917 918 919 920 921
(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."
922
  (define-key map [remap self-insert-command] 'undefined)
David Lawrence's avatar
David Lawrence committed
923 924 925 926 927 928 929 930 931
  (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))))))

932 933 934 935 936 937 938 939 940 941 942 943 944 945
(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))

946
(defun define-key-after (keymap key definition &optional after)
947 948 949
  "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
950 951 952
of the map.  Note that AFTER must be an event type (like KEY), NOT a command
\(like DEFINITION).

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

956
Bindings are always added before any inherited map.
957

958
The order of bindings in a keymap matters only when it is used as
959
a menu, so this function is not useful for non-menu keymaps."
960
  (unless after (setq after t))
961 962
  (or (keymapp keymap)
      (signal 'wrong-type-argument (list 'keymapp keymap)))
963 964 965 966 967 968 969
  (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)
970 971
    (while (and (not done) tail)
      ;; Delete any earlier bindings for the same key.
972
      (if (eq (car-safe (car (cdr tail))) key)
973
	  (setcdr tail (cdr (cdr tail))))
974 975
      ;; If we hit an included map, go down that one.
      (if (keymapp (car tail)) (setq tail (car tail)))
976 977
      ;; When we reach AFTER's binding, insert the new binding after.
      ;; If we reach an inherited keymap, insert just before that.
978
      ;; If we reach the end of this keymap, insert at the end.
979 980
      (if (or (and (eq (car-safe (car tail)) after)
		   (not (eq after t)))
981 982
	      (eq (car (cdr tail)) 'keymap)
	      (null (cdr tail)))
983
	  (progn
984 985 986 987 988 989 990
	    ;; 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
991
		(setcdr tail (cons (cons key definition) (cdr tail))))
992
	    (setq inserted t)))
993 994
      (setq tail (cdr tail)))))

995
(defun map-keymap-sorted (function keymap)
996 997
  "Implement `map-keymap' with sorting.
Don't call this function; it is for internal use only."
998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011
  (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)))))
1012

1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031
(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
1032
   ((not (consp item)) binding)		;Not a menu-item.
1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055
   ((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)))))

1056
(defun keymap-canonicalize (map)
1057 1058 1059 1060 1061 1062 1063 1064 1065 1066
  "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.
1067
  (let ((bindings ())
1068 1069
        (ranges ())
	(prompt (keymap-prompt map)))
1070
    (while (keymapp map)
1071
      (setq map (map-keymap ;; -internal
1072 1073 1074 1075 1076 1077
                 (lambda (key item)
                   (if (consp key)
                       ;; Treat char-ranges specially.
                       (push (cons key item) ranges)
                     (push (cons key item) bindings)))
                 map)))
1078
    ;; Create the new map.
1079
    (setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap) prompt))