subr.el 74.5 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 4
;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001
;;   Free Software Foundation, Inc.
David Lawrence's avatar
David Lawrence committed
5 6 7 8 9

;; 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
10
;; the Free Software Foundation; either version 2, or (at your option)
David Lawrence's avatar
David Lawrence committed
11 12 13 14 15 16 17 18
;; 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
19 20 21
;; 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
22

23 24
;;; Commentary:

Eric S. Raymond's avatar
Eric S. Raymond committed
25
;;; Code:
26 27 28 29
(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
30
;; Use this, rather than defcustom, in subr.el and other files loaded
31 32 33 34
;; before custom.el.
(defun custom-declare-variable-early (&rest arguments)
  (setq custom-declare-variable-list
	(cons arguments custom-declare-variable-list)))
35 36 37

;;;; Lisp language features.

Stefan Monnier's avatar
Stefan Monnier committed
38 39
(defalias 'not 'null)

40 41 42 43 44
(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
45 46 47
function, i.e., stored as the function value of a symbol, passed to
funcall or mapcar, etc.

48
ARGS should take the same form as an argument list for a `defun'.
Richard M. Stallman's avatar
Richard M. Stallman committed
49 50 51
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.
52 53 54 55 56 57 58
INTERACTIVE should be a call to the function `interactive', which see.
It may also be omitted.
BODY should be a list of lisp expressions."
  ;; 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
59
(defmacro push (newelt listname)
Richard M. Stallman's avatar
Richard M. Stallman committed
60
  "Add NEWELT to the list stored in the symbol LISTNAME.
Richard M. Stallman's avatar
Richard M. Stallman committed
61
This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)).
Richard M. Stallman's avatar
Richard M. Stallman committed
62
LISTNAME must be a symbol."
Dave Love's avatar
Dave Love committed
63 64
  (list 'setq listname
	(list 'cons newelt listname)))
Richard M. Stallman's avatar
Richard M. Stallman committed
65 66 67 68 69 70 71 72 73

(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."
  (list 'prog1 (list 'car listname)
	(list 'setq listname (list 'cdr listname))))

74
(defmacro when (cond &rest body)
75
  "If COND yields non-nil, do BODY, else return nil."
76
  (list 'if cond (cons 'progn body)))
77

78
(defmacro unless (cond &rest body)
79
  "If COND yields nil, do BODY, else return nil."
80
  (cons 'if (cons cond (cons nil body))))
81

82 83 84 85
(defmacro dolist (spec &rest body)
  "(dolist (VAR LIST [RESULT]) BODY...): loop over a list.
Evaluate BODY with VAR bound to each car from LIST, in turn.
Then evaluate RESULT to get return value, default nil."
86 87 88 89 90 91 92 93 94 95
  (let ((temp (make-symbol "--dolist-temp--")))
    (list 'let (list (list temp (nth 1 spec)) (car spec))
	  (list 'while temp
		(list 'setq (car spec) (list 'car temp))
		(cons 'progn
		      (append body
			      (list (list 'setq temp (list 'cdr temp))))))
	  (if (cdr (cdr spec))
	      (cons 'progn
		    (cons (list 'setq (car spec) nil) (cdr (cdr spec))))))))
96 97 98 99 100 101

(defmacro dotimes (spec &rest body)
  "(dotimes (VAR COUNT [RESULT]) BODY...): loop a certain number of times.
Evaluate BODY with VAR bound to successive integers running from 0,
inclusive, to COUNT, exclusive.  Then evaluate RESULT to get
the return value (nil if RESULT is omitted)."
102 103 104 105 106 107 108 109 110
  (let ((temp (make-symbol "--dotimes-temp--")))
    (list 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
	   (list 'while (list '< (car spec) temp)
		 (cons 'progn
		       (append body (list (list 'setq (car spec)
						(list '1+ (car spec)))))))
	   (if (cdr (cdr spec))
	       (car (cdr (cdr spec)))
	     nil))))
111

112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
(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
127

128 129 130 131 132 133 134 135 136 137 138
(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)))
139
    (while (consp (cdr x))
140 141
      (setq x (cdr x)))
    x))
142

143 144 145 146 147 148 149 150 151 152 153 154 155 156
(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))))

157
(defun remove (elt seq)
Richard M. Stallman's avatar
Richard M. Stallman committed
158
  "Return a copy of SEQ with all occurrences of ELT removed.
159 160 161 162 163 164 165 166 167 168 169 170 171 172
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 a copy of LIST with all occurences of ELT removed.
The comparison is done with `eq'."
  (if (memq elt list)
      (delq elt (copy-sequence list))
    list))

173 174 175 176 177 178
(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,
179
or DEFAULT if the element is not a cons.
180 181 182 183 184 185 186 187 188 189

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))
190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211

(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."
  (let (element)
    (while (and alist (not element))
      (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil t))
	  (setq element (car alist)))
      (setq alist (cdr alist)))
    element))

(defun assoc-ignore-representation (key alist)
  "Like `assoc', but ignores differences in text representation.
KEY must be a string.  
Unibyte strings are converted to multibyte for comparison."
  (let (element)
    (while (and alist (not element))
      (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil))
	  (setq element (car alist)))
      (setq alist (cdr alist)))
    element))
212 213 214 215 216

(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.
Unibyte strings are converted to multibyte for comparison."
217 218 219
  (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t))))
    (setq list (cdr list)))
  list)
220

221 222

;;;; Keymap support.
David Lawrence's avatar
David Lawrence committed
223 224 225 226 227 228 229 230 231 232 233 234 235

(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."
236
  (substitute-key-definition 'self-insert-command 'undefined map global-map)
David Lawrence's avatar
David Lawrence committed
237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254
  (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)
;  "Return a copy of KEYMAP"  
;  (while (not (keymapp keymap))
;    (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
;  (if (vectorp keymap)
;      (copy-sequence keymap)
;      (copy-alist keymap)))

255 256 257
(defvar key-substitution-in-progress nil
 "Used internally by substitute-key-definition.")

Richard M. Stallman's avatar
Richard M. Stallman committed
258
(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
David Lawrence's avatar
David Lawrence committed
259 260
  "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.
261
Alternatively, if optional fourth argument OLDMAP is specified, we redefine
262
in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP."
263 264 265 266 267 268 269
  ;; 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.
Richard M. Stallman's avatar
Richard M. Stallman committed
270 271 272
  (or prefix (setq prefix ""))
  (let* ((scan (or oldmap keymap))
	 (vec1 (vector nil))
273 274 275
	 (prefix1 (vconcat prefix vec1))
	 (key-substitution-in-progress
	  (cons scan key-substitution-in-progress)))
Richard M. Stallman's avatar
Richard M. Stallman committed
276 277 278 279 280 281 282 283 284 285
    ;; 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)
286
	    (let (inner-def skipped)
Richard M. Stallman's avatar
Richard M. Stallman committed
287 288
	      ;; Skip past menu-prompt.
	      (while (stringp (car-safe defn))
289
		(setq skipped (cons (car defn) skipped))
Richard M. Stallman's avatar
Richard M. Stallman committed
290
		(setq defn (cdr defn)))
291 292 293
	      ;; 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
294
	      (setq inner-def defn)
295
	      ;; Look past a symbol that names a keymap.
Richard M. Stallman's avatar
Richard M. Stallman committed
296 297 298
	      (while (and (symbolp inner-def)
			  (fboundp inner-def))
		(setq inner-def (symbol-function inner-def)))
299 300 301 302 303
	      (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)))
304
		  (define-key keymap prefix1 (nconc (nreverse skipped) newdef))
305
		(if (and (keymapp defn)
306 307
			 ;; Avoid recursively scanning
			 ;; where KEYMAP does not have a submap.
308 309 310
			 (let ((elt (lookup-key keymap prefix1)))
			   (or (null elt)
			       (keymapp elt)))
311
			 ;; Avoid recursively rescanning keymap being scanned.
312 313
			 (not (memq inner-def
				    key-substitution-in-progress)))
314 315
		    ;; If this one isn't being scanned already,
		    ;; scan it now.
Richard M. Stallman's avatar
Richard M. Stallman committed
316 317 318
		    (substitute-key-definition olddef newdef keymap
					       inner-def
					       prefix1)))))
319
	(if (vectorp (car scan))
Richard M. Stallman's avatar
Richard M. Stallman committed
320 321 322 323 324 325 326 327 328
	    (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)
329
		  (let (inner-def skipped)
Richard M. Stallman's avatar
Richard M. Stallman committed
330 331
		    ;; Skip past menu-prompt.
		    (while (stringp (car-safe defn))
332
		      (setq skipped (cons (car defn) skipped))
Richard M. Stallman's avatar
Richard M. Stallman committed
333
		      (setq defn (cdr defn)))
334 335
		    (and (consp defn) (consp (car defn))
			 (setq defn (cdr defn)))
Richard M. Stallman's avatar
Richard M. Stallman committed
336 337 338 339
		    (setq inner-def defn)
		    (while (and (symbolp inner-def)
				(fboundp inner-def))
		      (setq inner-def (symbol-function inner-def)))
340 341 342
		    (if (or (eq defn olddef)
			    (and (or (stringp defn) (vectorp defn))
				 (equal defn olddef)))
343 344
			(define-key keymap prefix1
			  (nconc (nreverse skipped) newdef))
345
		      (if (and (keymapp defn)
346 347 348
			       (let ((elt (lookup-key keymap prefix1)))
				 (or (null elt)
				     (keymapp elt)))
349 350
			       (not (memq inner-def
					  key-substitution-in-progress)))
Richard M. Stallman's avatar
Richard M. Stallman committed
351 352 353
			  (substitute-key-definition olddef newdef keymap
						     inner-def
						     prefix1)))))
354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378
		(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)))
379 380
				   (define-key keymap prefix1
				     (nconc (nreverse skipped) newdef))
381 382 383 384 385 386 387 388 389 390
				 (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
391
      (setq scan (cdr scan)))))
392

393
(defun define-key-after (keymap key definition &optional after)
394 395 396
  "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
397 398 399
of the map.  Note that AFTER must be an event type (like KEY), NOT a command
\(like DEFINITION).

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

403
Bindings are always added before any inherited map.
404

405 406
The order of bindings in a keymap matters when it is used as a menu."
  (unless after (setq after t))
407 408
  (or (keymapp keymap)
      (signal 'wrong-type-argument (list 'keymapp keymap)))
409 410 411 412 413 414 415
  (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)
416 417
    (while (and (not done) tail)
      ;; Delete any earlier bindings for the same key.
418
      (if (eq (car-safe (car (cdr tail))) key)
419
	  (setcdr tail (cdr (cdr tail))))
420 421
      ;; If we hit an included map, go down that one.
      (if (keymapp (car tail)) (setq tail (car tail)))
422 423
      ;; When we reach AFTER's binding, insert the new binding after.
      ;; If we reach an inherited keymap, insert just before that.
424
      ;; If we reach the end of this keymap, insert at the end.
425 426
      (if (or (and (eq (car-safe (car tail)) after)
		   (not (eq after t)))
427 428
	      (eq (car (cdr tail)) 'keymap)
	      (null (cdr tail)))
429
	  (progn
430 431 432 433 434 435 436
	    ;; 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
437
		(setcdr tail (cons (cons key definition) (cdr tail))))
438
	    (setq inserted t)))
439 440
      (setq tail (cdr tail)))))

Richard M. Stallman's avatar
Richard M. Stallman committed
441 442 443 444 445 446
(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))

447 448
(put 'keyboard-translate-table 'char-table-extra-slots 0)

449 450 451 452
(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."
453 454 455
  (or (char-table-p keyboard-translate-table)
      (setq keyboard-translate-table
	    (make-char-table 'keyboard-translate-table nil)))
456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477
  (aset keyboard-translate-table from to))


;;;; 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)
Pavel Janík's avatar
Pavel Janík committed
478
  "Keymap for subcommands of C-x 4.")
479
(defalias 'ctl-x-4-prefix ctl-x-4-map)
480 481 482 483
(define-key ctl-x-map "4" 'ctl-x-4-prefix)

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

487

488 489
;;;; Event manipulation functions.

490 491 492 493
;; 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-\\^@")))
494

495 496 497 498 499 500
(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)
501
			    (logxor c listify-key-sequence-1)
502 503 504
			  c)))
	    (append key nil))))

505 506 507 508 509 510 511 512 513 514 515 516
(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',
517 518
`shift', `hyper', `super', `alt', `click', `double', `triple', `drag',
and `down'."
519 520 521 522 523 524
  (let ((type event))
    (if (listp type)
	(setq type (car type)))
    (if (symbolp type)
	(cdr (get type 'event-symbol-elements))
      (let ((list nil))
525
	(or (zerop (logand type ?\M-\^@))
526
	    (setq list (cons 'meta list)))
527
	(or (and (zerop (logand type ?\C-\^@))
528 529
		 (>= (logand type 127) 32))
	    (setq list (cons 'control list)))
530
	(or (and (zerop (logand type ?\S-\^@))
531 532
		 (= (logand type 255) (downcase (logand type 255))))
	    (setq list (cons 'shift list)))
533
	(or (zerop (logand type ?\H-\^@))
534
	    (setq list (cons 'hyper list)))
535
	(or (zerop (logand type ?\s-\^@))
536
	    (setq list (cons 'super list)))
537
	(or (zerop (logand type ?\A-\^@))
538 539 540
	    (setq list (cons 'alt list)))
	list))))

541 542
(defun event-basic-type (event)
  "Returns the basic type of the given event (all modifiers removed).
Dave Love's avatar
Dave Love committed
543
The value is a printing character (not upper case) or a symbol."
544 545
  (if (consp event)
      (setq event (car event)))
546 547 548 549 550
  (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)))))

551 552 553 554 555 556 557 558 559 560 561
(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.
If EVENT is a mouse press or a mouse click, this returns the location
of the event.
If EVENT is a drag, this returns the drag's starting position.
The return value is of the form
562
   (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
563 564 565 566 567 568 569
The `posn-' functions access elements of such lists."
  (nth 1 event))

(defsubst event-end (event)
  "Return the ending location of EVENT.  EVENT should be a click or drag event.
If EVENT is a click event, this function is the same as `event-start'.
The return value is of the form
570
   (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
571
The `posn-' functions access elements of such lists."
572
  (nth (if (consp (nth 2 event)) 2 1) event))
573

574 575 576 577 578
(defsubst event-click-count (event)
  "Return the multi-click count of EVENT, a click or drag event.
The return value is a positive integer."
  (if (integerp (nth 2 event)) (nth 2 event) 1))

579 580 581
(defsubst posn-window (position)
  "Return the window in POSITION.
POSITION should be a list of the form
582
   (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
583 584 585 586 587 588
as returned by the `event-start' and `event-end' functions."
  (nth 0 position))

(defsubst posn-point (position)
  "Return the buffer location in POSITION.
POSITION should be a list of the form
589
   (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
590
as returned by the `event-start' and `event-end' functions."
591 592 593
  (if (consp (nth 1 position))
      (car (nth 1 position))
    (nth 1 position)))
594

595 596
(defsubst posn-x-y (position)
  "Return the x and y coordinates in POSITION.
597
POSITION should be a list of the form
598
   (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
599 600 601
as returned by the `event-start' and `event-end' functions."
  (nth 2 position))

602
(defun posn-col-row (position)
603
  "Return the column and row in POSITION, measured in characters.
604 605
POSITION should be a list of the form
   (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
606 607 608 609 610
as returned by the `event-start' and `event-end' functions.
For a scroll-bar event, the result column is 0, and the row
corresponds to the vertical position of the click in the scroll bar."
  (let ((pair   (nth 2 position))
	(window (posn-window position)))
611 612 613
    (if (eq (if (consp (nth 1 position))
		(car (nth 1 position))
	      (nth 1 position))
614 615
	    'vertical-scroll-bar)
	(cons 0 (scroll-bar-scale pair (1- (window-height window))))
616 617 618
      (if (eq (if (consp (nth 1 position))
		  (car (nth 1 position))
		(nth 1 position))
619 620
	      'horizontal-scroll-bar)
	  (cons (scroll-bar-scale pair (window-width window)) 0)
621 622 623
	(let* ((frame (if (framep window) window (window-frame window)))
	       (x (/ (car pair) (frame-char-width frame)))
	       (y (/ (cdr pair) (frame-char-height frame))))
624
	  (cons x y))))))
625

626 627 628
(defsubst posn-timestamp (position)
  "Return the timestamp of POSITION.
POSITION should be a list of the form
629
   (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
630
as returned by the `event-start' and `event-end' functions."
631
  (nth 3 position))
632

David Lawrence's avatar
David Lawrence committed
633

634 635
;;;; Obsolescent names for functions.

636 637 638 639 640 641 642 643 644 645 646 647 648
(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)
649
(defalias 'define-function 'defalias)
David Lawrence's avatar
David Lawrence committed
650

651
(defalias 'sref 'aref)
652 653
(make-obsolete 'sref 'aref "20.4")
(make-obsolete 'char-bytes "Now this function always returns 1" "20.4")
Richard M. Stallman's avatar
Richard M. Stallman committed
654

655 656 657 658 659 660 661 662 663
(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))))

(make-obsolete 'insert-string 'insert "21.3")

664 665
;; Some programs still use this as a function.
(defun baud-rate ()
Richard M. Stallman's avatar
Richard M. Stallman committed
666 667
  "Obsolete function returning the value of the `baud-rate' variable.
Please convert your programs to use the variable `baud-rate' directly."
668 669
  baud-rate)

670 671
(defalias 'focus-frame 'ignore)
(defalias 'unfocus-frame 'ignore)
672 673 674

;;;; Alternate names for functions - these are not being phased out.

675 676 677 678 679
(defalias 'string= 'string-equal)
(defalias 'string< 'string-lessp)
(defalias 'move-marker 'set-marker)
(defalias 'rplaca 'setcar)
(defalias 'rplacd 'setcdr)
680
(defalias 'beep 'ding) ;preserve lingual purity
681 682 683 684 685
(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)
686
(defalias 'store-match-data 'set-match-data)
687
;; These are the XEmacs names:
688 689
(defalias 'point-at-eol 'line-end-position)
(defalias 'point-at-bol 'line-beginning-position)
690 691 692

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

697 698
(defun make-local-hook (hook)
  "Make the hook HOOK local to the current buffer.
699 700
The return value is HOOK.

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

704 705 706 707 708
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.

709
This function works by making t a member of the buffer-local value,
710 711 712 713 714 715 716 717
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.
718 719 720 721 722 723

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)
724 725
    (set hook (list t)))
  hook)
726
(make-obsolete 'make-local-hook "Not necessary any more." "21.1")
727 728

(defun add-hook (hook function &optional append local)
729 730 731 732 733 734
  "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.

735 736
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
737 738 739
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.
740

741 742
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
743
function, it is changed to a list of functions."
David Lawrence's avatar
David Lawrence committed
744
  (or (boundp hook) (set hook nil))
745
  (or (default-boundp hook) (set-default hook nil))
746 747
  (if local (unless (local-variable-if-set-p hook)
	      (set (make-local-variable hook) (list t)))
748 749 750 751 752 753 754
    ;; Detect the case where make-local-variable was used on a hook
    ;; and do what we used to do.
    (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
      (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))
755
      (setq hook-value (list hook-value)))
756 757 758 759 760 761 762 763
    ;; 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))))
764 765

(defun remove-hook (hook function &optional local)
766 767 768
  "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
769 770 771 772
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
the hook's buffer-local value rather than its default value.
773
This makes the hook buffer-local if needed."
774 775
  (or (boundp hook) (set hook nil))
  (or (default-boundp hook) (set-default hook nil))
776 777
  (if local (unless (local-variable-if-set-p hook)
	      (set (make-local-variable hook) (list t)))
778 779 780 781 782
    ;; Detect the case where make-local-variable was used on a hook
    ;; and do what we used to do.
    (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
      (setq local t)))
  (let ((hook-value (if local (symbol-value hook) (default-value hook))))
783 784 785 786
    ;; 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))))
787 788 789 790 791 792
    ;; 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 local (set hook hook-value) (set-default hook hook-value))))
793

794
(defun add-to-list (list-var element &optional append)
Richard M. Stallman's avatar
Richard M. Stallman committed
795
  "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
Karl Heuer's avatar
Karl Heuer committed
796
The test for presence of ELEMENT is done with `equal'.
797 798 799
If ELEMENT is added, it is added at the beginning of the list,
unless the optional argument APPEND is non-nil, in which case
ELEMENT is added at the end.
Richard M. Stallman's avatar
Richard M. Stallman committed
800

Pavel Janík's avatar
Pavel Janík committed
801 802
The return value is the new value of LIST-VAR.

Richard M. Stallman's avatar
Richard M. Stallman committed
803 804 805 806 807
If you want to use `add-to-list' on a variable that is not defined
until a certain package is loaded, you should put the call to `add-to-list'
into a hook function that will be run only after loading the package.
`eval-after-load' provides one way to do this.  In some cases
other hooks, such as major mode hooks, can do the job."
808 809
  (if (member element (symbol-value list-var))
      (symbol-value list-var)
810 811 812 813
    (set list-var
	 (if append
	     (append (symbol-value list-var) (list element))
	   (cons element (symbol-value list-var))))))
814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852


;;; Load history

(defvar symbol-file-load-history-loaded nil
  "Non-nil means we have loaded the file `fns-VERSION.el' in `exec-directory'.
That file records the part of `load-history' for preloaded files,
which is cleared out before dumping to make Emacs smaller.")

(defun load-symbol-file-load-history ()
  "Load the file `fns-VERSION.el' in `exec-directory' if not already done.
That file records the part of `load-history' for preloaded files,
which is cleared out before dumping to make Emacs smaller."
  (unless symbol-file-load-history-loaded
    (load (expand-file-name
	   ;; fns-XX.YY.ZZ.el does not work on DOS filesystem.
	   (if (eq system-type 'ms-dos)
	       "fns.el"
	     (format "fns-%s.el" emacs-version))
	   exec-directory)
	  ;; The file name fns-%s.el already has a .el extension.
	  nil nil t)
    (setq symbol-file-load-history-loaded t)))

(defun symbol-file (function)
  "Return the input source from which FUNCTION was loaded.
The value is normally a string that was passed to `load':
either an absolute file name, or a library name
\(with no directory name and no `.el' or `.elc' at the end).
It can also be nil, if the definition is not associated with any file."
  (load-symbol-file-load-history)
  (let ((files load-history)
	file functions)
    (while files
      (if (memq function (cdr (car files)))
	  (setq file (car (car files)) files nil))
      (setq files (cdr files)))
    file))

David Lawrence's avatar
David Lawrence committed
853

854 855 856 857 858
;;;; Specifying things to do after certain files are loaded.

(defun eval-after-load (file form)
  "Arrange that, if FILE is ever loaded, FORM will be run at that time.
This makes or adds to an entry on `after-load-alist'.
859
If FILE is already loaded, evaluate FORM right now.
860
It does nothing if FORM is already on the list for FILE.
Dave Love's avatar
Dave Love committed
861 862
FILE must match exactly.  Normally FILE is the name of a library,
with no directory or extension specified, since that is how `load'
863 864 865
is normally called.
FILE can also be a feature (i.e. a symbol), in which case FORM is
evaluated whenever that feature is `provide'd."
866
  (let ((elt (assoc file after-load-alist)))
867 868 869 870 871 872 873 874 875 876 877 878 879
    ;; Make sure there is an element for FILE.
    (unless elt (setq elt (list file)) (push elt after-load-alist))
    ;; Add FORM to the element if it isn't there.
    (unless (member form (cdr elt))
      (nconc elt (list form))
      ;; If the file has been loaded already, run FORM right away.
      (if (if (symbolp file)
	      (featurep file)
	    ;; Make sure `load-history' contains the files dumped with
	    ;; Emacs for the case that FILE is one of them.
	    (load-symbol-file-load-history)
	    (assoc file load-history))
	  (eval form))))
880 881 882 883 884 885 886 887 888 889 890
  form)

(defun eval-next-after-load (file)
  "Read the following input sexp, and run it whenever FILE is loaded.
This makes or adds to an entry on `after-load-alist'.
FILE should be the name of a library, with no directory name."
  (eval-after-load file (read)))


;;;; Input and display facilities.

891
(defvar read-quoted-char-radix 8
892
  "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
893 894 895 896 897
Legitimate radix values are 8, 10 and 16.")

(custom-declare-variable-early
 'read-quoted-char-radix 8 
 "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
898 899 900 901
Legitimate radix values are 8, 10 and 16."
  :type '(choice (const 8) (const 10) (const 16))
  :group 'editing-basics)

902
(defun read-quoted-char (&optional prompt)
903 904 905
  "Like `read-char', but do not allow quitting.
Also, if the first character read is an octal digit,
we read any number of octal digits and return the
906
specified character code.  Any nondigit terminates the sequence.
907
If the terminator is RET, it is discarded;
908 909
any other terminator is used itself as input.

910 911 912
The optional argument PROMPT specifies a string to use to prompt the user.
The variable `read-quoted-char-radix' controls which radix to use
for numeric input."
913 914 915
  (let ((message-log-max nil) done (first t) (code 0) char)
    (while (not done)
      (let ((inhibit-quit first)
916 917 918 919
	    ;; Don't let C-h get the help message--only help function keys.
	    (help-char nil)
	    (help-form
	     "Type the special character you want to use,
920
or the octal character code.
921
RET terminates the character code and is discarded;
922
any other non-digit terminates the character code and is then used as input."))
923
	(setq char (read-event (and prompt (format "%s-" prompt)) t))
924
	(if inhibit-quit (setq quit-flag nil)))
925 926 927
      ;; Translate TAB key into control-I ASCII character, and so on.
      (and char
	   (let ((translated (lookup-key function-key-map (vector char))))
928
	     (if (arrayp translated)
929
		 (setq char (aref translated 0)))))
930
      (cond ((null char))
931 932 933
	    ((not (integerp char))
	     (setq unread-command-events (list char)
		   done t))
934 935 936 937
	    ((/= (logand char ?\M-\^@) 0)
	     ;; Turn a meta-character into a character with the 0200 bit set.
	     (setq code (logior (logand char (lognot ?\M-\^@)) 128)
		   done t))
938 939 940 941 942
	    ((and (<= ?0 char) (< char (+ ?0 (min 10 read-quoted-char-radix))))
	     (setq code (+ (* code read-quoted-char-radix) (- char ?0)))
	     (and prompt (setq prompt (message "%s %c" prompt char))))
	    ((and (<= ?a (downcase char))
		  (< (downcase char) (+ ?a -10 (min 26 read-quoted-char-radix))))
943 944
	     (setq code (+ (* code read-quoted-char-radix)
			   (+ 10 (- (downcase char) ?a))))
945
	     (and prompt (setq prompt (message "%s %c" prompt char))))
946
	    ((and (not first) (eq char ?\C-m))
947 948 949 950 951 952 953
	     (setq done t))
	    ((not first)
	     (setq unread-command-events (list char)
		   done t))
	    (t (setq code char
		     done t)))
      (setq first nil))
954
    code))
955

956 957
(defun read-passwd (prompt &optional confirm default)
  "Read a password, prompting with PROMPT.  Echo `.' for each character typed.
958
End with RET, LFD, or ESC.  DEL or C-h rubs out.  C-u kills line.
959 960 961 962 963 964 965 966
Optional argument CONFIRM, if non-nil, then read it twice to make sure.
Optional DEFAULT is a default password to use instead of empty input."
  (if confirm
      (let (success)
	(while (not success)
	  (let ((first (read-passwd prompt nil default))
		(second (read-passwd "Confirm password: " nil default)))
	    (if (equal first second)
967 968 969 970 971
		(progn
		  (and (arrayp second) (fillarray second ?\0))
		  (setq success first))
	      (and (arrayp first) (fillarray first ?\0))
	      (and (arrayp second) (fillarray second ?\0))
972 973 974 975 976 977 978 979 980 981
	      (message "Password not repeated accurately; please start over")
	      (sit-for 1))))
	success)
    (let ((pass nil)
	  (c 0)
	  (echo-keystrokes 0)
	  (cursor-in-echo-area t))
      (while (progn (message "%s%s"
			     prompt
			     (make-string (length pass) ?.))
982
		    (setq c (read-char-exclusive nil t))
983
		    (and (/= c ?\r) (/= c ?\n) (/= c ?\e)))
984
	(clear-this-command-keys)
985
	(if (= c ?\C-u)
986 987 988
	    (progn
	      (and (arrayp pass) (fillarray pass ?\0))
	      (setq pass ""))
989
	  (if (and (/= c ?\b) (/= c ?\177))
990 991 992 993 994 995
	      (let* ((new-char (char-to-string c))
		     (new-pass (concat pass new-char)))
		(and (arrayp pass) (fillarray pass ?\0))
		(fillarray new-char ?\0)
		(setq c ?\0)
		(setq pass new-pass))
996
	    (if (> (length pass) 0)
997 998 999
		(let ((new-pass (substring pass 0 -1)))
		  (and (arrayp pass) (fillarray pass ?\0))
		  (setq pass new-pass))))))
1000 1001
      (message nil)
      (or pass default ""))))
1002

1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097