subr.el 130 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

3
;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1999, 2000, 2001, 2002, 2003,
Glenn Morris's avatar
Glenn Morris committed
4
;;   2004, 2005, 2006, 2007 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
;; along with GNU Emacs; see the file COPYING.  If not, write to the
Lute Kamstra's avatar
Lute Kamstra committed
23 24
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, 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
;;;; Basic Lisp macros.
41

Stefan Monnier's avatar
Stefan Monnier committed
42 43
(defalias 'not 'null)

44
(defmacro noreturn (form)
Luc Teirlinck's avatar
Luc Teirlinck committed
45 46
  "Evaluate FORM, expecting it not to return.
If FORM does return, signal an error."
47 48 49 50
  `(prog1 ,form
     (error "Form marked with `noreturn' did return")))

(defmacro 1value (form)
Luc Teirlinck's avatar
Luc Teirlinck committed
51 52 53
  "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."
54 55
  form)

56 57
(defmacro def-edebug-spec (symbol spec)
  "Set the `edebug-form-spec' property of SYMBOL according to SPEC.
58
Both SYMBOL and SPEC are unevaluated.  The SPEC can be 0, t, a symbol
59 60 61
\(naming a function), or a list."
  `(put (quote ,symbol) 'edebug-form-spec (quote ,spec)))

62 63 64 65 66
(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
67
function, i.e., stored as the function value of a symbol, passed to
68
`funcall' or `mapcar', etc.
Richard M. Stallman's avatar
Richard M. Stallman committed
69

70
ARGS should take the same form as an argument list for a `defun'.
Richard M. Stallman's avatar
Richard M. Stallman committed
71 72 73
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.
74 75
INTERACTIVE should be a call to the function `interactive', which see.
It may also be omitted.
76 77 78
BODY should be a list of Lisp expressions.

\(fn ARGS [DOCSTRING] [INTERACTIVE] BODY)"
79 80 81 82
  ;; 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
83
(defmacro push (newelt listname)
Richard M. Stallman's avatar
Richard M. Stallman committed
84
  "Add NEWELT to the list stored in the symbol LISTNAME.
Richard M. Stallman's avatar
Richard M. Stallman committed
85
This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)).
Richard M. Stallman's avatar
Richard M. Stallman committed
86
LISTNAME must be a symbol."
87
  (declare (debug (form sexp)))
Dave Love's avatar
Dave Love committed
88 89
  (list 'setq listname
	(list 'cons newelt listname)))
Richard M. Stallman's avatar
Richard M. Stallman committed
90 91 92 93 94 95

(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."
96
  (declare (debug (sexp)))
97 98 99
  (list 'car
	(list 'prog1 listname
	      (list 'setq listname (list 'cdr listname)))))
Richard M. Stallman's avatar
Richard M. Stallman committed
100

101
(defmacro when (cond &rest body)
Kim F. Storm's avatar
Kim F. Storm committed
102 103 104 105 106
  "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.

\(fn COND BODY ...)"
107
  (declare (indent 1) (debug t))
108
  (list 'if cond (cons 'progn body)))
109

110
(defmacro unless (cond &rest body)
Kim F. Storm's avatar
Kim F. Storm committed
111 112 113 114 115
  "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.

\(fn COND BODY ...)"
116
  (declare (indent 1) (debug t))
117
  (cons 'if (cons cond (cons nil body))))
118

119 120 121
(defvar --dolist-tail-- nil
  "Temporary variable used in `dolist' expansion.")

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

Markus Rost's avatar
Markus Rost committed
127
\(fn (VAR LIST [RESULT]) BODY...)"
128
  (declare (indent 1) (debug ((symbolp form &optional form) body)))
129 130 131 132
  ;; It would be cleaner to create an uninterned symbol,
  ;; but that uses a lot more space when many functions in many files
  ;; use dolist.
  (let ((temp '--dolist-tail--))
133 134 135 136
    `(let ((,temp ,(nth 1 spec))
	   ,(car spec))
       (while ,temp
	 (setq ,(car spec) (car ,temp))
137 138
	 ,@body
	 (setq ,temp (cdr ,temp)))
139 140
       ,@(if (cdr (cdr spec))
	     `((setq ,(car spec) nil) ,@(cdr (cdr spec)))))))
141

142 143 144
(defvar --dotimes-limit-- nil
  "Temporary variable used in `dotimes' expansion.")

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

Markus Rost's avatar
Markus Rost committed
151
\(fn (VAR COUNT [RESULT]) BODY...)"
152
  (declare (indent 1) (debug dolist))
153 154 155 156
  ;; It would be cleaner to create an uninterned symbol,
  ;; but that uses a lot more space when many functions in many files
  ;; use dotimes.
  (let ((temp '--dotimes-limit--)
157 158 159 160 161 162 163 164
	(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)))))
165

Luc Teirlinck's avatar
Luc Teirlinck committed
166 167 168
(defmacro declare (&rest specs)
  "Do not evaluate any arguments and return nil.
Treated as a declaration when used at the right place in a
169
`defmacro' form.  \(See Info anchor `(elisp)Definition of declare'.)"
Luc Teirlinck's avatar
Luc Teirlinck committed
170
  nil)
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211

;;;; Basic Lisp functions.

(defun ignore (&rest ignore)
  "Do nothing and return nil.
This function accepts any number of arguments, but ignores them."
  (interactive)
  nil)

(defun error (&rest args)
  "Signal an error, making error message by passing all args to `format'.
In Emacs, the convention is that error messages start with a capital
letter but *do not* end with a period.  Please follow this convention
for the sake of consistency."
  (while t
    (signal 'error (list (apply 'format args)))))

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

(defun functionp (object)
  "Non-nil if OBJECT is any kind of function or a special form.
Also non-nil if OBJECT is a symbol and its function definition is
\(recursively) a function or special form.  This does not include
macros."
  (or (and (symbolp object) (fboundp object)
	   (condition-case nil
	       (setq object (indirect-function object))
	     (error nil))
	   (eq (car-safe object) 'autoload)
	   (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))
      (subrp object) (byte-code-function-p object)
      (eq (car-safe object) 'lambda)))

;;;; List functions.
Luc Teirlinck's avatar
Luc Teirlinck committed
212

213 214 215 216 217 218 219 220 221 222 223 224 225 226 227
(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
228

229 230 231 232 233
(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."
234
  (if n
235
      (let ((m 0) (p list))
236 237 238
	(while (consp p)
	  (setq m (1+ m) p (cdr p)))
	(if (<= n 0) p
239 240 241 242
	  (if (< n m) (nthcdr (- m n) list) list)))
    (while (consp (cdr list))
      (setq list (cdr list)))
    list))
243

244
(defun butlast (list &optional n)
245
  "Return a copy of LIST with the last N elements removed."
246 247
  (if (and n (<= n 0)) list
    (nbutlast (copy-sequence list) n)))
248

249
(defun nbutlast (list &optional n)
250
  "Modifies LIST to remove the last N elements."
251
  (let ((m (length list)))
252 253 254
    (or n (setq n 1))
    (and (< n m)
	 (progn
255 256
	   (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
	   list))))
257

Luc Teirlinck's avatar
Luc Teirlinck committed
258
(defun delete-dups (list)
259 260 261 262
  "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
263 264
  (let ((tail list))
    (while tail
265 266
      (setcdr tail (delete (car tail) (cdr tail)))
      (setq tail (cdr tail))))
Luc Teirlinck's avatar
Luc Teirlinck committed
267 268
  list)

269
(defun number-sequence (from &optional to inc)
270
  "Return a sequence of numbers from FROM to TO (both inclusive) as a list.
271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292
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))
293 294
      (list from)
    (or inc (setq inc 1))
295 296 297 298 299 300 301 302 303 304 305
    (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)))))
306
      (nreverse seq))))
307

308 309 310
(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.
311
Contrast to `copy-sequence', which copies only along the cdrs.  With second
312 313
argument VECP, this copies vectors as well as conses."
  (if (consp tree)
314 315 316 317 318 319 320
      (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)))
321
	(nconc (nreverse result) tree))
322 323 324
    (if (and vecp (vectorp tree))
	(let ((i (length (setq tree (copy-sequence tree)))))
	  (while (>= (setq i (1- i)) 0)
325 326 327
	    (aset tree i (copy-tree (aref tree i) vecp)))
	  tree)
      tree)))
328 329

;;;; Various list-search functions.
330

331 332 333 334 335 336
(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,
337
or DEFAULT if the element is not a cons.
338 339 340 341 342 343 344 345 346 347

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

349
(make-obsolete 'assoc-ignore-case 'assoc-string)
350 351 352 353
(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."
354
  (assoc-string key alist t))
355

356
(make-obsolete 'assoc-ignore-representation 'assoc-string)
357 358
(defun assoc-ignore-representation (key alist)
  "Like `assoc', but ignores differences in text representation.
Juanma Barranquero's avatar
Juanma Barranquero committed
359
KEY must be a string.
360
Unibyte strings are converted to multibyte for comparison."
361
  (assoc-string key alist nil))
362 363 364 365

(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.
366 367 368 369 370
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)))))
371 372
    (setq list (cdr list)))
  list)
373

374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419
(defun assq-delete-all (key alist)
  "Delete from ALIST all elements whose car is `eq' to KEY.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
  (while (and (consp (car alist))
	      (eq (car (car alist)) key))
    (setq alist (cdr alist)))
  (let ((tail alist) tail-cdr)
    (while (setq tail-cdr (cdr tail))
      (if (and (consp (car tail-cdr))
	       (eq (car (car tail-cdr)) key))
	  (setcdr tail (cdr tail-cdr))
	(setq tail tail-cdr))))
  alist)

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

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

(defun remq (elt list)
  "Return LIST with all occurrences of ELT removed.
The comparison is done with `eq'.  Contrary to `delq', this does not use
side-effects, and the argument LIST is not modified."
  (if (memq elt list)
      (delq elt (copy-sequence list))
    list))
420 421

;;;; Keymap support.
David Lawrence's avatar
David Lawrence committed
422

423 424 425 426 427 428
(defmacro kbd (keys)
  "Convert KEYS to the internal Emacs key representation.
KEYS should be a string constant in the format used for
saving keyboard macros (see `edmacro-mode')."
  (read-kbd-macro keys))

David Lawrence's avatar
David Lawrence committed
429 430 431 432
(defun undefined ()
  (interactive)
  (ding))

433 434
;; Prevent the \{...} documentation construct
;; from mentioning keys that run this command.
David Lawrence's avatar
David Lawrence committed
435 436 437 438 439 440
(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."
441
  (define-key map [remap self-insert-command] 'undefined)
David Lawrence's avatar
David Lawrence committed
442 443 444 445 446 447 448 449 450
  (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))))))

451
(defun define-key-after (keymap key definition &optional after)
452 453 454
  "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
455 456 457
of the map.  Note that AFTER must be an event type (like KEY), NOT a command
\(like DEFINITION).

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

461
Bindings are always added before any inherited map.
462

463 464
The order of bindings in a keymap matters when it is used as a menu."
  (unless after (setq after t))
465 466
  (or (keymapp keymap)
      (signal 'wrong-type-argument (list 'keymapp keymap)))
467 468 469 470 471 472 473
  (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)
474 475
    (while (and (not done) tail)
      ;; Delete any earlier bindings for the same key.
476
      (if (eq (car-safe (car (cdr tail))) key)
477
	  (setcdr tail (cdr (cdr tail))))
478 479
      ;; If we hit an included map, go down that one.
      (if (keymapp (car tail)) (setq tail (car tail)))
480 481
      ;; When we reach AFTER's binding, insert the new binding after.
      ;; If we reach an inherited keymap, insert just before that.
482
      ;; If we reach the end of this keymap, insert at the end.
483 484
      (if (or (and (eq (car-safe (car tail)) after)
		   (not (eq after t)))
485 486
	      (eq (car (cdr tail)) 'keymap)
	      (null (cdr tail)))
487
	  (progn
488 489 490 491 492 493 494
	    ;; 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
495
		(setcdr tail (cons (cons key definition) (cdr tail))))
496
	    (setq inserted t)))
497 498
      (setq tail (cdr tail)))))

499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516
(defun map-keymap-internal (function keymap &optional sort-first)
  "Implement `map-keymap' with sorting.
Don't call this function; it is for internal use only."
  (if sort-first
      (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< a b))))))
	(dolist (p list)
	  (funcall function (car p) (cdr p))))
    (map-keymap function keymap)))
517

518 519
(put 'keyboard-translate-table 'char-table-extra-slots 0)

520 521 522 523
(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."
524 525 526
  (or (char-table-p keyboard-translate-table)
      (setq keyboard-translate-table
	    (make-char-table 'keyboard-translate-table nil)))
527 528
  (aset keyboard-translate-table from to))

529
;;;; Key binding commands.
530

531 532 533 534 535 536 537
(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.
538

539 540 541 542 543 544 545
Note that if KEY has a local binding in the current buffer,
that local binding will continue to shadow any global binding
that you make with this function."
  (interactive "KSet key globally: \nCSet key %s to command: ")
  (or (vectorp key) (stringp key)
      (signal 'wrong-type-argument (list 'arrayp key)))
  (define-key (current-global-map) key command))
546

547 548 549 550 551 552 553
(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.
554

555 556 557 558 559 560 561 562 563
The binding goes in the current buffer's local map,
which in most cases is shared with all other buffers in the same major mode."
  (interactive "KSet key locally: \nCSet key %s locally to command: ")
  (let ((map (current-local-map)))
    (or map
	(use-local-map (setq map (make-sparse-keymap))))
    (or (vectorp key) (stringp key)
	(signal 'wrong-type-argument (list 'arrayp key)))
    (define-key map key command)))
564

565 566 567 568 569
(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))
570

571 572 573 574 575 576 577 578 579 580 581
(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
582
  "Used internally by `substitute-key-definition'.")
583 584 585 586 587 588 589

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

590 591
If you don't specify OLDMAP, you can usually get the same results
in a cleaner way with command remapping, like this:
592 593
  \(define-key KEYMAP [remap OLDDEF] NEWDEF)
\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)"
594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637
  ;; 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
638
	    (or (indirect-function defn t) defn))
639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681
      ;; 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)))))


;;;; The global keymap tree.

;;; 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)
  "Keymap for subcommands of C-x 4.")
(defalias 'ctl-x-4-prefix ctl-x-4-map)
(define-key ctl-x-map "4" 'ctl-x-4-prefix)

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


682 683
;;;; Event manipulation functions.

684 685 686 687
;; 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-\\^@")))
688

689 690 691 692 693 694
(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)
695
			    (logxor c listify-key-sequence-1)
696
			  c)))
697
	    key)))
698

699 700
(defsubst eventp (obj)
  "True if the argument is an event object."
701 702 703 704 705
  (or (and (integerp obj)
	   ;; Filter out integers too large to be events.
	   ;; M is the biggest modifier.
	   (zerop (logand obj (lognot (1- (lsh ?\M-\^@ 1)))))
	   (char-valid-p (event-basic-type obj)))
706 707 708 709 710 711 712
      (and (symbolp obj)
	   (get obj 'event-symbol-elements))
      (and (consp obj)
	   (symbolp (car obj))
	   (get (car obj) 'event-symbol-elements))))

(defun event-modifiers (event)
713
  "Return a list of symbols representing the modifier keys in event EVENT.
714
The elements of the list may include `meta', `control',
715
`shift', `hyper', `super', `alt', `click', `double', `triple', `drag',
716 717 718 719 720
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
in the current Emacs session, then this function can return nil,
even when EVENT actually has modifiers."
721 722 723 724 725
  (let ((type event))
    (if (listp type)
	(setq type (car type)))
    (if (symbolp type)
	(cdr (get type 'event-symbol-elements))
726 727 728 729
      (let ((list nil)
	    (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
					       ?\H-\^@ ?\s-\^@ ?\A-\^@)))))
	(if (not (zerop (logand type ?\M-\^@)))
730
	    (push 'meta list))
731 732
	(if (or (not (zerop (logand type ?\C-\^@)))
		(< char 32))
733
	    (push 'control list))
734 735
	(if (or (not (zerop (logand type ?\S-\^@)))
		(/= char (downcase char)))
736
	    (push 'shift list))
737
	(or (zerop (logand type ?\H-\^@))
738
	    (push 'hyper list))
739
	(or (zerop (logand type ?\s-\^@))
740
	    (push 'super list))
741
	(or (zerop (logand type ?\A-\^@))
742
	    (push 'alt list))
743 744
	list))))

745
(defun event-basic-type (event)
746
  "Return the basic type of the given event (all modifiers removed).
747 748 749 750
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."
751 752
  (if (consp event)
      (setq event (car event)))
753 754
  (if (symbolp event)
      (car (get event 'event-symbol-elements))
755 756 757 758 759 760 761
    (let* ((base (logand event (1- ?\A-\^@)))
	   (uncontrolled (if (< base 32) (logior base 64) base)))
      ;; There are some numbers that are invalid characters and
      ;; cause `downcase' to get an error.
      (condition-case ()
	  (downcase uncontrolled)
	(error uncontrolled)))))
762

763 764
(defsubst mouse-movement-p (object)
  "Return non-nil if OBJECT is a mouse movement event."
765
  (eq (car-safe object) 'mouse-movement))
766 767 768

(defsubst event-start (event)
  "Return the starting position of EVENT.
769
If EVENT is a mouse or key press or a mouse click, this returns the location
770 771 772
of the event.
If EVENT is a drag, this returns the drag's starting position.
The return value is of the form
773 774
   (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
    IMAGE (DX . DY) (WIDTH . HEIGHT))
775
The `posn-' functions access elements of such lists."
776 777
  (if (consp event) (nth 1 event)
    (list (selected-window) (point) '(0 . 0) 0)))
778 779

(defsubst event-end (event)
780 781
  "Return the ending location of EVENT.
EVENT should be a click, drag, or key press event.
782 783
If EVENT is a click event, this function is the same as `event-start'.
The return value is of the form
784 785
   (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
    IMAGE (DX . DY) (WIDTH . HEIGHT))
786
The `posn-' functions access elements of such lists."
787 788
  (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event)
    (list (selected-window) (point) '(0 . 0) 0)))
789

790 791 792
(defsubst event-click-count (event)
  "Return the multi-click count of EVENT, a click or drag event.
The return value is a positive integer."
793
  (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1))
794 795

;;;; Extracting fields of the positions in an event.
796

797 798
(defsubst posn-window (position)
  "Return the window in POSITION.
799
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
  (nth 0 position))

803 804 805
(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
806
and `event-end' functions."
807 808 809 810 811
  (let ((area (if (consp (nth 1 position))
		  (car (nth 1 position))
		(nth 1 position))))
    (and (symbolp area) area)))

812 813
(defsubst posn-point (position)
  "Return the buffer location in POSITION.
814
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
815
and `event-end' functions."
816 817 818 819
  (or (nth 5 position)
      (if (consp (nth 1 position))
	  (car (nth 1 position))
	(nth 1 position))))
820

821 822 823
(defun posn-set-point (position)
  "Move point to POSITION.
Select the corresponding window as well."
Vinicius Jose Latorre's avatar
Vinicius Jose Latorre committed
824 825 826 827 828
  (if (not (windowp (posn-window position)))
      (error "Position not in text area of window"))
  (select-window (posn-window position))
  (if (numberp (posn-point position))
      (goto-char (posn-point position))))
829

830 831
(defsubst posn-x-y (position)
  "Return the x and y coordinates in POSITION.
832
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
833
and `event-end' functions."
834 835
  (nth 2 position))

836
(defun posn-col-row (position)
837 838 839
  "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
840
and height.
841
For a scroll-bar event, the result column is 0, and the row
842 843
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
844
and `event-end' functions."
845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869
  (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
870
and `event-end' functions."
871
  (nth 6 position))
872

873 874
(defsubst posn-timestamp (position)
  "Return the timestamp of POSITION.
875
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
876
and `event-end' functions."
877
  (nth 3 position))
878

879
(defsubst posn-string (position)
880 881
  "Return the string object of POSITION.
Value is a cons (STRING . STRING-POS), or nil if not a string.
882
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
883
and `event-end' functions."
884 885
  (nth 4 position))

886
(defsubst posn-image (position)
887
  "Return the image object of POSITION.
888
Value is a list (image ...), or nil if not an image.
889
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
890
and `event-end' functions."
891 892 893 894
  (nth 7 position))

(defsubst posn-object (position)
  "Return the object (image or string) of POSITION.
895 896
Value is a list (image ...) for an image object, a cons cell
\(STRING . STRING-POS) for a string object, and nil for a buffer position.
897
POSITION should be a list of the form returned by the `event-start'
Luc Teirlinck's avatar
Luc Teirlinck committed
898
and `event-end' functions."
899 900
  (or (posn-image position) (posn-string position)))

Kim F. Storm's avatar
Kim F. Storm committed
901 902 903
(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
904
and `event-end' functions."
905 906 907 908 909
  (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
910
and `event-end' functions."
911
  (nth 9 position))
Kim F. Storm's avatar
Kim F. Storm committed
912

David Lawrence's avatar
David Lawrence committed
913

914 915
;;;; Obsolescent names for functions.

916 917 918 919 920 921
(define-obsolete-function-alias 'window-dot 'window-point "22.1")
(define-obsolete-function-alias 'set-window-dot 'set-window-point "22.1")
(define-obsolete-function-alias 'read-input 'read-string "22.1")
(define-obsolete-function-alias 'show-buffer 'set-window-buffer "22.1")
(define-obsolete-function-alias 'eval-current-buffer 'eval-buffer "22.1")
(define-obsolete-function-alias 'string-to-int 'string-to-number "22.1")
David Lawrence's avatar
David Lawrence committed
922

923
(make-obsolete 'char-bytes "now always returns 1." "20.4")
Richard M. Stallman's avatar
Richard M. Stallman committed
924

925 926 927 928 929 930
(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))))
931
(make-obsolete 'insert-string 'insert "22.1")
932

933
(defun makehash (&optional test) (make-hash-table :test (or test 'eql)))
934
(make-obsolete 'makehash 'make-hash-table "22.1")
935

936 937
;; Some programs still use this as a function.
(defun baud-rate ()
938
  "Return the value of the `baud-rate' variable."
939
  baud-rate)
940
(make-obsolete 'baud-rate "use the `baud-rate' variable instead." "before 19.15")
941

942 943 944 945 946 947
;; These are used by VM and some old programs
(defalias 'focus-frame 'ignore "")
(make-obsolete 'focus-frame "it does nothing." "22.1")
(defalias 'unfocus-frame 'ignore "")
(make-obsolete 'unfocus-frame "it does nothing." "22.1")

948

949
;;;; Obsolescence declarations for variables, and aliases.
950 951

(make-obsolete-variable 'directory-sep-char "do not use it." "21.1")
Vinicius Jose Latorre's avatar
Vinicius Jose Latorre committed
952 953 954 955 956 957 958
(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
959
to reread, so it now uses nil to mean `no event', instead of -1."
Vinicius Jose Latorre's avatar
Vinicius Jose Latorre committed
960
 "before 19.15")
961

962 963
;; Lisp manual only updated in 22.1.
(define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro
Vinicius Jose Latorre's avatar
Vinicius Jose Latorre committed
964
  "before 19.34")
965

966
(defvaralias 'x-lost-selection-hooks 'x-lost-selection-functions)
Vinicius Jose Latorre's avatar
Vinicius Jose Latorre committed
967 968
(make-obsolete-variable 'x-lost-selection-hooks
			'x-lost-selection-functions "22.1")
969
(defvaralias 'x-sent-selection-hooks 'x-sent-selection-functions)
Vinicius Jose Latorre's avatar
Vinicius Jose Latorre committed
970 971
(make-obsolete-variable 'x-sent-selection-hooks
			'x-sent-selection-functions "22.1")
972 973

(defvaralias 'messages-buffer-max-lines 'message-log-max)
974 975 976

;;;; Alternate names for functions - these are not being phased out.

977 978
(defalias 'send-string 'process-send-string)
(defalias 'send-region 'process-send-region)
979 980 981 982 983
(defalias 'string= 'string-equal)
(defalias 'string< 'string-lessp)
(defalias 'move-marker 'set-marker)
(defalias 'rplaca 'setcar)
(defalias 'rplacd 'setcdr)
984
(defalias 'beep 'ding) ;preserve lingual purity
985 986 987 988 989
(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)
990
(defalias 'store-match-data 'set-match-data)
991
(defalias 'make-variable-frame-localizable 'make-variable-frame-local)
992
;; These are the XEmacs names:
993 994
(defalias 'point-at-eol 'line-end-position)
(defalias 'point-at-bol 'line-beginning-position)
995

996 997
(defalias 'user-original-login-name 'user-login-name)

David Lawrence's avatar
David Lawrence committed
998

999
;;;; Hook manipulation functions.
David Lawrence's avatar
David Lawrence committed
1000

1001 1002
(defun make-local-hook (hook)
  "Make the hook HOOK local to the current buffer.
1003 1004
The return value is HOOK.

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

1008 1009 1010 1011 1012
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.

1013
This function works by making t a member of the buffer-local value,
1014 1015 1016 1017 1018 1019 1020 1021
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.
1022 1023 1024 1025 1026 1027

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)
1028 1029
    (set hook (list t)))
  hook)
1030
(make-obsolete 'make-local-hook "not necessary any more." "21.1")
1031 1032

(defun add-hook (hook function &optional append local)
1033 1034 1035 1036 1037 1038
  "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.

1039 1040
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
1041 1042 1043
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.
1044

1045 1046
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
1047
function, it is changed to a list of functions."
David Lawrence's avatar
David Lawrence committed
1048
  (or (boundp hook) (set hook nil))
1049
  (or (default-boundp hook) (set-default hook nil))
1050 1051
  (if local (unless (local-variable-if-set-p hook)
	      (set (make-local-variable hook) (list t)))
1052 1053
    ;; 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
1054
    (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
1055 1056 1057 1058
      (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))
1059
      (setq hook-value (list hook-value)))
1060 1061 1062 1063 1064 1065 1066 1067
    ;; Do the actual addition if necessary
    (unless (member function hook-value)
      (setq hook-value
	    (if append
		(append hook-value (list function))
	      (cons function hook-value))))
    ;; Set the actual variable
    (if local (set hook hook-value) (set-default hook hook-value))))
1068 1069

(defun remove-hook (hook function &optional local)
1070 1071 1072
  "Remove from the value of HOOK the function FUNCTION.
HOOK should be a symbol, and FUNCTION may be any valid function.  If
FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
1073 1074 1075
list of hooks to run in HOOK, then nothing is done.  See `add-hook'.

The optional third argument, LOCAL, if non-nil, says to modify
1076
the hook's buffer-local value rather than its default value."
1077 1078
  (or (boundp hook) (set hook nil))
  (or (default-boundp hook) (set-default hook nil))
1079 1080
  ;; Do nothing if LOCAL is t but this hook has no local binding.
  (unless (and local (not (local-variable-p hook)))
1081 1082
    ;; Detect the case where make-local-variable was used on a hook
    ;; and do what we used to do.
1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101
    (when (and (local-variable-p hook)
	       (not (and (consp (symbol-value hook))
			 (memq t (symbol-value hook)))))
      (setq local t))
    (let ((hook-value (if local (symbol-value hook) (default-value hook))))
      ;; Remove the function, for both the list and the non-list cases.
      (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
	  (if (equal hook-value function) (setq hook-value nil))
	(setq hook-value (delete function (copy-sequence hook-value))))
      ;; If the function is on the global hook, we need to shadow it locally
      ;;(when (and local (member function (default-value hook))
      ;;	       (not (member (cons 'not function) hook-value)))
      ;;  (push (cons 'not function) hook-value))
      ;; Set the actual variable
      (if (not local)
	  (set-default hook hook-value)
	(if (equal hook-value '(t))
	    (kill-local-variable hook)
	  (set hook hook-value))))))
Richard M. Stallman's avatar