subr.el 99.6 KB
Newer Older
Eric S. Raymond's avatar
Eric S. Raymond committed
1
;;; subr.el --- basic lisp subroutines for Emacs
Eric S. Raymond's avatar
Eric S. Raymond committed
2

Stefan Monnier's avatar
Stefan Monnier committed
3
;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001, 2002, 03, 2004
4
;;   Free Software Foundation, Inc.
David Lawrence's avatar
David Lawrence committed
5

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

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

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

;; 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
Erik Naggum's avatar
Erik Naggum committed
22 23 24
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
David Lawrence's avatar
David Lawrence committed
25

26 27
;;; Commentary:

Eric S. Raymond's avatar
Eric S. Raymond committed
28
;;; Code:
29 30 31 32
(defvar custom-declare-variable-list nil
  "Record `defcustom' calls made before `custom.el' is loaded to handle them.
Each element of this list holds the arguments to one call to `defcustom'.")

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


(defun macro-declaration-function (macro decl)
  "Process a declaration found in a macro definition.
This is set as the value of the variable `macro-declaration-function'.
MACRO is the name of the macro being defined.
DECL is a list `(declare ...)' containing the declarations.
The return value of this function is not used."
46 47 48 49 50 51 52 53 54 55 56
  ;; We can't use `dolist' or `cadr' yet for bootstrapping reasons.
  (let (d)
    ;; Ignore the first element of `decl' (it's always `declare').
    (while (setq decl (cdr decl))
      (setq d (car decl))
      (cond ((and (consp d) (eq (car d) 'indent))
	     (put macro 'lisp-indent-function (car (cdr d))))
	    ((and (consp d) (eq (car d) 'debug))
	     (put macro 'edebug-form-spec (car (cdr d))))
	    (t
	     (message "Unknown declaration %s" d))))))
57 58 59

(setq macro-declaration-function 'macro-declaration-function)

60 61 62

;;;; Lisp language features.

Stefan Monnier's avatar
Stefan Monnier committed
63 64
(defalias 'not 'null)

65 66 67
(defmacro noreturn (form)
  "Evaluates FORM, with the expectation that the evaluation will signal an error
instead of returning to its caller.  If FORM does return, an error is
Luc Teirlinck's avatar
Luc Teirlinck committed
68
signalled."
69 70 71 72 73 74 75 76 77 78
  `(prog1 ,form
     (error "Form marked with `noreturn' did return")))

(defmacro 1value (form)
  "Evaluates FORM, with the expectation that all the same value will be returned
from all evaluations of FORM.  This is the global do-nothing
version of `1value'.  There is also `testcover-1value' that
complains if FORM ever does return differing values."
  form)

79 80 81 82 83
(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
84 85 86
function, i.e., stored as the function value of a symbol, passed to
funcall or mapcar, etc.

87
ARGS should take the same form as an argument list for a `defun'.
Richard M. Stallman's avatar
Richard M. Stallman committed
88 89 90
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.
91 92
INTERACTIVE should be a call to the function `interactive', which see.
It may also be omitted.
Kim F. Storm's avatar
Kim F. Storm committed
93
BODY should be a list of Lisp expressions."
94 95 96 97
  ;; Note that this definition should not use backquotes; subr.el should not
  ;; depend on backquote.el.
  (list 'function (cons 'lambda cdr)))

Richard M. Stallman's avatar
Richard M. Stallman committed
98
(defmacro push (newelt listname)
Richard M. Stallman's avatar
Richard M. Stallman committed
99
  "Add NEWELT to the list stored in the symbol LISTNAME.
Richard M. Stallman's avatar
Richard M. Stallman committed
100
This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)).
Richard M. Stallman's avatar
Richard M. Stallman committed
101
LISTNAME must be a symbol."
102
  (declare (debug (form sexp)))
Dave Love's avatar
Dave Love committed
103 104
  (list 'setq listname
	(list 'cons newelt listname)))
Richard M. Stallman's avatar
Richard M. Stallman committed
105 106 107 108 109 110

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

116
(defmacro when (cond &rest body)
117
  "If COND yields non-nil, do BODY, else return nil."
118
  (declare (indent 1) (debug t))
119
  (list 'if cond (cons 'progn body)))
120

121
(defmacro unless (cond &rest body)
122
  "If COND yields nil, do BODY, else return nil."
123
  (declare (indent 1) (debug t))
124
  (cons 'if (cons cond (cons nil body))))
125

126
(defmacro dolist (spec &rest body)
127
  "Loop over a list.
128
Evaluate BODY with VAR bound to each car from LIST, in turn.
129 130
Then evaluate RESULT to get return value, default nil.

Markus Rost's avatar
Markus Rost committed
131
\(fn (VAR LIST [RESULT]) BODY...)"
132
  (declare (indent 1) (debug ((symbolp form &optional form) body)))
133
  (let ((temp (make-symbol "--dolist-temp--")))
134 135 136 137 138 139 140 141
    `(let ((,temp ,(nth 1 spec))
	   ,(car spec))
       (while ,temp
	 (setq ,(car spec) (car ,temp))
	 (setq ,temp (cdr ,temp))
	 ,@body)
       ,@(if (cdr (cdr spec))
	     `((setq ,(car spec) nil) ,@(cdr (cdr spec)))))))
142 143

(defmacro dotimes (spec &rest body)
144
  "Loop a certain number of times.
145 146
Evaluate BODY with VAR bound to successive integers running from 0,
inclusive, to COUNT, exclusive.  Then evaluate RESULT to get
147 148
the return value (nil if RESULT is omitted).

Markus Rost's avatar
Markus Rost committed
149
\(fn (VAR COUNT [RESULT]) BODY...)"
150 151 152 153 154 155 156 157 158 159
  (declare (indent 1) (debug dolist))
  (let ((temp (make-symbol "--dotimes-temp--"))
	(start 0)
	(end (nth 1 spec)))
    `(let ((,temp ,end)
	   (,(car spec) ,start))
       (while (< ,(car spec) ,temp)
	 ,@body
	 (setq ,(car spec) (1+ ,(car spec))))
       ,@(cdr (cdr spec)))))
160

Luc Teirlinck's avatar
Luc Teirlinck committed
161 162 163 164 165 166
(defmacro declare (&rest specs)
  "Do not evaluate any arguments and return nil.
Treated as a declaration when used at the right place in a
`defmacro' form.  \(See Info anchor `(elisp)Definition of declare'."
  nil)

167 168 169 170 171 172 173 174 175 176 177 178 179 180 181
(defsubst caar (x)
  "Return the car of the car of X."
  (car (car x)))

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

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

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

183 184 185 186 187 188 189 190 191 192 193
(defun last (x &optional n)
  "Return the last link of the list X.  Its car is the last element.
If X is nil, return nil.
If N is non-nil, return the Nth-to-last link of X.
If N is bigger than the length of X, return X."
  (if n
      (let ((m 0) (p x))
	(while (consp p)
	  (setq m (1+ m) p (cdr p)))
	(if (<= n 0) p
	  (if (< n m) (nthcdr (- m n) x) x)))
194
    (while (consp (cdr x))
195 196
      (setq x (cdr x)))
    x))
197

198 199 200 201 202 203 204 205 206 207 208 209 210 211
(defun butlast (x &optional n)
  "Returns a copy of LIST with the last N elements removed."
  (if (and n (<= n 0)) x
    (nbutlast (copy-sequence x) n)))

(defun nbutlast (x &optional n)
  "Modifies LIST to remove the last N elements."
  (let ((m (length x)))
    (or n (setq n 1))
    (and (< n m)
	 (progn
	   (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
	   x))))

Luc Teirlinck's avatar
Luc Teirlinck committed
212
(defun delete-dups (list)
213 214 215 216
  "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."
Luc Teirlinck's avatar
Luc Teirlinck committed
217 218
  (let ((tail list))
    (while tail
219 220
      (setcdr tail (delete (car tail) (cdr tail)))
      (setq tail (cdr tail))))
Luc Teirlinck's avatar
Luc Teirlinck committed
221 222
  list)

223
(defun number-sequence (from &optional to inc)
224
  "Return a sequence of numbers from FROM to TO (both inclusive) as a list.
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246
INC is the increment used between numbers in the sequence and defaults to 1.
So, the Nth element of the list is \(+ FROM \(* N INC)) where N counts from
zero.  TO is only included if there is an N for which TO = FROM + N * INC.
If TO is nil or numerically equal to FROM, return \(FROM).
If INC is positive and TO is less than FROM, or INC is negative
and TO is larger than FROM, return nil.
If INC is zero and TO is neither nil nor numerically equal to
FROM, signal an error.

This function is primarily designed for integer arguments.
Nevertheless, FROM, TO and INC can be integer or float.  However,
floating point arithmetic is inexact.  For instance, depending on
the machine, it may quite well happen that
\(number-sequence 0.4 0.6 0.2) returns the one element list \(0.4),
whereas \(number-sequence 0.4 0.8 0.2) returns a list with three
elements.  Thus, if some of the arguments are floats and one wants
to make sure that TO is included, one may have to explicitly write
TO as \(+ FROM \(* N INC)) or use a variable whose value was
computed with this exact expression.  Alternatively, you can,
of course, also replace TO with a slightly larger value
\(or a slightly more negative value if INC is negative)."
  (if (or (not to) (= from to))
247 248
      (list from)
    (or inc (setq inc 1))
249 250 251 252 253 254 255 256 257 258 259
    (when (zerop inc) (error "The increment can not be zero"))
    (let (seq (n 0) (next from))
      (if (> inc 0)
          (while (<= next to)
            (setq seq (cons next seq)
                  n (1+ n)
                  next (+ from (* n inc))))
        (while (>= next to)
          (setq seq (cons next seq)
                n (1+ n)
                next (+ from (* n inc)))))
260
      (nreverse seq))))
261

262
(defun remove (elt seq)
Richard M. Stallman's avatar
Richard M. Stallman committed
263
  "Return a copy of SEQ with all occurrences of ELT removed.
264 265 266 267 268 269 270 271
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)
272 273 274
  "Return LIST with all occurrences of ELT removed.
The comparison is done with `eq'.  Contrary to `delq', this does not use
side-effects, and the argument LIST is not modified."
275 276 277 278
  (if (memq elt list)
      (delq elt (copy-sequence list))
    list))

279 280 281
(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.
282
Contrast to `copy-sequence', which copies only along the cdrs.  With second
283 284
argument VECP, this copies vectors as well as conses."
  (if (consp tree)
285 286 287 288 289 290 291
      (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)))
292
	(nconc (nreverse result) tree))
293 294 295
    (if (and vecp (vectorp tree))
	(let ((i (length (setq tree (copy-sequence tree)))))
	  (while (>= (setq i (1- i)) 0)
296 297 298
	    (aset tree i (copy-tree (aref tree i) vecp)))
	  tree)
      tree)))
299

300 301 302 303 304 305
(defun assoc-default (key alist &optional test default)
  "Find object KEY in a pseudo-alist ALIST.
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 evaluating (TEST (car elt) KEY).
If that is non-nil, the element matches;
then `assoc-default' returns the element's cdr, if it is a cons,
306
or DEFAULT if the element is not a cons.
307 308 309 310 311 312 313 314 315 316

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

318
(make-obsolete 'assoc-ignore-case 'assoc-string)
319 320 321 322
(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."
323
  (assoc-string key alist t))
324

325
(make-obsolete 'assoc-ignore-representation 'assoc-string)
326 327
(defun assoc-ignore-representation (key alist)
  "Like `assoc', but ignores differences in text representation.
Juanma Barranquero's avatar
Juanma Barranquero committed
328
KEY must be a string.
329
Unibyte strings are converted to multibyte for comparison."
330
  (assoc-string key alist nil))
331 332 333 334

(defun member-ignore-case (elt list)
  "Like `member', but ignores differences in case and text representation.
ELT must be a string.  Upper-case and lower-case letters are treated as equal.
335 336 337 338 339
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)))))
340 341
    (setq list (cdr list)))
  list)
342

343 344

;;;; Keymap support.
David Lawrence's avatar
David Lawrence committed
345 346 347 348 349 350 351 352 353 354 355 356 357

(defun undefined ()
  (interactive)
  (ding))

;Prevent the \{...} documentation construct
;from mentioning keys that run this command.
(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."
358
  (define-key map [remap self-insert-command] 'undefined)
David Lawrence's avatar
David Lawrence committed
359 360 361 362 363 364 365 366 367 368 369
  (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))))))

;Moved to keymap.c
;(defun copy-keymap (keymap)
Juanma Barranquero's avatar
Juanma Barranquero committed
370
;  "Return a copy of KEYMAP"
David Lawrence's avatar
David Lawrence committed
371 372 373 374 375 376
;  (while (not (keymapp keymap))
;    (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
;  (if (vectorp keymap)
;      (copy-sequence keymap)
;      (copy-alist keymap)))

377 378 379
(defvar key-substitution-in-progress nil
 "Used internally by substitute-key-definition.")

Richard M. Stallman's avatar
Richard M. Stallman committed
380
(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
David Lawrence's avatar
David Lawrence committed
381 382
  "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.
383
Alternatively, if optional fourth argument OLDMAP is specified, we redefine
384
in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP."
385 386 387
  ;; 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
Juanma Barranquero's avatar
Juanma Barranquero committed
388

389 390 391
  ;; 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.
Richard M. Stallman's avatar
Richard M. Stallman committed
392 393 394
  (or prefix (setq prefix ""))
  (let* ((scan (or oldmap keymap))
	 (vec1 (vector nil))
395 396 397
	 (prefix1 (vconcat prefix vec1))
	 (key-substitution-in-progress
	  (cons scan key-substitution-in-progress)))
Richard M. Stallman's avatar
Richard M. Stallman committed
398 399 400 401 402 403 404 405 406 407
    ;; Scan OLDMAP, finding each char or event-symbol that
    ;; has any definition, and act on it with hack-key.
    (while (consp scan)
      (if (consp (car scan))
	  (let ((char (car (car scan)))
		(defn (cdr (car scan))))
	    ;; The inside of this let duplicates exactly
	    ;; the inside of the following let that handles array elements.
	    (aset vec1 0 char)
	    (aset prefix1 (length prefix) char)
408
	    (let (inner-def skipped)
Richard M. Stallman's avatar
Richard M. Stallman committed
409 410
	      ;; Skip past menu-prompt.
	      (while (stringp (car-safe defn))
411
		(setq skipped (cons (car defn) skipped))
Richard M. Stallman's avatar
Richard M. Stallman committed
412
		(setq defn (cdr defn)))
413 414 415
	      ;; Skip past cached key-equivalence data for menu items.
	      (and (consp defn) (consp (car defn))
		   (setq defn (cdr defn)))
Richard M. Stallman's avatar
Richard M. Stallman committed
416
	      (setq inner-def defn)
417
	      ;; Look past a symbol that names a keymap.
Richard M. Stallman's avatar
Richard M. Stallman committed
418 419 420
	      (while (and (symbolp inner-def)
			  (fboundp inner-def))
		(setq inner-def (symbol-function inner-def)))
421 422 423 424 425
	      (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)))
426
		  (define-key keymap prefix1 (nconc (nreverse skipped) newdef))
427
		(if (and (keymapp defn)
428 429
			 ;; Avoid recursively scanning
			 ;; where KEYMAP does not have a submap.
430 431 432
			 (let ((elt (lookup-key keymap prefix1)))
			   (or (null elt)
			       (keymapp elt)))
433
			 ;; Avoid recursively rescanning keymap being scanned.
434 435
			 (not (memq inner-def
				    key-substitution-in-progress)))
436 437
		    ;; If this one isn't being scanned already,
		    ;; scan it now.
Richard M. Stallman's avatar
Richard M. Stallman committed
438 439 440
		    (substitute-key-definition olddef newdef keymap
					       inner-def
					       prefix1)))))
441
	(if (vectorp (car scan))
Richard M. Stallman's avatar
Richard M. Stallman committed
442 443 444 445 446 447 448 449 450
	    (let* ((array (car scan))
		   (len (length array))
		   (i 0))
	      (while (< i len)
		(let ((char i) (defn (aref array i)))
		  ;; The inside of this let duplicates exactly
		  ;; the inside of the previous let.
		  (aset vec1 0 char)
		  (aset prefix1 (length prefix) char)
451
		  (let (inner-def skipped)
Richard M. Stallman's avatar
Richard M. Stallman committed
452 453
		    ;; Skip past menu-prompt.
		    (while (stringp (car-safe defn))
454
		      (setq skipped (cons (car defn) skipped))
Richard M. Stallman's avatar
Richard M. Stallman committed
455
		      (setq defn (cdr defn)))
456 457
		    (and (consp defn) (consp (car defn))
			 (setq defn (cdr defn)))
Richard M. Stallman's avatar
Richard M. Stallman committed
458 459 460 461
		    (setq inner-def defn)
		    (while (and (symbolp inner-def)
				(fboundp inner-def))
		      (setq inner-def (symbol-function inner-def)))
462 463 464
		    (if (or (eq defn olddef)
			    (and (or (stringp defn) (vectorp defn))
				 (equal defn olddef)))
465 466
			(define-key keymap prefix1
			  (nconc (nreverse skipped) newdef))
467
		      (if (and (keymapp defn)
468 469 470
			       (let ((elt (lookup-key keymap prefix1)))
				 (or (null elt)
				     (keymapp elt)))
471 472
			       (not (memq inner-def
					  key-substitution-in-progress)))
Richard M. Stallman's avatar
Richard M. Stallman committed
473 474 475
			  (substitute-key-definition olddef newdef keymap
						     inner-def
						     prefix1)))))
476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500
		(setq i (1+ i))))
	  (if (char-table-p (car scan))
	      (map-char-table
	       (function (lambda (char defn)
			   (let ()
			     ;; The inside of this let duplicates exactly
			     ;; the inside of the previous let,
			     ;; except that it uses set-char-table-range
			     ;; instead of define-key.
			     (aset vec1 0 char)
			     (aset prefix1 (length prefix) char)
			     (let (inner-def skipped)
			       ;; Skip past menu-prompt.
			       (while (stringp (car-safe defn))
				 (setq skipped (cons (car defn) skipped))
				 (setq defn (cdr defn)))
			       (and (consp defn) (consp (car defn))
				    (setq defn (cdr defn)))
			       (setq inner-def defn)
			       (while (and (symbolp inner-def)
					   (fboundp inner-def))
				 (setq inner-def (symbol-function inner-def)))
			       (if (or (eq defn olddef)
				       (and (or (stringp defn) (vectorp defn))
					    (equal defn olddef)))
501 502
				   (define-key keymap prefix1
				     (nconc (nreverse skipped) newdef))
503 504 505 506 507 508 509 510 511 512
				 (if (and (keymapp defn)
					  (let ((elt (lookup-key keymap prefix1)))
					    (or (null elt)
						(keymapp elt)))
					  (not (memq inner-def
						     key-substitution-in-progress)))
				     (substitute-key-definition olddef newdef keymap
								inner-def
								prefix1)))))))
	       (car scan)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
513
      (setq scan (cdr scan)))))
514

515
(defun define-key-after (keymap key definition &optional after)
516 517 518
  "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
519 520 521
of the map.  Note that AFTER must be an event type (like KEY), NOT a command
\(like DEFINITION).

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

525
Bindings are always added before any inherited map.
526

527 528
The order of bindings in a keymap matters when it is used as a menu."
  (unless after (setq after t))
529 530
  (or (keymapp keymap)
      (signal 'wrong-type-argument (list 'keymapp keymap)))
531 532 533 534 535 536 537
  (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)
538 539
    (while (and (not done) tail)
      ;; Delete any earlier bindings for the same key.
540
      (if (eq (car-safe (car (cdr tail))) key)
541
	  (setcdr tail (cdr (cdr tail))))
542 543
      ;; If we hit an included map, go down that one.
      (if (keymapp (car tail)) (setq tail (car tail)))
544 545
      ;; When we reach AFTER's binding, insert the new binding after.
      ;; If we reach an inherited keymap, insert just before that.
546
      ;; If we reach the end of this keymap, insert at the end.
547 548
      (if (or (and (eq (car-safe (car tail)) after)
		   (not (eq after t)))
549 550
	      (eq (car (cdr tail)) 'keymap)
	      (null (cdr tail)))
551
	  (progn
552 553 554 555 556 557 558
	    ;; 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
559
		(setcdr tail (cons (cons key definition) (cdr tail))))
560
	    (setq inserted t)))
561 562
      (setq tail (cdr tail)))))

563

Richard M. Stallman's avatar
Richard M. Stallman committed
564 565 566 567 568 569
(defmacro kbd (keys)
  "Convert KEYS to the internal Emacs key representation.
KEYS should be a string constant in the format used for
saving keyboard macros (see `insert-kbd-macro')."
  (read-kbd-macro keys))

570 571
(put 'keyboard-translate-table 'char-table-extra-slots 0)

572 573 574 575
(defun keyboard-translate (from to)
  "Translate character FROM to TO at a low level.
This function creates a `keyboard-translate-table' if necessary
and then modifies one entry in it."
576 577 578
  (or (char-table-p keyboard-translate-table)
      (setq keyboard-translate-table
	    (make-char-table 'keyboard-translate-table nil)))
579 580 581
  (aset keyboard-translate-table from to))


Juanma Barranquero's avatar
Juanma Barranquero committed
582
;;;; The global keymap tree.
583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600

;;; global-map, esc-map, and ctl-x-map have their values set up in
;;; keymap.c; we just give them docstrings here.

(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
601
  "Keymap for subcommands of C-x 4.")
602
(defalias 'ctl-x-4-prefix ctl-x-4-map)
603 604 605 606
(define-key ctl-x-map "4" 'ctl-x-4-prefix)

(defvar ctl-x-5-map (make-sparse-keymap)
  "Keymap for frame commands.")
607
(defalias 'ctl-x-5-prefix ctl-x-5-map)
608 609
(define-key ctl-x-map "5" 'ctl-x-5-prefix)

610

611 612
;;;; Event manipulation functions.

613 614 615 616
;; The call to `read' is to ensure that the value is computed at load time
;; and not compiled into the .elc file.  The value is negative on most
;; machines, but not on all!
(defconst listify-key-sequence-1 (logior 128 (read "?\\M-\\^@")))
617

618 619 620 621 622 623
(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)
624
			    (logxor c listify-key-sequence-1)
625
			  c)))
626
	    key)))
627

628 629 630 631 632 633 634 635 636 637 638 639
(defsubst eventp (obj)
  "True if the argument is an event object."
  (or (integerp obj)
      (and (symbolp obj)
	   (get obj 'event-symbol-elements))
      (and (consp obj)
	   (symbolp (car obj))
	   (get (car obj) 'event-symbol-elements))))

(defun event-modifiers (event)
  "Returns a list of symbols representing the modifier keys in event EVENT.
The elements of the list may include `meta', `control',
640 641
`shift', `hyper', `super', `alt', `click', `double', `triple', `drag',
and `down'."
642 643 644 645 646
  (let ((type event))
    (if (listp type)
	(setq type (car type)))
    (if (symbolp type)
	(cdr (get type 'event-symbol-elements))
647 648 649 650
      (let ((list nil)
	    (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
					       ?\H-\^@ ?\s-\^@ ?\A-\^@)))))
	(if (not (zerop (logand type ?\M-\^@)))
651
	    (setq list (cons 'meta list)))
652 653
	(if (or (not (zerop (logand type ?\C-\^@)))
		(< char 32))
654
	    (setq list (cons 'control list)))
655 656
	(if (or (not (zerop (logand type ?\S-\^@)))
		(/= char (downcase char)))
657
	    (setq list (cons 'shift list)))
658
	(or (zerop (logand type ?\H-\^@))
659
	    (setq list (cons 'hyper list)))
660
	(or (zerop (logand type ?\s-\^@))
661
	    (setq list (cons 'super list)))
662
	(or (zerop (logand type ?\A-\^@))
663 664 665
	    (setq list (cons 'alt list)))
	list))))

666 667
(defun event-basic-type (event)
  "Returns the basic type of the given event (all modifiers removed).
Dave Love's avatar
Dave Love committed
668
The value is a printing character (not upper case) or a symbol."
669 670
  (if (consp event)
      (setq event (car event)))
671 672 673 674 675
  (if (symbolp event)
      (car (get event 'event-symbol-elements))
    (let ((base (logand event (1- (lsh 1 18)))))
      (downcase (if (< base 32) (logior base 64) base)))))

676 677 678 679 680 681 682
(defsubst mouse-movement-p (object)
  "Return non-nil if OBJECT is a mouse movement event."
  (and (consp object)
       (eq (car object) 'mouse-movement)))

(defsubst event-start (event)
  "Return the starting position of EVENT.
683
If EVENT is a mouse or key press or a mouse click, this returns the location
684 685 686
of the event.
If EVENT is a drag, this returns the drag's starting position.
The return value is of the form
687 688
   (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
    IMAGE (DX . DY) (WIDTH . HEIGHT))
689
The `posn-' functions access elements of such lists."
690 691
  (if (consp event) (nth 1 event)
    (list (selected-window) (point) '(0 . 0) 0)))
692 693

(defsubst event-end (event)
694 695
  "Return the ending location of EVENT.
EVENT should be a click, drag, or key press event.
696 697
If EVENT is a click event, this function is the same as `event-start'.
The return value is of the form
698 699
   (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
    IMAGE (DX . DY) (WIDTH . HEIGHT))
700
The `posn-' functions access elements of such lists."
701 702
  (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event)
    (list (selected-window) (point) '(0 . 0) 0)))
703

704 705 706
(defsubst event-click-count (event)
  "Return the multi-click count of EVENT, a click or drag event.
The return value is a positive integer."
707
  (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1))
708

709 710
(defsubst posn-window (position)
  "Return the window in POSITION.
711
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
712
and `event-end' functions."
713 714
  (nth 0 position))

715 716 717
(defsubst posn-area (position)
  "Return the window area recorded in POSITION, or nil for the text area.
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
718
and `event-end' functions."
719 720 721 722 723
  (let ((area (if (consp (nth 1 position))
		  (car (nth 1 position))
		(nth 1 position))))
    (and (symbolp area) area)))

724 725
(defsubst posn-point (position)
  "Return the buffer location in POSITION.
726
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
727
and `event-end' functions."
728 729 730 731
  (or (nth 5 position)
      (if (consp (nth 1 position))
	  (car (nth 1 position))
	(nth 1 position))))
732

733 734 735
(defun posn-set-point (position)
  "Move point to POSITION.
Select the corresponding window as well."
736
    (if (not (windowp (posn-window position)))
737
	(error "Position not in text area of window"))
738 739 740
    (select-window (posn-window position))
    (if (numberp (posn-point position))
	(goto-char (posn-point position))))
741

742 743
(defsubst posn-x-y (position)
  "Return the x and y coordinates in POSITION.
744
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
745
and `event-end' functions."
746 747
  (nth 2 position))

748
(defun posn-col-row (position)
749 750 751
  "Return the nominal column and row in POSITION, measured in characters.
The column and row values are approximations calculated from the x
and y coordinates in POSITION and the frame's default character width
Luc Teirlinck's avatar
Luc Teirlinck committed
752
and height.
753
For a scroll-bar event, the result column is 0, and the row
754 755
corresponds to the vertical position of the click in the scroll bar.
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
756
and `event-end' functions."
757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781
  (let* ((pair   (posn-x-y position))
	 (window (posn-window position))
	 (area   (posn-area position)))
    (cond
     ((null window)
      '(0 . 0))
     ((eq area 'vertical-scroll-bar)
      (cons 0 (scroll-bar-scale pair (1- (window-height window)))))
     ((eq area 'horizontal-scroll-bar)
      (cons (scroll-bar-scale pair (window-width window)) 0))
     (t
      (let* ((frame (if (framep window) window (window-frame window)))
	     (x (/ (car pair) (frame-char-width frame)))
	     (y (/ (cdr pair) (+ (frame-char-height frame)
				 (or (frame-parameter frame 'line-spacing)
				     default-line-spacing
				     0)))))
	(cons x y))))))

(defun posn-actual-col-row (position)
  "Return the actual column and row in POSITION, measured in characters.
These are the actual row number in the window and character number in that row.
Return nil if POSITION does not contain the actual position; in that case
`posn-col-row' can be used to get approximate values.
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
782
and `event-end' functions."
783
  (nth 6 position))
784

785 786
(defsubst posn-timestamp (position)
  "Return the timestamp of POSITION.
787
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
788
and `event-end' functions."
789
  (nth 3 position))
790

791 792
(defsubst posn-string (position)
  "Return the string object of POSITION, or nil if a buffer position.
793
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
794
and `event-end' functions."
795 796
  (nth 4 position))

797 798 799
(defsubst posn-image (position)
  "Return the image object of POSITION, or nil if a not an image.
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
800
and `event-end' functions."
801 802 803 804 805
  (nth 7 position))

(defsubst posn-object (position)
  "Return the object (image or string) of POSITION.
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
806
and `event-end' functions."
807 808
  (or (posn-image position) (posn-string position)))

Kim F. Storm's avatar
Kim F. Storm committed
809 810 811
(defsubst posn-object-x-y (position)
  "Return the x and y coordinates relative to the object of POSITION.
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
812
and `event-end' functions."
813 814 815 816 817
  (nth 8 position))

(defsubst posn-object-width-height (position)
  "Return the pixel width and height of the object of POSITION.
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
818
and `event-end' functions."
819
  (nth 9 position))
Kim F. Storm's avatar
Kim F. Storm committed
820

David Lawrence's avatar
David Lawrence committed
821

822 823
;;;; Obsolescent names for functions.

824 825 826 827 828 829 830 831 832 833 834 835 836
(defalias 'dot 'point)
(defalias 'dot-marker 'point-marker)
(defalias 'dot-min 'point-min)
(defalias 'dot-max 'point-max)
(defalias 'window-dot 'window-point)
(defalias 'set-window-dot 'set-window-point)
(defalias 'read-input 'read-string)
(defalias 'send-string 'process-send-string)
(defalias 'send-region 'process-send-region)
(defalias 'show-buffer 'set-window-buffer)
(defalias 'buffer-flush-undo 'buffer-disable-undo)
(defalias 'eval-current-buffer 'eval-buffer)
(defalias 'compiled-function-p 'byte-code-function-p)
837
(defalias 'define-function 'defalias)
David Lawrence's avatar
David Lawrence committed
838

839
(defalias 'sref 'aref)
840
(make-obsolete 'sref 'aref "20.4")
841
(make-obsolete 'char-bytes "now always returns 1." "20.4")
842
(make-obsolete 'chars-in-region "use (abs (- BEG END))." "20.3")
843 844 845 846 847 848 849 850
(make-obsolete 'dot 'point		"before 19.15")
(make-obsolete 'dot-max 'point-max	"before 19.15")
(make-obsolete 'dot-min 'point-min	"before 19.15")
(make-obsolete 'dot-marker 'point-marker "before 19.15")
(make-obsolete 'buffer-flush-undo 'buffer-disable-undo "before 19.15")
(make-obsolete 'baud-rate "use the baud-rate variable instead." "before 19.15")
(make-obsolete 'compiled-function-p 'byte-code-function-p "before 19.15")
(make-obsolete 'define-function 'defalias "20.1")
Richard M. Stallman's avatar
Richard M. Stallman committed
851

852 853 854 855 856 857
(defun insert-string (&rest args)
  "Mocklisp-compatibility insert function.
Like the function `insert' except that any argument that is a number
is converted into a string by expressing it in decimal."
  (dolist (el args)
    (insert (if (integerp el) (number-to-string el) el))))
858 859 860
(make-obsolete 'insert-string 'insert "21.4")
(defun makehash (&optional test) (make-hash-table :test (or test 'eql)))
(make-obsolete 'makehash 'make-hash-table "21.4")
861

862 863
;; Some programs still use this as a function.
(defun baud-rate ()
864
  "Return the value of the `baud-rate' variable."
865 866
  baud-rate)

867 868
(defalias 'focus-frame 'ignore)
(defalias 'unfocus-frame 'ignore)
869 870 871 872 873 874 875 876 877 878 879 880 881 882 883


;;;; Obsolescence declarations for variables.

(make-obsolete-variable 'directory-sep-char "do not use it." "21.1")
(make-obsolete-variable 'mode-line-inverse-video "use the appropriate faces instead." "21.1")
(make-obsolete-variable 'unread-command-char
  "use `unread-command-events' instead.  That variable is a list of events to reread, so it now uses nil to mean `no event', instead of -1."
  "before 19.15")
(make-obsolete-variable 'executing-macro 'executing-kbd-macro "before 19.34")
(make-obsolete-variable 'post-command-idle-hook
  "use timers instead, with `run-with-idle-timer'." "before 19.34")
(make-obsolete-variable 'post-command-idle-delay
  "use timers instead, with `run-with-idle-timer'." "before 19.34")

884 885 886

;;;; Alternate names for functions - these are not being phased out.

887 888 889 890 891
(defalias 'string= 'string-equal)
(defalias 'string< 'string-lessp)
(defalias 'move-marker 'set-marker)
(defalias 'rplaca 'setcar)
(defalias 'rplacd 'setcdr)
892
(defalias 'beep 'ding) ;preserve lingual purity
893 894 895 896 897
(defalias 'indent-to-column 'indent-to)
(defalias 'backward-delete-char 'delete-backward-char)
(defalias 'search-forward-regexp (symbol-function 're-search-forward))
(defalias 'search-backward-regexp (symbol-function 're-search-backward))
(defalias 'int-to-string 'number-to-string)
898
(defalias 'store-match-data 'set-match-data)
899
(defalias 'make-variable-frame-localizable 'make-variable-frame-local)
900
;; These are the XEmacs names:
901 902
(defalias 'point-at-eol 'line-end-position)
(defalias 'point-at-bol 'line-beginning-position)
903 904 905

;;; Should this be an obsolete name?  If you decide it should, you get
;;; to go through all the sources and change them.
906
(defalias 'string-to-int 'string-to-number)
David Lawrence's avatar
David Lawrence committed
907

908
;;;; Hook manipulation functions.
David Lawrence's avatar
David Lawrence committed
909

910 911
(defun make-local-hook (hook)
  "Make the hook HOOK local to the current buffer.
912 913
The return value is HOOK.

914 915 916
You never need to call this function now that `add-hook' does it for you
if its LOCAL argument is non-nil.

917 918 919 920 921
When a hook is local, its local and global values
work in concert: running the hook actually runs all the hook
functions listed in *either* the local value *or* the global value
of the hook variable.

922
This function works by making t a member of the buffer-local value,
923 924 925 926 927 928 929 930
which acts as a flag to run the hook functions in the default value as
well.  This works for all normal hooks, but does not work for most
non-normal hooks yet.  We will be changing the callers of non-normal
hooks so that they can handle localness; this has to be done one by
one.

This function does nothing if HOOK is already local in the current
buffer.
931 932 933 934 935 936

Do not use `make-local-variable' to make a hook variable buffer-local."
  (if (local-variable-p hook)
      nil
    (or (boundp hook) (set hook nil))
    (make-local-variable hook)
937 938
    (set hook (list t)))
  hook)
939
(make-obsolete 'make-local-hook "not necessary any more." "21.1")
940 941

(defun add-hook (hook function &optional append local)
942 943 944 945 946 947
  "Add to the value of HOOK the function FUNCTION.
FUNCTION is not added if already present.
FUNCTION is added (if necessary) at the beginning of the hook list
unless the optional argument APPEND is non-nil, in which case
FUNCTION is added at the end.

948 949
The optional fourth argument, LOCAL, if non-nil, says to modify
the hook's buffer-local value rather than its default value.
Richard M. Stallman's avatar
Richard M. Stallman committed
950 951 952
This makes the hook buffer-local if needed, and it makes t a member
of the buffer-local value.  That acts as a flag to run the hook
functions in the default value as well as in the local value.
953

954 955
HOOK should be a symbol, and FUNCTION may be any valid function.  If
HOOK is void, it is first set to nil.  If HOOK's value is a single
956
function, it is changed to a list of functions."
David Lawrence's avatar
David Lawrence committed
957
  (or (boundp hook) (set hook nil))
958
  (or (default-boundp hook) (set-default hook nil))
959 960
  (if local (unless (local-variable-if-set-p hook)
	      (set (make-local-variable hook) (list t)))
961 962
    ;; Detect the case where make-local-variable was used on a hook
    ;; and do what we used to do.
Stefan Monnier's avatar
Stefan Monnier committed
963
    (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
964 965 966 967
      (setq local t)))
  (let ((hook-value (if local (symbol-value hook) (default-value hook))))
    ;; If the hook value is a single function, turn it into a list.
    (when (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
968
      (setq hook-value (list hook-value)))