subr.el 203 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-2016 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 <http://www.gnu.org/licenses/>.
David Lawrence's avatar
David Lawrence committed
24

25 26 27
;; Beware: while this file has tag `utf-8', before it's compiled, it gets
;; loaded as "raw-text", so non-ASCII chars won't work right during bootstrap.

28 29 30 31

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

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

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.

47 48
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
49 50
ARGLIST specifies an empty argument list, and an explicit t
ARGLIST is a placeholder that allows supplying a later arg.
51 52 53 54 55

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'.
56 57

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

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

66

67
;;;; Basic Lisp macros.
68

Stefan Monnier's avatar
Stefan Monnier committed
69
(defalias 'not 'null)
70
(defalias 'sxhash 'sxhash-equal)
Stefan Monnier's avatar
Stefan Monnier committed
71

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

(defmacro 1value (form)
Luc Teirlinck's avatar
Luc Teirlinck committed
80 81 82
  "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."
83
  (declare (debug t))
Kenichi Handa's avatar
Kenichi Handa committed
84 85
  form)

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

95 96 97 98 99
(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
100
function, i.e., stored as the function value of a symbol, passed to
101
`funcall' or `mapcar', etc.
Richard M. Stallman's avatar
Richard M. Stallman committed
102

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

\(fn ARGS [DOCSTRING] [INTERACTIVE] BODY)"
112 113 114 115 116
  (declare (doc-string 2) (indent defun)
           (debug (&define lambda-list
                           [&optional stringp]
                           [&optional ("interactive" interactive)]
                           def-body)))
117 118 119 120
  ;; Note that this definition should not use backquotes; subr.el should not
  ;; depend on backquote.el.
  (list 'function (cons 'lambda cdr)))

121 122 123 124 125 126 127 128 129
(defmacro setq-local (var val)
  "Set variable VAR to value VAL in current buffer."
  ;; Can't use backquote here, it's too early in the bootstrap.
  (list 'set (list 'make-local-variable (list 'quote var)) val))

(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."
130
  (declare (debug defvar) (doc-string 3))
131 132 133 134
  ;; 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))))

135 136 137 138 139 140
(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."
141 142
  (lambda (&rest args2)
    (apply fun (append args args2))))
143

144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161
(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)),
except that PLACE is only evaluated once (after NEWELT)."
  (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
162 163
If the value is nil, `pop' returns nil but does not actually
change the list."
164
  (declare (debug (gv-place)))
165 166 167 168 169 170 171 172 173
  ;; 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
174 175
         (macroexp-let2 macroexp-copyable-p x getter
           `(prog1 ,x ,(funcall setter `(cdr ,x))))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
176

177
(defmacro when (cond &rest body)
Kim F. Storm's avatar
Kim F. Storm committed
178 179 180 181
  "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
182
\(fn COND BODY...)"
183
  (declare (indent 1) (debug t))
184
  (list 'if cond (cons 'progn body)))
185

186
(defmacro unless (cond &rest body)
Kim F. Storm's avatar
Kim F. Storm committed
187 188 189 190
  "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
191
\(fn COND BODY...)"
192
  (declare (indent 1) (debug t))
193
  (cons 'if (cons cond (cons nil body))))
194

195
(defmacro dolist (spec &rest body)
196
  "Loop over a list.
197
Evaluate BODY with VAR bound to each car from LIST, in turn.
198 199
Then evaluate RESULT to get return value, default nil.

Markus Rost's avatar
Markus Rost committed
200
\(fn (VAR LIST [RESULT]) BODY...)"
201
  (declare (indent 1) (debug ((symbolp form &optional form) body)))
202 203 204
  ;; It would be cleaner to create an uninterned symbol,
  ;; but that uses a lot more space when many functions in many files
  ;; use dolist.
205
  ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
206
  (let ((temp '--dolist-tail--))
207 208 209 210 211 212 213 214 215 216
    ;; 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))))
217
           ,@(cdr (cdr spec)))
218 219 220 221 222 223 224 225
      `(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))))))))
226

227
(defmacro dotimes (spec &rest body)
228
  "Loop a certain number of times.
229 230
Evaluate BODY with VAR bound to successive integers running from 0,
inclusive, to COUNT, exclusive.  Then evaluate RESULT to get
231 232
the return value (nil if RESULT is omitted).

Markus Rost's avatar
Markus Rost committed
233
\(fn (VAR COUNT [RESULT]) BODY...)"
234
  (declare (indent 1) (debug dolist))
235 236 237
  ;; It would be cleaner to create an uninterned symbol,
  ;; but that uses a lot more space when many functions in many files
  ;; use dotimes.
238
  ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
239
  (let ((temp '--dotimes-limit--)
240 241
	(start 0)
	(end (nth 1 spec)))
242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261
    ;; 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))))))
262

263
(defmacro declare (&rest _specs)
264 265 266 267 268 269 270
  "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
271 272 273
`defun-declarations-alist' and `macro-declarations-alist'.

For more information, see info node `(elisp)Declare Form'."
Stefan Monnier's avatar
Stefan Monnier committed
274
  ;; FIXME: edebug spec should pay attention to defun-declarations-alist.
275
  nil)
276 277 278

(defmacro ignore-errors (&rest body)
  "Execute BODY; if an error occurs, return nil.
279 280 281
Otherwise, return result of last form in BODY.
See also `with-demoted-errors' that does something similar
without silencing all errors."
282
  (declare (debug t) (indent 0))
283
  `(condition-case nil (progn ,@body) (error nil)))
284 285 286

;;;; Basic Lisp functions.

287
(defun ignore (&rest _ignore)
288 289 290 291 292
  "Do nothing and return nil.
This function accepts any number of arguments, but ignores them."
  (interactive)
  nil)

293
;; Signal a compile-error if the first arg is missing.
294
(defun error (&rest args)
Paul Eggert's avatar
Paul Eggert committed
295
  "Signal an error, making a message by passing args to `format-message'.
296 297
In Emacs, the convention is that error messages start with a capital
letter but *do not* end with a period.  Please follow this convention
Paul Eggert's avatar
Paul Eggert committed
298 299 300 301
for the sake of consistency.

Note: (error \"%s\" VALUE) makes the message VALUE without
interpreting format characters like `%', `\\=`', and `\\=''."
302
  (declare (advertised-calling-convention (string &rest args) "23.1"))
303
  (signal 'error (list (apply #'format-message args))))
304

305
(defun user-error (format &rest args)
Paul Eggert's avatar
Paul Eggert committed
306
  "Signal a pilot error, making a message by passing args to `format-message'.
307 308 309 310 311
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.
This is just like `error' except that `user-error's are expected to be the
result of an incorrect manipulation on the part of the user, rather than the
Paul Eggert's avatar
Paul Eggert committed
312 313 314 315
result of an actual problem.

Note: (user-error \"%s\" VALUE) makes the message VALUE without
interpreting format characters like `%', `\\=`', and `\\=''."
316
  (signal 'user-error (list (apply #'format-message format args))))
317

318 319 320 321 322 323 324 325 326
(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)
327
             (apply #'append
328 329 330
                    (mapcar (lambda (parent)
                              (cons parent
                                    (or (get parent 'error-conditions)
331
                                        (error "Unknown signal `%s'" parent))))
332 333 334 335 336 337
                            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))))

338 339 340 341 342 343 344 345
;; 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)))
346

347 348

;;;; List functions.
Kenichi Handa's avatar
Kenichi Handa committed
349

350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367
;; 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)
368
  "Return the car of the car of X."
369
  (declare (compiler-macro internal--compiler-macro-cXXr))
370 371
  (car (car x)))

372
(defun cadr (x)
373
  "Return the car of the cdr of X."
374
  (declare (compiler-macro internal--compiler-macro-cXXr))
375 376
  (car (cdr x)))

377
(defun cdar (x)
378
  "Return the cdr of the car of X."
379
  (declare (compiler-macro internal--compiler-macro-cXXr))
380 381
  (cdr (car x)))

382
(defun cddr (x)
383
  "Return the cdr of the cdr of X."
384
  (declare (compiler-macro internal--compiler-macro-cXXr))
385
  (cdr (cdr x)))
Richard M. Stallman's avatar
Richard M. Stallman committed
386

387 388 389 390 391
(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."
392
  (if n
393
      (and (>= n 0)
394
           (let ((m (safe-length list)))
395 396
             (if (< n m) (nthcdr (- m n) list) list)))
    (and list
397
         (nthcdr (1- (safe-length list)) list))))
398

399
(defun butlast (list &optional n)
400 401 402
  "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."
403 404
  (if (and n (<= n 0)) list
    (nbutlast (copy-sequence list) n)))
405

406
(defun nbutlast (list &optional n)
407 408
  "Modifies LIST to remove the last N elements.
If N is omitted or nil, remove the last element."
409
  (let ((m (length list)))
410 411 412
    (or n (setq n 1))
    (and (< n m)
	 (progn
413 414
	   (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
	   list))))
415

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

Kenichi Handa's avatar
Kenichi Handa committed
423 424 425 426 427
(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."
428 429 430 431 432 433 434 435 436
  (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))
437 438
                (puthash elt t hash)
                (setq tail retail)))))
439 440 441 442
      (let ((tail list))
        (while tail
          (setcdr tail (delete (car tail) (cdr tail)))
          (setq tail (cdr tail))))))
443
  list)
Kenichi Handa's avatar
Kenichi Handa committed
444

445 446 447 448 449 450
;; See http://lists.gnu.org/archive/html/emacs-devel/2013-05/msg00204.html
(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)
451
    (while (cdr tail)
452 453
      (if (equal (car tail) (cadr tail))
	  (setcdr tail (cddr tail))
454
	(setq last tail
455 456
	      tail (cdr tail))))
    (if (and circular
457 458 459 460
	     last
	     (equal (car tail) (car list)))
	(setcdr last nil)))
  list)
461

462
(defun number-sequence (from &optional to inc)
463
  "Return a sequence of numbers from FROM to TO (both inclusive) as a list.
Kenichi Handa's avatar
Kenichi Handa committed
464
INC is the increment used between numbers in the sequence and defaults to 1.
Juanma Barranquero's avatar
Juanma Barranquero committed
465
So, the Nth element of the list is (+ FROM (* N INC)) where N counts from
Kenichi Handa's avatar
Kenichi Handa committed
466
zero.  TO is only included if there is an N for which TO = FROM + N * INC.
Juanma Barranquero's avatar
Juanma Barranquero committed
467
If TO is nil or numerically equal to FROM, return (FROM).
Kenichi Handa's avatar
Kenichi Handa committed
468 469 470 471 472 473 474 475 476
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
477 478
\(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
479 480
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
481
TO as (+ FROM (* N INC)) or use a variable whose value was
Kenichi Handa's avatar
Kenichi Handa committed
482 483 484 485
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))
486 487
      (list from)
    (or inc (setq inc 1))
Kenichi Handa's avatar
Kenichi Handa committed
488
    (when (zerop inc) (error "The increment can not be zero"))
489
    (let (seq (n 0) (next from) (last from))
Kenichi Handa's avatar
Kenichi Handa committed
490
      (if (> inc 0)
491 492 493
          ;; The (>= next last) condition protects against integer
          ;; overflow in computing NEXT.
          (while (and (>= next last) (<= next to))
Kenichi Handa's avatar
Kenichi Handa committed
494 495
            (setq seq (cons next seq)
                  n (1+ n)
496
                  last next
Kenichi Handa's avatar
Kenichi Handa committed
497
                  next (+ from (* n inc))))
498
        (while (and (<= next last) (>= next to))
Kenichi Handa's avatar
Kenichi Handa committed
499 500 501
          (setq seq (cons next seq)
                n (1+ n)
                next (+ from (* n inc)))))
502
      (nreverse seq))))
503

504 505 506
(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.
507
Contrast to `copy-sequence', which copies only along the cdrs.  With second
508 509
argument VECP, this copies vectors as well as conses."
  (if (consp tree)
510 511 512 513 514 515 516
      (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)))
517
	(nconc (nreverse result) tree))
518 519 520
    (if (and vecp (vectorp tree))
	(let ((i (length (setq tree (copy-sequence tree)))))
	  (while (>= (setq i (1- i)) 0)
521 522 523
	    (aset tree i (copy-tree (aref tree i) vecp)))
	  tree)
      tree)))
524 525

;;;; Various list-search functions.
526

527 528
(defun assoc-default (key alist &optional test default)
  "Find object KEY in a pseudo-alist ALIST.
529 530 531 532 533 534 535
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.
536 537 538 539 540 541 542 543 544 545

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))
546 547 548 549 550

(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."
551
  (declare (obsolete assoc-string "22.1"))
Kenichi Handa's avatar
Kenichi Handa committed
552
  (assoc-string key alist t))
553 554 555

(defun assoc-ignore-representation (key alist)
  "Like `assoc', but ignores differences in text representation.
Juanma Barranquero's avatar
Juanma Barranquero committed
556
KEY must be a string.
557
Unibyte strings are converted to multibyte for comparison."
558
  (declare (obsolete assoc-string "22.1"))
Kenichi Handa's avatar
Kenichi Handa committed
559
  (assoc-string key alist nil))
560 561

(defun member-ignore-case (elt list)
Glenn Morris's avatar
Glenn Morris committed
562
  "Like `member', but ignore differences in case and text representation.
563
ELT must be a string.  Upper-case and lower-case letters are treated as equal.
564 565 566 567 568
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)))))
569 570
    (setq list (cdr list)))
  list)
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
(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)

602
(defun alist-get (key alist &optional default remove)
603 604 605 606 607 608
  "Return the value associated with KEY in ALIST, using `assq'.
If KEY is not found in ALIST, return DEFAULT.

This is a generalized variable suitable for use with `setf'.
When using it to set a value, optional argument REMOVE non-nil
means to remove KEY from ALIST if the new value is `eql' to DEFAULT."
609 610 611 612
  (ignore remove) ;;Silence byte-compiler.
  (let ((x (assq key alist)))
    (if x (cdr x) default)))

613 614 615 616 617 618 619 620 621 622
(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)
623
  "Return LIST with all occurrences of ELT removed.
624 625
The comparison is done with `eq'.  Contrary to `delq', this does not use
side-effects, and the argument LIST is not modified."
626
  (while (and (eq elt (car list)) (setq list (cdr list))))
627 628 629
  (if (memq elt list)
      (delq elt (copy-sequence list))
    list))
630 631

;;;; Keymap support.
David Lawrence's avatar
David Lawrence committed
632

633 634
(defun kbd (keys)
  "Convert KEYS to the internal Emacs key representation.
Lars Ingebrigtsen's avatar
Lars Ingebrigtsen committed
635 636 637 638
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
`edmacro-mode')."
639 640 641
  ;; Don't use a defalias, since the `pure' property is only true for
  ;; the calling convention of `kbd'.
  (read-kbd-macro keys))
642
(put 'kbd 'pure t)
643

David Lawrence's avatar
David Lawrence committed
644
(defun undefined ()
645
  "Beep to tell the user this binding is undefined."
David Lawrence's avatar
David Lawrence committed
646
  (interactive)
647 648 649 650 651 652 653 654 655
  (ding)
  (message "%s is undefined" (key-description (this-single-command-keys)))
  (setq defining-kbd-macro nil)
  (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
656

657 658
;; Prevent the \{...} documentation construct
;; from mentioning keys that run this command.
David Lawrence's avatar
David Lawrence committed
659 660 661 662 663 664
(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."
665
  (define-key map [remap self-insert-command] 'undefined)
David Lawrence's avatar
David Lawrence committed
666 667 668 669 670 671 672 673 674
  (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))))))

675 676 677 678 679 680 681 682 683 684 685 686 687 688
(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))

689
(defun define-key-after (keymap key definition &optional after)
690 691 692
  "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
693 694 695
of the map.  Note that AFTER must be an event type (like KEY), NOT a command
\(like DEFINITION).

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

699
Bindings are always added before any inherited map.
700

701 702
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."
703
  (unless after (setq after t))
704 705
  (or (keymapp keymap)
      (signal 'wrong-type-argument (list 'keymapp keymap)))
706 707 708 709 710 711 712
  (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)
713 714
    (while (and (not done) tail)
      ;; Delete any earlier bindings for the same key.
715
      (if (eq (car-safe (car (cdr tail))) key)
716
	  (setcdr tail (cdr (cdr tail))))
717 718
      ;; If we hit an included map, go down that one.
      (if (keymapp (car tail)) (setq tail (car tail)))
719 720
      ;; When we reach AFTER's binding, insert the new binding after.
      ;; If we reach an inherited keymap, insert just before that.
721
      ;; If we reach the end of this keymap, insert at the end.
722 723
      (if (or (and (eq (car-safe (car tail)) after)
		   (not (eq after t)))
724 725
	      (eq (car (cdr tail)) 'keymap)
	      (null (cdr tail)))
726
	  (progn
727 728 729 730 731 732 733
	    ;; 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
734
		(setcdr tail (cons (cons key definition) (cdr tail))))
735
	    (setq inserted t)))
736 737
      (setq tail (cdr tail)))))

738
(defun map-keymap-sorted (function keymap)
739 740
  "Implement `map-keymap' with sorting.
Don't call this function; it is for internal use only."
741 742 743 744 745 746 747 748 749 750 751 752 753 754
  (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)))))
755

756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774
(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
775
   ((not (consp item)) binding)		;Not a menu-item.
776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798
   ((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)))))

799
(defun keymap-canonicalize (map)
800 801 802 803 804 805 806 807 808 809
  "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.
810
  (let ((bindings ())
811 812
        (ranges ())
	(prompt (keymap-prompt map)))
813
    (while (keymapp map)
814
      (setq map (map-keymap ;; -internal
815 816 817 818 819 820
                 (lambda (key item)
                   (if (consp key)
                       ;; Treat char-ranges specially.
                       (push (cons key item) ranges)
                     (push (cons key item) bindings)))
                 map)))
821
    ;; Create the new map.
822
    (setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap) prompt))
823
    (dolist (binding ranges)
824
      ;; Treat char-ranges specially.  FIXME: need to merge as well.
Stefan Monnier's avatar
Stefan Monnier committed
825
      (define-key map (vector (car binding)) (cdr binding)))
826
    ;; Process the bindings starting from the end.
827 828 829
    (dolist (binding (prog1 bindings (setq bindings ())))
      (let* ((key (car binding))
             (oldbind (assq key bindings)))
830 831 832 833 834 835 836 837
        (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)))
838 839
    (nconc map bindings)))

840 841
(put 'keyboard-translate-table 'char-table-extra-slots 0)

842
(defun keyboard-translate (from to)
843
  "Translate character FROM to TO on the current terminal.
844 845
This function creates a `keyboard-translate-table' if necessary
and then modifies one entry in it."
846 847 848
  (or (char-table-p keyboard-translate-table)
      (setq keyboard-translate-table
	    (make-char-table 'keyboard-translate-table nil)))
849 850
  (aset keyboard-translate-table from to))

851
;;;; Key binding commands.
852

853 854 855 856 857 858 859
(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.
860

861 862 863
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."
864 865 866 867 868 869
  (interactive
   (let* ((menu-prompting nil)
          (key (read-key-sequence "Set key globally: ")))
     (list key
           (read-command (format "Set key %s to command: "
                                 (key-description key))))))
870 871 872
  (or (vectorp key) (stringp key)
      (signal 'wrong-type-argument (list 'arrayp key)))
  (define-key (current-global-map) key command))
873

874 875 876 877 878 879 880
(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.
881

Juanma Barranquero's avatar
Juanma Barranquero committed
882 883
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."
884 885 886 887 888 889 890
  (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)))
891

892 893 894 895 896
(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))
897

898 899 900 901 902 903 904 905 906 907 908
(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
909
  "Used internally by `substitute-key-definition'.")
910 911 912 913 914 915 916

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

917 918
If you don't specify OLDMAP, you can usually get the same results
in a cleaner way with command remapping, like this:
Juanma Barranquero's avatar
Juanma Barranquero committed
919
  (define-key KEYMAP [remap OLDDEF] NEWDEF)
920
\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)"
921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964
  ;; 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
965
	    (or (indirect-function defn) defn))
966 967 968 969 970 971 972 973 974 975 976 977
      ;; 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)))))
978 979


Juanma Barranquero's avatar
Juanma Barranquero committed
980
;;;; The global keymap tree.
981

982 983
;; global-map, esc-map, and ctl-x-map have their values set up in
;; keymap.c; we just give them docstrings here.
984 985 986 987 988 989 990 991 992 993 994 995 996 997 998

(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
999
  "Keymap for subcommands of C-x 4.")
1000
(defalias 'ctl-x-4-prefix ctl-x-4-map)
1001 1002 1003 1004
(define-key ctl-x-map "4" 'ctl-x-4-prefix)

(defvar ctl-x-5-map (make-sparse-keymap)
  "Keymap for frame commands.")
1005
(defalias 'ctl-x-5-prefix ctl-x-5-map)
1006 1007
(define-key ctl-x-map "5" 'ctl-x-5-prefix)

1008

1009 1010
;;;; Event manipulation functions.

1011
(defconst listify-key-sequence-1 (logior 128 ?\M-\C-@))
1012

1013 1014 1015 1016 1017 1018
(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)
1019
			    (logxor c listify-key-sequence-1)
1020
			  c)))
1021
	    key)))
1022

1023
(defun eventp (obj)
1024
  "True if the argument is an event object."
1025 1026 1027 1028
  (when obj
    (or (integerp obj)
        (and (symbolp obj) obj (not (keywordp obj)))
        (and (consp obj) (symbolp (car obj))))))
1029 1030

(defun event-modifiers (event)
1031
  "Return a list of symbols representing the modifier keys in event EVENT.
1032
The elements of the list may include `meta', `control',
1033
`shift', `hyper', `super', `alt', `click', `double', `triple', `drag',
1034 1035 1036
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
1037 1038
in the current Emacs session, then this function may fail to include
the `click' modifier."
1039 1040 1041 1042
  (let ((type event))
    (if (listp type)
	(setq type (car type)))
    (if (symbolp type)
1043 1044 1045
        ;; 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))
1046 1047 1048 1049
      (let ((list nil)
	    (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
					       ?\H-\^@ ?\s-\^@ ?\A-\^@)))))
	(if (not (zerop (logand type ?\M-\^@)))
1050
	    (push 'meta list))
1051 1052
	(if (or (not (zerop (logand type ?\C-\^@)))
		(< char 32))
1053
	    (push 'control list))
1054 1055
	(if (or (not (zerop (logand type ?\S-\^@)))
		(/= char (downcase char)))
1056
	    (push 'shift list))
1057
	(or (zerop (logand type ?\H-\^@))
1058
	    (push 'hyper list))
1059
	(or (zerop (logand type ?\s-\^@))
1060
	    (push 'super list))
1061
	(or (zerop (logand type ?\A-\^@))
1062
	    (push 'alt list))
1063 1064
	list))))

1065
(defun event-basic-type (event)
1066
  "Return the basic type of the given event (all modifiers removed).
1067 1068 1069 1070
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."
1071 1072
  (if (consp event)
      (setq event (car event)))