aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorRichard M. Stallman2005-10-22 15:01:08 +0000
committerRichard M. Stallman2005-10-22 15:01:08 +0000
commitc4f484f2796623300cb64a2ce23d1b90a688e4e6 (patch)
treebc38c5f6e0b0be41dc1bd74046f0a2ff09645cc9
parent5798342c35897393d48f06eae807417fd71e3424 (diff)
downloademacs-c4f484f2796623300cb64a2ce23d1b90a688e4e6.tar.gz
emacs-c4f484f2796623300cb64a2ce23d1b90a688e4e6.zip
Much rearrangement of functions and division into pages. No code changes.
-rw-r--r--lisp/subr.el1124
1 files changed, 580 insertions, 544 deletions
diff --git a/lisp/subr.el b/lisp/subr.el
index 32ee6f987b7..2348c1e3c5d 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -37,7 +37,7 @@ Each element of this list holds the arguments to one call to `defcustom'.")
37 (cons arguments custom-declare-variable-list))) 37 (cons arguments custom-declare-variable-list)))
38 38
39 39
40;;;; Lisp language features. 40;;;; Basic Lisp macros.
41 41
42(defalias 'not 'null) 42(defalias 'not 'null)
43 43
@@ -144,6 +144,59 @@ the return value (nil if RESULT is omitted).
144Treated as a declaration when used at the right place in a 144Treated as a declaration when used at the right place in a
145`defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)" 145`defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)"
146 nil) 146 nil)
147
148;;;; Basic Lisp functions.
149
150(defun ignore (&rest ignore)
151 "Do nothing and return nil.
152This function accepts any number of arguments, but ignores them."
153 (interactive)
154 nil)
155
156(defun error (&rest args)
157 "Signal an error, making error message by passing all args to `format'.
158In Emacs, the convention is that error messages start with a capital
159letter but *do not* end with a period. Please follow this convention
160for the sake of consistency."
161 (while t
162 (signal 'error (list (apply 'format args)))))
163
164;; We put this here instead of in frame.el so that it's defined even on
165;; systems where frame.el isn't loaded.
166(defun frame-configuration-p (object)
167 "Return non-nil if OBJECT seems to be a frame configuration.
168Any list whose car is `frame-configuration' is assumed to be a frame
169configuration."
170 (and (consp object)
171 (eq (car object) 'frame-configuration)))
172
173(defun functionp (object)
174 "Non-nil if OBJECT is any kind of function or a special form.
175Also non-nil if OBJECT is a symbol and its function definition is
176\(recursively) a function or special form. This does not include
177macros."
178 (or (and (symbolp object) (fboundp object)
179 (condition-case nil
180 (setq object (indirect-function object))
181 (error nil))
182 (eq (car-safe object) 'autoload)
183 (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))
184 (subrp object) (byte-code-function-p object)
185 (eq (car-safe object) 'lambda)))
186
187;; This should probably be written in C (i.e., without using `walk-windows').
188(defun get-buffer-window-list (buffer &optional minibuf frame)
189 "Return list of all windows displaying BUFFER, or nil if none.
190BUFFER can be a buffer or a buffer name.
191See `walk-windows' for the meaning of MINIBUF and FRAME."
192 (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows)
193 (walk-windows (function (lambda (window)
194 (if (eq (window-buffer window) buffer)
195 (setq windows (cons window windows)))))
196 minibuf frame)
197 windows))
198
199;;;; List functions.
147 200
148(defsubst caar (x) 201(defsubst caar (x)
149 "Return the car of the car of X." 202 "Return the car of the car of X."
@@ -240,23 +293,6 @@ of course, also replace TO with a slightly larger value
240 next (+ from (* n inc))))) 293 next (+ from (* n inc)))))
241 (nreverse seq)))) 294 (nreverse seq))))
242 295
243(defun remove (elt seq)
244 "Return a copy of SEQ with all occurrences of ELT removed.
245SEQ must be a list, vector, or string. The comparison is done with `equal'."
246 (if (nlistp seq)
247 ;; If SEQ isn't a list, there's no need to copy SEQ because
248 ;; `delete' will return a new object.
249 (delete elt seq)
250 (delete elt (copy-sequence seq))))
251
252(defun remq (elt list)
253 "Return LIST with all occurrences of ELT removed.
254The comparison is done with `eq'. Contrary to `delq', this does not use
255side-effects, and the argument LIST is not modified."
256 (if (memq elt list)
257 (delq elt (copy-sequence list))
258 list))
259
260(defun copy-tree (tree &optional vecp) 296(defun copy-tree (tree &optional vecp)
261 "Make a copy of TREE. 297 "Make a copy of TREE.
262If TREE is a cons cell, this recursively copies both its car and its cdr. 298If TREE is a cons cell, this recursively copies both its car and its cdr.
@@ -277,6 +313,8 @@ argument VECP, this copies vectors as well as conses."
277 (aset tree i (copy-tree (aref tree i) vecp))) 313 (aset tree i (copy-tree (aref tree i) vecp)))
278 tree) 314 tree)
279 tree))) 315 tree)))
316
317;;;; Various list-search functions.
280 318
281(defun assoc-default (key alist &optional test default) 319(defun assoc-default (key alist &optional test default)
282 "Find object KEY in a pseudo-alist ALIST. 320 "Find object KEY in a pseudo-alist ALIST.
@@ -321,15 +359,67 @@ Non-strings in LIST are ignored."
321 (setq list (cdr list))) 359 (setq list (cdr list)))
322 list) 360 list)
323 361
362(defun assq-delete-all (key alist)
363 "Delete from ALIST all elements whose car is `eq' to KEY.
364Return the modified alist.
365Elements of ALIST that are not conses are ignored."
366 (while (and (consp (car alist))
367 (eq (car (car alist)) key))
368 (setq alist (cdr alist)))
369 (let ((tail alist) tail-cdr)
370 (while (setq tail-cdr (cdr tail))
371 (if (and (consp (car tail-cdr))
372 (eq (car (car tail-cdr)) key))
373 (setcdr tail (cdr tail-cdr))
374 (setq tail tail-cdr))))
375 alist)
376
377(defun rassq-delete-all (value alist)
378 "Delete from ALIST all elements whose cdr is `eq' to VALUE.
379Return the modified alist.
380Elements of ALIST that are not conses are ignored."
381 (while (and (consp (car alist))
382 (eq (cdr (car alist)) value))
383 (setq alist (cdr alist)))
384 (let ((tail alist) tail-cdr)
385 (while (setq tail-cdr (cdr tail))
386 (if (and (consp (car tail-cdr))
387 (eq (cdr (car tail-cdr)) value))
388 (setcdr tail (cdr tail-cdr))
389 (setq tail tail-cdr))))
390 alist)
391
392(defun remove (elt seq)
393 "Return a copy of SEQ with all occurrences of ELT removed.
394SEQ must be a list, vector, or string. The comparison is done with `equal'."
395 (if (nlistp seq)
396 ;; If SEQ isn't a list, there's no need to copy SEQ because
397 ;; `delete' will return a new object.
398 (delete elt seq)
399 (delete elt (copy-sequence seq))))
400
401(defun remq (elt list)
402 "Return LIST with all occurrences of ELT removed.
403The comparison is done with `eq'. Contrary to `delq', this does not use
404side-effects, and the argument LIST is not modified."
405 (if (memq elt list)
406 (delq elt (copy-sequence list))
407 list))
324 408
325;;;; Keymap support. 409;;;; Keymap support.
326 410
411(defmacro kbd (keys)
412 "Convert KEYS to the internal Emacs key representation.
413KEYS should be a string constant in the format used for
414saving keyboard macros (see `edmacro-mode')."
415 (read-kbd-macro keys))
416
327(defun undefined () 417(defun undefined ()
328 (interactive) 418 (interactive)
329 (ding)) 419 (ding))
330 420
331;Prevent the \{...} documentation construct 421;; Prevent the \{...} documentation construct
332;from mentioning keys that run this command. 422;; from mentioning keys that run this command.
333(put 'undefined 'suppress-keymap t) 423(put 'undefined 'suppress-keymap t)
334 424
335(defun suppress-keymap (map &optional nodigits) 425(defun suppress-keymap (map &optional nodigits)
@@ -346,76 +436,6 @@ but optional second arg NODIGITS non-nil treats them like other chars."
346 (define-key map (char-to-string loop) 'digit-argument) 436 (define-key map (char-to-string loop) 'digit-argument)
347 (setq loop (1+ loop)))))) 437 (setq loop (1+ loop))))))
348 438
349(defvar key-substitution-in-progress nil
350 "Used internally by `substitute-key-definition'.")
351
352(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
353 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
354In other words, OLDDEF is replaced with NEWDEF where ever it appears.
355Alternatively, if optional fourth argument OLDMAP is specified, we redefine
356in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP.
357
358For most uses, it is simpler and safer to use command remappping like this:
359 \(define-key KEYMAP [remap OLDDEF] NEWDEF)"
360 ;; Don't document PREFIX in the doc string because we don't want to
361 ;; advertise it. It's meant for recursive calls only. Here's its
362 ;; meaning
363
364 ;; If optional argument PREFIX is specified, it should be a key
365 ;; prefix, a string. Redefined bindings will then be bound to the
366 ;; original key, with PREFIX added at the front.
367 (or prefix (setq prefix ""))
368 (let* ((scan (or oldmap keymap))
369 (prefix1 (vconcat prefix [nil]))
370 (key-substitution-in-progress
371 (cons scan key-substitution-in-progress)))
372 ;; Scan OLDMAP, finding each char or event-symbol that
373 ;; has any definition, and act on it with hack-key.
374 (map-keymap
375 (lambda (char defn)
376 (aset prefix1 (length prefix) char)
377 (substitute-key-definition-key defn olddef newdef prefix1 keymap))
378 scan)))
379
380(defun substitute-key-definition-key (defn olddef newdef prefix keymap)
381 (let (inner-def skipped menu-item)
382 ;; Find the actual command name within the binding.
383 (if (eq (car-safe defn) 'menu-item)
384 (setq menu-item defn defn (nth 2 defn))
385 ;; Skip past menu-prompt.
386 (while (stringp (car-safe defn))
387 (push (pop defn) skipped))
388 ;; Skip past cached key-equivalence data for menu items.
389 (if (consp (car-safe defn))
390 (setq defn (cdr defn))))
391 (if (or (eq defn olddef)
392 ;; Compare with equal if definition is a key sequence.
393 ;; That is useful for operating on function-key-map.
394 (and (or (stringp defn) (vectorp defn))
395 (equal defn olddef)))
396 (define-key keymap prefix
397 (if menu-item
398 (let ((copy (copy-sequence menu-item)))
399 (setcar (nthcdr 2 copy) newdef)
400 copy)
401 (nconc (nreverse skipped) newdef)))
402 ;; Look past a symbol that names a keymap.
403 (setq inner-def
404 (and defn
405 (condition-case nil (indirect-function defn) (error defn))))
406 ;; For nested keymaps, we use `inner-def' rather than `defn' so as to
407 ;; avoid autoloading a keymap. This is mostly done to preserve the
408 ;; original non-autoloading behavior of pre-map-keymap times.
409 (if (and (keymapp inner-def)
410 ;; Avoid recursively scanning
411 ;; where KEYMAP does not have a submap.
412 (let ((elt (lookup-key keymap prefix)))
413 (or (null elt) (natnump elt) (keymapp elt)))
414 ;; Avoid recursively rescanning keymap being scanned.
415 (not (memq inner-def key-substitution-in-progress)))
416 ;; If this one isn't being scanned already, scan it now.
417 (substitute-key-definition olddef newdef keymap inner-def prefix)))))
418
419(defun define-key-after (keymap key definition &optional after) 439(defun define-key-after (keymap key definition &optional after)
420 "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. 440 "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
421This is like `define-key' except that the binding for KEY is placed 441This is like `define-key' except that the binding for KEY is placed
@@ -483,12 +503,6 @@ Don't call this function; it is for internal use only."
483 (funcall function (car p) (cdr p)))) 503 (funcall function (car p) (cdr p))))
484 (map-keymap function keymap))) 504 (map-keymap function keymap)))
485 505
486(defmacro kbd (keys)
487 "Convert KEYS to the internal Emacs key representation.
488KEYS should be a string constant in the format used for
489saving keyboard macros (see `edmacro-mode')."
490 (read-kbd-macro keys))
491
492(put 'keyboard-translate-table 'char-table-extra-slots 0) 506(put 'keyboard-translate-table 'char-table-extra-slots 0)
493 507
494(defun keyboard-translate (from to) 508(defun keyboard-translate (from to)
@@ -499,6 +513,128 @@ and then modifies one entry in it."
499 (setq keyboard-translate-table 513 (setq keyboard-translate-table
500 (make-char-table 'keyboard-translate-table nil))) 514 (make-char-table 'keyboard-translate-table nil)))
501 (aset keyboard-translate-table from to)) 515 (aset keyboard-translate-table from to))
516
517;;;; Key binding commands.
518
519(defun global-set-key (key command)
520 "Give KEY a global binding as COMMAND.
521COMMAND is the command definition to use; usually it is
522a symbol naming an interactively-callable function.
523KEY is a key sequence; noninteractively, it is a string or vector
524of characters or event types, and non-ASCII characters with codes
525above 127 (such as ISO Latin-1) can be included if you use a vector.
526
527Note that if KEY has a local binding in the current buffer,
528that local binding will continue to shadow any global binding
529that you make with this function."
530 (interactive "KSet key globally: \nCSet key %s to command: ")
531 (or (vectorp key) (stringp key)
532 (signal 'wrong-type-argument (list 'arrayp key)))
533 (define-key (current-global-map) key command))
534
535(defun local-set-key (key command)
536 "Give KEY a local binding as COMMAND.
537COMMAND is the command definition to use; usually it is
538a symbol naming an interactively-callable function.
539KEY is a key sequence; noninteractively, it is a string or vector
540of characters or event types, and non-ASCII characters with codes
541above 127 (such as ISO Latin-1) can be included if you use a vector.
542
543The binding goes in the current buffer's local map,
544which in most cases is shared with all other buffers in the same major mode."
545 (interactive "KSet key locally: \nCSet key %s locally to command: ")
546 (let ((map (current-local-map)))
547 (or map
548 (use-local-map (setq map (make-sparse-keymap))))
549 (or (vectorp key) (stringp key)
550 (signal 'wrong-type-argument (list 'arrayp key)))
551 (define-key map key command)))
552
553(defun global-unset-key (key)
554 "Remove global binding of KEY.
555KEY is a string or vector representing a sequence of keystrokes."
556 (interactive "kUnset key globally: ")
557 (global-set-key key nil))
558
559(defun local-unset-key (key)
560 "Remove local binding of KEY.
561KEY is a string or vector representing a sequence of keystrokes."
562 (interactive "kUnset key locally: ")
563 (if (current-local-map)
564 (local-set-key key nil))
565 nil)
566
567;;;; substitute-key-definition and its subroutines.
568
569(defvar key-substitution-in-progress nil
570 "Used internally by `substitute-key-definition'.")
571
572(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
573 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
574In other words, OLDDEF is replaced with NEWDEF where ever it appears.
575Alternatively, if optional fourth argument OLDMAP is specified, we redefine
576in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP.
577
578For most uses, it is simpler and safer to use command remappping like this:
579 \(define-key KEYMAP [remap OLDDEF] NEWDEF)"
580 ;; Don't document PREFIX in the doc string because we don't want to
581 ;; advertise it. It's meant for recursive calls only. Here's its
582 ;; meaning
583
584 ;; If optional argument PREFIX is specified, it should be a key
585 ;; prefix, a string. Redefined bindings will then be bound to the
586 ;; original key, with PREFIX added at the front.
587 (or prefix (setq prefix ""))
588 (let* ((scan (or oldmap keymap))
589 (prefix1 (vconcat prefix [nil]))
590 (key-substitution-in-progress
591 (cons scan key-substitution-in-progress)))
592 ;; Scan OLDMAP, finding each char or event-symbol that
593 ;; has any definition, and act on it with hack-key.
594 (map-keymap
595 (lambda (char defn)
596 (aset prefix1 (length prefix) char)
597 (substitute-key-definition-key defn olddef newdef prefix1 keymap))
598 scan)))
599
600(defun substitute-key-definition-key (defn olddef newdef prefix keymap)
601 (let (inner-def skipped menu-item)
602 ;; Find the actual command name within the binding.
603 (if (eq (car-safe defn) 'menu-item)
604 (setq menu-item defn defn (nth 2 defn))
605 ;; Skip past menu-prompt.
606 (while (stringp (car-safe defn))
607 (push (pop defn) skipped))
608 ;; Skip past cached key-equivalence data for menu items.
609 (if (consp (car-safe defn))
610 (setq defn (cdr defn))))
611 (if (or (eq defn olddef)
612 ;; Compare with equal if definition is a key sequence.
613 ;; That is useful for operating on function-key-map.
614 (and (or (stringp defn) (vectorp defn))
615 (equal defn olddef)))
616 (define-key keymap prefix
617 (if menu-item
618 (let ((copy (copy-sequence menu-item)))
619 (setcar (nthcdr 2 copy) newdef)
620 copy)
621 (nconc (nreverse skipped) newdef)))
622 ;; Look past a symbol that names a keymap.
623 (setq inner-def
624 (and defn
625 (condition-case nil (indirect-function defn) (error defn))))
626 ;; For nested keymaps, we use `inner-def' rather than `defn' so as to
627 ;; avoid autoloading a keymap. This is mostly done to preserve the
628 ;; original non-autoloading behavior of pre-map-keymap times.
629 (if (and (keymapp inner-def)
630 ;; Avoid recursively scanning
631 ;; where KEYMAP does not have a submap.
632 (let ((elt (lookup-key keymap prefix)))
633 (or (null elt) (natnump elt) (keymapp elt)))
634 ;; Avoid recursively rescanning keymap being scanned.
635 (not (memq inner-def key-substitution-in-progress)))
636 ;; If this one isn't being scanned already, scan it now.
637 (substitute-key-definition olddef newdef keymap inner-def prefix)))))
502 638
503 639
504;;;; The global keymap tree. 640;;;; The global keymap tree.
@@ -642,6 +778,8 @@ The `posn-' functions access elements of such lists."
642 "Return the multi-click count of EVENT, a click or drag event. 778 "Return the multi-click count of EVENT, a click or drag event.
643The return value is a positive integer." 779The return value is a positive integer."
644 (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1)) 780 (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1))
781
782;;;; Extracting fields of the positions in an event.
645 783
646(defsubst posn-window (position) 784(defsubst posn-window (position)
647 "Return the window in POSITION. 785 "Return the window in POSITION.
@@ -831,6 +969,8 @@ is converted into a string by expressing it in decimal."
831(defalias 'point-at-eol 'line-end-position) 969(defalias 'point-at-eol 'line-end-position)
832(defalias 'point-at-bol 'line-beginning-position) 970(defalias 'point-at-bol 'line-beginning-position)
833 971
972(defalias 'user-original-login-name 'user-login-name)
973
834 974
835;;;; Hook manipulation functions. 975;;;; Hook manipulation functions.
836 976
@@ -991,7 +1131,143 @@ The return value is the new value of LIST-VAR."
991 (if (and oa ob) 1131 (if (and oa ob)
992 (< oa ob) 1132 (< oa ob)
993 oa))))))) 1133 oa)))))))
1134
1135;;;; Mode hooks.
1136
1137(defvar delay-mode-hooks nil
1138 "If non-nil, `run-mode-hooks' should delay running the hooks.")
1139(defvar delayed-mode-hooks nil
1140 "List of delayed mode hooks waiting to be run.")
1141(make-variable-buffer-local 'delayed-mode-hooks)
1142(put 'delay-mode-hooks 'permanent-local t)
1143
1144(defvar after-change-major-mode-hook nil
1145 "Normal hook run at the very end of major mode functions.")
1146
1147(defun run-mode-hooks (&rest hooks)
1148 "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS.
1149Execution is delayed if `delay-mode-hooks' is non-nil.
1150If `delay-mode-hooks' is nil, run `after-change-major-mode-hook'
1151after running the mode hooks.
1152Major mode functions should use this."
1153 (if delay-mode-hooks
1154 ;; Delaying case.
1155 (dolist (hook hooks)
1156 (push hook delayed-mode-hooks))
1157 ;; Normal case, just run the hook as before plus any delayed hooks.
1158 (setq hooks (nconc (nreverse delayed-mode-hooks) hooks))
1159 (setq delayed-mode-hooks nil)
1160 (apply 'run-hooks hooks)
1161 (run-hooks 'after-change-major-mode-hook)))
1162
1163(defmacro delay-mode-hooks (&rest body)
1164 "Execute BODY, but delay any `run-mode-hooks'.
1165These hooks will be executed by the first following call to
1166`run-mode-hooks' that occurs outside any `delayed-mode-hooks' form.
1167Only affects hooks run in the current buffer."
1168 (declare (debug t) (indent 0))
1169 `(progn
1170 (make-local-variable 'delay-mode-hooks)
1171 (let ((delay-mode-hooks t))
1172 ,@body)))
1173
1174;; PUBLIC: find if the current mode derives from another.
994 1175
1176(defun derived-mode-p (&rest modes)
1177 "Non-nil if the current major mode is derived from one of MODES.
1178Uses the `derived-mode-parent' property of the symbol to trace backwards."
1179 (let ((parent major-mode))
1180 (while (and (not (memq parent modes))
1181 (setq parent (get parent 'derived-mode-parent))))
1182 parent))
1183
1184;;;; Minor modes.
1185
1186;; If a minor mode is not defined with define-minor-mode,
1187;; add it here explicitly.
1188;; isearch-mode is deliberately excluded, since you should
1189;; not call it yourself.
1190(defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode
1191 overwrite-mode view-mode
1192 hs-minor-mode)
1193 "List of all minor mode functions.")
1194
1195(defun add-minor-mode (toggle name &optional keymap after toggle-fun)
1196 "Register a new minor mode.
1197
1198This is an XEmacs-compatibility function. Use `define-minor-mode' instead.
1199
1200TOGGLE is a symbol which is the name of a buffer-local variable that
1201is toggled on or off to say whether the minor mode is active or not.
1202
1203NAME specifies what will appear in the mode line when the minor mode
1204is active. NAME should be either a string starting with a space, or a
1205symbol whose value is such a string.
1206
1207Optional KEYMAP is the keymap for the minor mode that will be added
1208to `minor-mode-map-alist'.
1209
1210Optional AFTER specifies that TOGGLE should be added after AFTER
1211in `minor-mode-alist'.
1212
1213Optional TOGGLE-FUN is an interactive function to toggle the mode.
1214It defaults to (and should by convention be) TOGGLE.
1215
1216If TOGGLE has a non-nil `:included' property, an entry for the mode is
1217included in the mode-line minor mode menu.
1218If TOGGLE has a `:menu-tag', that is used for the menu item's label."
1219 (unless (memq toggle minor-mode-list)
1220 (push toggle minor-mode-list))
1221
1222 (unless toggle-fun (setq toggle-fun toggle))
1223 (unless (eq toggle-fun toggle)
1224 (put toggle :minor-mode-function toggle-fun))
1225 ;; Add the name to the minor-mode-alist.
1226 (when name
1227 (let ((existing (assq toggle minor-mode-alist)))
1228 (if existing
1229 (setcdr existing (list name))
1230 (let ((tail minor-mode-alist) found)
1231 (while (and tail (not found))
1232 (if (eq after (caar tail))
1233 (setq found tail)
1234 (setq tail (cdr tail))))
1235 (if found
1236 (let ((rest (cdr found)))
1237 (setcdr found nil)
1238 (nconc found (list (list toggle name)) rest))
1239 (setq minor-mode-alist (cons (list toggle name)
1240 minor-mode-alist)))))))
1241 ;; Add the toggle to the minor-modes menu if requested.
1242 (when (get toggle :included)
1243 (define-key mode-line-mode-menu
1244 (vector toggle)
1245 (list 'menu-item
1246 (concat
1247 (or (get toggle :menu-tag)
1248 (if (stringp name) name (symbol-name toggle)))
1249 (let ((mode-name (if (symbolp name) (symbol-value name))))
1250 (if (and (stringp mode-name) (string-match "[^ ]+" mode-name))
1251 (concat " (" (match-string 0 mode-name) ")"))))
1252 toggle-fun
1253 :button (cons :toggle toggle))))
1254
1255 ;; Add the map to the minor-mode-map-alist.
1256 (when keymap
1257 (let ((existing (assq toggle minor-mode-map-alist)))
1258 (if existing
1259 (setcdr existing keymap)
1260 (let ((tail minor-mode-map-alist) found)
1261 (while (and tail (not found))
1262 (if (eq after (caar tail))
1263 (setq found tail)
1264 (setq tail (cdr tail))))
1265 (if found
1266 (let ((rest (cdr found)))
1267 (setcdr found nil)
1268 (nconc found (list (cons toggle keymap)) rest))
1269 (setq minor-mode-map-alist (cons (cons toggle keymap)
1270 minor-mode-map-alist))))))))
995 1271
996;;; Load history 1272;;; Load history
997 1273
@@ -1080,7 +1356,9 @@ This makes or adds to an entry on `after-load-alist'.
1080FILE should be the name of a library, with no directory name." 1356FILE should be the name of a library, with no directory name."
1081 (eval-after-load file (read))) 1357 (eval-after-load file (read)))
1082 1358
1083;;; open-network-stream is a wrapper around make-network-process. 1359;;;; Process stuff.
1360
1361;; open-network-stream is a wrapper around make-network-process.
1084 1362
1085(when (featurep 'make-network-process) 1363(when (featurep 'make-network-process)
1086 (defun open-network-stream (name buffer host service) 1364 (defun open-network-stream (name buffer host service)
@@ -1380,6 +1658,8 @@ This finishes the change group by reverting all of its changes."
1380 ;; Revert the undo info to what it was when we grabbed the state. 1658 ;; Revert the undo info to what it was when we grabbed the state.
1381 (setq buffer-undo-list elt))))) 1659 (setq buffer-undo-list elt)))))
1382 1660
1661;;;; Display-related functions.
1662
1383;; For compatibility. 1663;; For compatibility.
1384(defalias 'redraw-modeline 'force-mode-line-update) 1664(defalias 'redraw-modeline 'force-mode-line-update)
1385 1665
@@ -1517,34 +1797,122 @@ mode.")
1517This variable is meaningful on MS-DOG and Windows NT. 1797This variable is meaningful on MS-DOG and Windows NT.
1518On those systems, it is automatically local in every buffer. 1798On those systems, it is automatically local in every buffer.
1519On other systems, this variable is normally always nil.") 1799On other systems, this variable is normally always nil.")
1800
1801;;;; Misc. useful functions.
1520 1802
1521;; This should probably be written in C (i.e., without using `walk-windows'). 1803(defun find-tag-default ()
1522(defun get-buffer-window-list (buffer &optional minibuf frame) 1804 "Determine default tag to search for, based on text at point.
1523 "Return list of all windows displaying BUFFER, or nil if none. 1805If there is no plausible default, return nil."
1524BUFFER can be a buffer or a buffer name. 1806 (save-excursion
1525See `walk-windows' for the meaning of MINIBUF and FRAME." 1807 (while (looking-at "\\sw\\|\\s_")
1526 (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows) 1808 (forward-char 1))
1527 (walk-windows (function (lambda (window) 1809 (if (or (re-search-backward "\\sw\\|\\s_"
1528 (if (eq (window-buffer window) buffer) 1810 (save-excursion (beginning-of-line) (point))
1529 (setq windows (cons window windows))))) 1811 t)
1530 minibuf frame) 1812 (re-search-forward "\\(\\sw\\|\\s_\\)+"
1531 windows)) 1813 (save-excursion (end-of-line) (point))
1814 t))
1815 (progn
1816 (goto-char (match-end 0))
1817 (condition-case nil
1818 (buffer-substring-no-properties
1819 (point)
1820 (progn (forward-sexp -1)
1821 (while (looking-at "\\s'")
1822 (forward-char 1))
1823 (point)))
1824 (error nil)))
1825 nil)))
1532 1826
1533(defun ignore (&rest ignore) 1827(defun play-sound (sound)
1534 "Do nothing and return nil. 1828 "SOUND is a list of the form `(sound KEYWORD VALUE...)'.
1535This function accepts any number of arguments, but ignores them." 1829The following keywords are recognized:
1536 (interactive)
1537 nil)
1538 1830
1539(defun error (&rest args) 1831 :file FILE - read sound data from FILE. If FILE isn't an
1540 "Signal an error, making error message by passing all args to `format'. 1832absolute file name, it is searched in `data-directory'.
1541In Emacs, the convention is that error messages start with a capital
1542letter but *do not* end with a period. Please follow this convention
1543for the sake of consistency."
1544 (while t
1545 (signal 'error (list (apply 'format args)))))
1546 1833
1547(defalias 'user-original-login-name 'user-login-name) 1834 :data DATA - read sound data from string DATA.
1835
1836Exactly one of :file or :data must be present.
1837
1838 :volume VOL - set volume to VOL. VOL must an integer in the
1839range 0..100 or a float in the range 0..1.0. If not specified,
1840don't change the volume setting of the sound device.
1841
1842 :device DEVICE - play sound on DEVICE. If not specified,
1843a system-dependent default device name is used."
1844 (if (fboundp 'play-sound-internal)
1845 (play-sound-internal sound)
1846 (error "This Emacs binary lacks sound support")))
1847
1848(defun make-temp-file (prefix &optional dir-flag suffix)
1849 "Create a temporary file.
1850The returned file name (created by appending some random characters at the end
1851of PREFIX, and expanding against `temporary-file-directory' if necessary),
1852is guaranteed to point to a newly created empty file.
1853You can then use `write-region' to write new data into the file.
1854
1855If DIR-FLAG is non-nil, create a new empty directory instead of a file.
1856
1857If SUFFIX is non-nil, add that at the end of the file name."
1858 (let ((umask (default-file-modes))
1859 file)
1860 (unwind-protect
1861 (progn
1862 ;; Create temp files with strict access rights. It's easy to
1863 ;; loosen them later, whereas it's impossible to close the
1864 ;; time-window of loose permissions otherwise.
1865 (set-default-file-modes ?\700)
1866 (while (condition-case ()
1867 (progn
1868 (setq file
1869 (make-temp-name
1870 (expand-file-name prefix temporary-file-directory)))
1871 (if suffix
1872 (setq file (concat file suffix)))
1873 (if dir-flag
1874 (make-directory file)
1875 (write-region "" nil file nil 'silent nil 'excl))
1876 nil)
1877 (file-already-exists t))
1878 ;; the file was somehow created by someone else between
1879 ;; `make-temp-name' and `write-region', let's try again.
1880 nil)
1881 file)
1882 ;; Reset the umask.
1883 (set-default-file-modes umask))))
1884
1885(defun shell-quote-argument (argument)
1886 "Quote an argument for passing as argument to an inferior shell."
1887 (if (eq system-type 'ms-dos)
1888 ;; Quote using double quotes, but escape any existing quotes in
1889 ;; the argument with backslashes.
1890 (let ((result "")
1891 (start 0)
1892 end)
1893 (if (or (null (string-match "[^\"]" argument))
1894 (< (match-end 0) (length argument)))
1895 (while (string-match "[\"]" argument start)
1896 (setq end (match-beginning 0)
1897 result (concat result (substring argument start end)
1898 "\\" (substring argument end (1+ end)))
1899 start (1+ end))))
1900 (concat "\"" result (substring argument start) "\""))
1901 (if (eq system-type 'windows-nt)
1902 (concat "\"" argument "\"")
1903 (if (equal argument "")
1904 "''"
1905 ;; Quote everything except POSIX filename characters.
1906 ;; This should be safe enough even for really weird shells.
1907 (let ((result "") (start 0) end)
1908 (while (string-match "[^-0-9a-zA-Z_./]" argument start)
1909 (setq end (match-beginning 0)
1910 result (concat result (substring argument start end)
1911 "\\" (substring argument end (1+ end)))
1912 start (1+ end)))
1913 (concat result (substring argument start)))))))
1914
1915;;;; Support for yanking and text properties.
1548 1916
1549(defvar yank-excluded-properties) 1917(defvar yank-excluded-properties)
1550 1918
@@ -1650,7 +2018,7 @@ Strip text properties from the inserted text according to
1650 (remove-yank-excluded-properties opoint (point)))) 2018 (remove-yank-excluded-properties opoint (point))))
1651 2019
1652 2020
1653;; Synchronous shell commands. 2021;;;; Synchronous shell commands.
1654 2022
1655(defun start-process-shell-command (name buffer &rest args) 2023(defun start-process-shell-command (name buffer &rest args)
1656 "Start a program in a subprocess. Return the process object for it. 2024 "Start a program in a subprocess. Return the process object for it.
@@ -1706,6 +2074,8 @@ If you quit, the process is killed with SIGINT, or SIGKILL if you quit again."
1706 shell-command-switch 2074 shell-command-switch
1707 (mapconcat 'identity (cons command args) " "))))) 2075 (mapconcat 'identity (cons command args) " ")))))
1708 2076
2077;;;; Lisp macros to do various things temporarily.
2078
1709(defmacro with-current-buffer (buffer &rest body) 2079(defmacro with-current-buffer (buffer &rest body)
1710 "Execute the forms in BODY with BUFFER as the current buffer. 2080 "Execute the forms in BODY with BUFFER as the current buffer.
1711The value returned is the value of the last form in BODY. 2081The value returned is the value of the last form in BODY.
@@ -1858,96 +2228,8 @@ in BODY."
1858 (let ((combine-after-change-calls t)) 2228 (let ((combine-after-change-calls t))
1859 . ,body) 2229 . ,body)
1860 (combine-after-change-execute))) 2230 (combine-after-change-execute)))
1861 2231
1862 2232;;;; Constructing completion tables.
1863(defvar delay-mode-hooks nil
1864 "If non-nil, `run-mode-hooks' should delay running the hooks.")
1865(defvar delayed-mode-hooks nil
1866 "List of delayed mode hooks waiting to be run.")
1867(make-variable-buffer-local 'delayed-mode-hooks)
1868(put 'delay-mode-hooks 'permanent-local t)
1869
1870(defvar after-change-major-mode-hook nil
1871 "Normal hook run at the very end of major mode functions.")
1872
1873(defun run-mode-hooks (&rest hooks)
1874 "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS.
1875Execution is delayed if `delay-mode-hooks' is non-nil.
1876If `delay-mode-hooks' is nil, run `after-change-major-mode-hook'
1877after running the mode hooks.
1878Major mode functions should use this."
1879 (if delay-mode-hooks
1880 ;; Delaying case.
1881 (dolist (hook hooks)
1882 (push hook delayed-mode-hooks))
1883 ;; Normal case, just run the hook as before plus any delayed hooks.
1884 (setq hooks (nconc (nreverse delayed-mode-hooks) hooks))
1885 (setq delayed-mode-hooks nil)
1886 (apply 'run-hooks hooks)
1887 (run-hooks 'after-change-major-mode-hook)))
1888
1889(defmacro delay-mode-hooks (&rest body)
1890 "Execute BODY, but delay any `run-mode-hooks'.
1891These hooks will be executed by the first following call to
1892`run-mode-hooks' that occurs outside any `delayed-mode-hooks' form.
1893Only affects hooks run in the current buffer."
1894 (declare (debug t) (indent 0))
1895 `(progn
1896 (make-local-variable 'delay-mode-hooks)
1897 (let ((delay-mode-hooks t))
1898 ,@body)))
1899
1900;; PUBLIC: find if the current mode derives from another.
1901
1902(defun derived-mode-p (&rest modes)
1903 "Non-nil if the current major mode is derived from one of MODES.
1904Uses the `derived-mode-parent' property of the symbol to trace backwards."
1905 (let ((parent major-mode))
1906 (while (and (not (memq parent modes))
1907 (setq parent (get parent 'derived-mode-parent))))
1908 parent))
1909
1910(defun find-tag-default ()
1911 "Determine default tag to search for, based on text at point.
1912If there is no plausible default, return nil."
1913 (save-excursion
1914 (while (looking-at "\\sw\\|\\s_")
1915 (forward-char 1))
1916 (if (or (re-search-backward "\\sw\\|\\s_"
1917 (save-excursion (beginning-of-line) (point))
1918 t)
1919 (re-search-forward "\\(\\sw\\|\\s_\\)+"
1920 (save-excursion (end-of-line) (point))
1921 t))
1922 (progn
1923 (goto-char (match-end 0))
1924 (condition-case nil
1925 (buffer-substring-no-properties
1926 (point)
1927 (progn (forward-sexp -1)
1928 (while (looking-at "\\s'")
1929 (forward-char 1))
1930 (point)))
1931 (error nil)))
1932 nil)))
1933
1934(defmacro with-syntax-table (table &rest body)
1935 "Evaluate BODY with syntax table of current buffer set to TABLE.
1936The syntax table of the current buffer is saved, BODY is evaluated, and the
1937saved table is restored, even in case of an abnormal exit.
1938Value is what BODY returns."
1939 (declare (debug t))
1940 (let ((old-table (make-symbol "table"))
1941 (old-buffer (make-symbol "buffer")))
1942 `(let ((,old-table (syntax-table))
1943 (,old-buffer (current-buffer)))
1944 (unwind-protect
1945 (progn
1946 (set-syntax-table ,table)
1947 ,@body)
1948 (save-current-buffer
1949 (set-buffer ,old-buffer)
1950 (set-syntax-table ,old-table))))))
1951 2233
1952(defmacro dynamic-completion-table (fun) 2234(defmacro dynamic-completion-table (fun)
1953 "Use function FUN as a dynamic completion table. 2235 "Use function FUN as a dynamic completion table.
@@ -2007,7 +2289,7 @@ A and B should not be costly (or side-effecting) expressions."
2007 (or (test-completion string ,a predicate) 2289 (or (test-completion string ,a predicate)
2008 (test-completion string ,b predicate)))))) 2290 (test-completion string ,b predicate))))))
2009 2291
2010;;; Matching and substitution 2292;;; Matching and match data.
2011 2293
2012(defvar save-match-data-internal) 2294(defvar save-match-data-internal)
2013 2295
@@ -2082,6 +2364,47 @@ of a match for REGEXP."
2082 (looking-at (concat "\\(?:" regexp "\\)\\'"))))) 2364 (looking-at (concat "\\(?:" regexp "\\)\\'")))))
2083 (not (null pos)))) 2365 (not (null pos))))
2084 2366
2367(defun subregexp-context-p (regexp pos &optional start)
2368 "Return non-nil if POS is in a normal subregexp context in REGEXP.
2369A subregexp context is one where a sub-regexp can appear.
2370A non-subregexp context is for example within brackets, or within a
2371repetition bounds operator `\\=\\{...\\}', or right after a `\\'.
2372If START is non-nil, it should be a position in REGEXP, smaller
2373than POS, and known to be in a subregexp context."
2374 ;; Here's one possible implementation, with the great benefit that it
2375 ;; reuses the regexp-matcher's own parser, so it understands all the
2376 ;; details of the syntax. A disadvantage is that it needs to match the
2377 ;; error string.
2378 (condition-case err
2379 (progn
2380 (string-match (substring regexp (or start 0) pos) "")
2381 t)
2382 (invalid-regexp
2383 (not (member (cadr err) '("Unmatched [ or [^"
2384 "Unmatched \\{"
2385 "Trailing backslash")))))
2386 ;; An alternative implementation:
2387 ;; (defconst re-context-re
2388 ;; (let* ((harmless-ch "[^\\[]")
2389 ;; (harmless-esc "\\\\[^{]")
2390 ;; (class-harmless-ch "[^][]")
2391 ;; (class-lb-harmless "[^]:]")
2392 ;; (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?")
2393 ;; (class-lb (concat "\\[\\(" class-lb-harmless
2394 ;; "\\|" class-lb-colon-maybe-charclass "\\)"))
2395 ;; (class
2396 ;; (concat "\\[^?]?"
2397 ;; "\\(" class-harmless-ch
2398 ;; "\\|" class-lb "\\)*"
2399 ;; "\\[?]")) ; special handling for bare [ at end of re
2400 ;; (braces "\\\\{[0-9,]+\\\\}"))
2401 ;; (concat "\\`\\(" harmless-ch "\\|" harmless-esc
2402 ;; "\\|" class "\\|" braces "\\)*\\'"))
2403 ;; "Matches any prefix that corresponds to a normal subregexp context.")
2404 ;; (string-match re-context-re (substring regexp (or start 0) pos))
2405 )
2406
2407;;;; split-string
2085 2408
2086(defconst split-string-default-separators "[ \f\t\n\r\v]+" 2409(defconst split-string-default-separators "[ \f\t\n\r\v]+"
2087 "The default value of separators for `split-string'. 2410 "The default value of separators for `split-string'.
@@ -2142,6 +2465,8 @@ Modifies the match data; use `save-match-data' if necessary."
2142 (cons (substring string start) 2465 (cons (substring string start)
2143 list))) 2466 list)))
2144 (nreverse list))) 2467 (nreverse list)))
2468
2469;;;; Replacement in strings.
2145 2470
2146(defun subst-char-in-string (fromchar tochar string &optional inplace) 2471(defun subst-char-in-string (fromchar tochar string &optional inplace)
2147 "Replace FROMCHAR with TOCHAR in STRING each time it occurs. 2472 "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
@@ -2211,76 +2536,42 @@ and replace a sub-expression, e.g.
2211 ;; Reconstruct a string from the pieces. 2536 ;; Reconstruct a string from the pieces.
2212 (setq matches (cons (substring string start l) matches)) ; leftover 2537 (setq matches (cons (substring string start l) matches)) ; leftover
2213 (apply #'concat (nreverse matches))))) 2538 (apply #'concat (nreverse matches)))))
2539
2540;;;; invisibility specs
2214 2541
2215(defun subregexp-context-p (regexp pos &optional start) 2542(defun add-to-invisibility-spec (element)
2216 "Return non-nil if POS is in a normal subregexp context in REGEXP. 2543 "Add ELEMENT to `buffer-invisibility-spec'.
2217A subregexp context is one where a sub-regexp can appear. 2544See documentation for `buffer-invisibility-spec' for the kind of elements
2218A non-subregexp context is for example within brackets, or within a 2545that can be added."
2219repetition bounds operator `\\=\\{...\\}', or right after a `\\'. 2546 (if (eq buffer-invisibility-spec t)
2220If START is non-nil, it should be a position in REGEXP, smaller 2547 (setq buffer-invisibility-spec (list t)))
2221than POS, and known to be in a subregexp context." 2548 (setq buffer-invisibility-spec
2222 ;; Here's one possible implementation, with the great benefit that it 2549 (cons element buffer-invisibility-spec)))
2223 ;; reuses the regexp-matcher's own parser, so it understands all the 2550
2224 ;; details of the syntax. A disadvantage is that it needs to match the 2551(defun remove-from-invisibility-spec (element)
2225 ;; error string. 2552 "Remove ELEMENT from `buffer-invisibility-spec'."
2226 (condition-case err 2553 (if (consp buffer-invisibility-spec)
2227 (progn 2554 (setq buffer-invisibility-spec (delete element buffer-invisibility-spec))))
2228 (string-match (substring regexp (or start 0) pos) "")
2229 t)
2230 (invalid-regexp
2231 (not (member (cadr err) '("Unmatched [ or [^"
2232 "Unmatched \\{"
2233 "Trailing backslash")))))
2234 ;; An alternative implementation:
2235 ;; (defconst re-context-re
2236 ;; (let* ((harmless-ch "[^\\[]")
2237 ;; (harmless-esc "\\\\[^{]")
2238 ;; (class-harmless-ch "[^][]")
2239 ;; (class-lb-harmless "[^]:]")
2240 ;; (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?")
2241 ;; (class-lb (concat "\\[\\(" class-lb-harmless
2242 ;; "\\|" class-lb-colon-maybe-charclass "\\)"))
2243 ;; (class
2244 ;; (concat "\\[^?]?"
2245 ;; "\\(" class-harmless-ch
2246 ;; "\\|" class-lb "\\)*"
2247 ;; "\\[?]")) ; special handling for bare [ at end of re
2248 ;; (braces "\\\\{[0-9,]+\\\\}"))
2249 ;; (concat "\\`\\(" harmless-ch "\\|" harmless-esc
2250 ;; "\\|" class "\\|" braces "\\)*\\'"))
2251 ;; "Matches any prefix that corresponds to a normal subregexp context.")
2252 ;; (string-match re-context-re (substring regexp (or start 0) pos))
2253 )
2254 2555
2255(defun shell-quote-argument (argument) 2556;;;; Syntax tables.
2256 "Quote an argument for passing as argument to an inferior shell." 2557
2257 (if (eq system-type 'ms-dos) 2558(defmacro with-syntax-table (table &rest body)
2258 ;; Quote using double quotes, but escape any existing quotes in 2559 "Evaluate BODY with syntax table of current buffer set to TABLE.
2259 ;; the argument with backslashes. 2560The syntax table of the current buffer is saved, BODY is evaluated, and the
2260 (let ((result "") 2561saved table is restored, even in case of an abnormal exit.
2261 (start 0) 2562Value is what BODY returns."
2262 end) 2563 (declare (debug t))
2263 (if (or (null (string-match "[^\"]" argument)) 2564 (let ((old-table (make-symbol "table"))
2264 (< (match-end 0) (length argument))) 2565 (old-buffer (make-symbol "buffer")))
2265 (while (string-match "[\"]" argument start) 2566 `(let ((,old-table (syntax-table))
2266 (setq end (match-beginning 0) 2567 (,old-buffer (current-buffer)))
2267 result (concat result (substring argument start end) 2568 (unwind-protect
2268 "\\" (substring argument end (1+ end))) 2569 (progn
2269 start (1+ end)))) 2570 (set-syntax-table ,table)
2270 (concat "\"" result (substring argument start) "\"")) 2571 ,@body)
2271 (if (eq system-type 'windows-nt) 2572 (save-current-buffer
2272 (concat "\"" argument "\"") 2573 (set-buffer ,old-buffer)
2273 (if (equal argument "") 2574 (set-syntax-table ,old-table))))))
2274 "''"
2275 ;; Quote everything except POSIX filename characters.
2276 ;; This should be safe enough even for really weird shells.
2277 (let ((result "") (start 0) end)
2278 (while (string-match "[^-0-9a-zA-Z_./]" argument start)
2279 (setq end (match-beginning 0)
2280 result (concat result (substring argument start end)
2281 "\\" (substring argument end (1+ end)))
2282 start (1+ end)))
2283 (concat result (substring argument start)))))))
2284 2575
2285(defun make-syntax-table (&optional oldtable) 2576(defun make-syntax-table (&optional oldtable)
2286 "Return a new syntax table. 2577 "Return a new syntax table.
@@ -2303,247 +2594,8 @@ If POS is outside the buffer's accessible portion, return nil."
2303 "Return the syntax class part of the syntax descriptor SYNTAX. 2594 "Return the syntax class part of the syntax descriptor SYNTAX.
2304If SYNTAX is nil, return nil." 2595If SYNTAX is nil, return nil."
2305 (and syntax (logand (car syntax) 65535))) 2596 (and syntax (logand (car syntax) 65535)))
2306
2307(defun add-to-invisibility-spec (element)
2308 "Add ELEMENT to `buffer-invisibility-spec'.
2309See documentation for `buffer-invisibility-spec' for the kind of elements
2310that can be added."
2311 (if (eq buffer-invisibility-spec t)
2312 (setq buffer-invisibility-spec (list t)))
2313 (setq buffer-invisibility-spec
2314 (cons element buffer-invisibility-spec)))
2315
2316(defun remove-from-invisibility-spec (element)
2317 "Remove ELEMENT from `buffer-invisibility-spec'."
2318 (if (consp buffer-invisibility-spec)
2319 (setq buffer-invisibility-spec (delete element buffer-invisibility-spec))))
2320
2321(defun global-set-key (key command)
2322 "Give KEY a global binding as COMMAND.
2323COMMAND is the command definition to use; usually it is
2324a symbol naming an interactively-callable function.
2325KEY is a key sequence; noninteractively, it is a string or vector
2326of characters or event types, and non-ASCII characters with codes
2327above 127 (such as ISO Latin-1) can be included if you use a vector.
2328
2329Note that if KEY has a local binding in the current buffer,
2330that local binding will continue to shadow any global binding
2331that you make with this function."
2332 (interactive "KSet key globally: \nCSet key %s to command: ")
2333 (or (vectorp key) (stringp key)
2334 (signal 'wrong-type-argument (list 'arrayp key)))
2335 (define-key (current-global-map) key command))
2336
2337(defun local-set-key (key command)
2338 "Give KEY a local binding as COMMAND.
2339COMMAND is the command definition to use; usually it is
2340a symbol naming an interactively-callable function.
2341KEY is a key sequence; noninteractively, it is a string or vector
2342of characters or event types, and non-ASCII characters with codes
2343above 127 (such as ISO Latin-1) can be included if you use a vector.
2344
2345The binding goes in the current buffer's local map,
2346which in most cases is shared with all other buffers in the same major mode."
2347 (interactive "KSet key locally: \nCSet key %s locally to command: ")
2348 (let ((map (current-local-map)))
2349 (or map
2350 (use-local-map (setq map (make-sparse-keymap))))
2351 (or (vectorp key) (stringp key)
2352 (signal 'wrong-type-argument (list 'arrayp key)))
2353 (define-key map key command)))
2354
2355(defun global-unset-key (key)
2356 "Remove global binding of KEY.
2357KEY is a string or vector representing a sequence of keystrokes."
2358 (interactive "kUnset key globally: ")
2359 (global-set-key key nil))
2360
2361(defun local-unset-key (key)
2362 "Remove local binding of KEY.
2363KEY is a string or vector representing a sequence of keystrokes."
2364 (interactive "kUnset key locally: ")
2365 (if (current-local-map)
2366 (local-set-key key nil))
2367 nil)
2368 2597
2369;; We put this here instead of in frame.el so that it's defined even on 2598;;;; Text clones
2370;; systems where frame.el isn't loaded.
2371(defun frame-configuration-p (object)
2372 "Return non-nil if OBJECT seems to be a frame configuration.
2373Any list whose car is `frame-configuration' is assumed to be a frame
2374configuration."
2375 (and (consp object)
2376 (eq (car object) 'frame-configuration)))
2377
2378(defun functionp (object)
2379 "Non-nil if OBJECT is any kind of function or a special form.
2380Also non-nil if OBJECT is a symbol and its function definition is
2381\(recursively) a function or special form. This does not include
2382macros."
2383 (or (and (symbolp object) (fboundp object)
2384 (condition-case nil
2385 (setq object (indirect-function object))
2386 (error nil))
2387 (eq (car-safe object) 'autoload)
2388 (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))
2389 (subrp object) (byte-code-function-p object)
2390 (eq (car-safe object) 'lambda)))
2391
2392(defun assq-delete-all (key alist)
2393 "Delete from ALIST all elements whose car is `eq' to KEY.
2394Return the modified alist.
2395Elements of ALIST that are not conses are ignored."
2396 (while (and (consp (car alist))
2397 (eq (car (car alist)) key))
2398 (setq alist (cdr alist)))
2399 (let ((tail alist) tail-cdr)
2400 (while (setq tail-cdr (cdr tail))
2401 (if (and (consp (car tail-cdr))
2402 (eq (car (car tail-cdr)) key))
2403 (setcdr tail (cdr tail-cdr))
2404 (setq tail tail-cdr))))
2405 alist)
2406
2407(defun rassq-delete-all (value alist)
2408 "Delete from ALIST all elements whose cdr is `eq' to VALUE.
2409Return the modified alist.
2410Elements of ALIST that are not conses are ignored."
2411 (while (and (consp (car alist))
2412 (eq (cdr (car alist)) value))
2413 (setq alist (cdr alist)))
2414 (let ((tail alist) tail-cdr)
2415 (while (setq tail-cdr (cdr tail))
2416 (if (and (consp (car tail-cdr))
2417 (eq (cdr (car tail-cdr)) value))
2418 (setcdr tail (cdr tail-cdr))
2419 (setq tail tail-cdr))))
2420 alist)
2421
2422(defun make-temp-file (prefix &optional dir-flag suffix)
2423 "Create a temporary file.
2424The returned file name (created by appending some random characters at the end
2425of PREFIX, and expanding against `temporary-file-directory' if necessary),
2426is guaranteed to point to a newly created empty file.
2427You can then use `write-region' to write new data into the file.
2428
2429If DIR-FLAG is non-nil, create a new empty directory instead of a file.
2430
2431If SUFFIX is non-nil, add that at the end of the file name."
2432 (let ((umask (default-file-modes))
2433 file)
2434 (unwind-protect
2435 (progn
2436 ;; Create temp files with strict access rights. It's easy to
2437 ;; loosen them later, whereas it's impossible to close the
2438 ;; time-window of loose permissions otherwise.
2439 (set-default-file-modes ?\700)
2440 (while (condition-case ()
2441 (progn
2442 (setq file
2443 (make-temp-name
2444 (expand-file-name prefix temporary-file-directory)))
2445 (if suffix
2446 (setq file (concat file suffix)))
2447 (if dir-flag
2448 (make-directory file)
2449 (write-region "" nil file nil 'silent nil 'excl))
2450 nil)
2451 (file-already-exists t))
2452 ;; the file was somehow created by someone else between
2453 ;; `make-temp-name' and `write-region', let's try again.
2454 nil)
2455 file)
2456 ;; Reset the umask.
2457 (set-default-file-modes umask))))
2458
2459
2460;; If a minor mode is not defined with define-minor-mode,
2461;; add it here explicitly.
2462;; isearch-mode is deliberately excluded, since you should
2463;; not call it yourself.
2464(defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode
2465 overwrite-mode view-mode
2466 hs-minor-mode)
2467 "List of all minor mode functions.")
2468
2469(defun add-minor-mode (toggle name &optional keymap after toggle-fun)
2470 "Register a new minor mode.
2471
2472This is an XEmacs-compatibility function. Use `define-minor-mode' instead.
2473
2474TOGGLE is a symbol which is the name of a buffer-local variable that
2475is toggled on or off to say whether the minor mode is active or not.
2476
2477NAME specifies what will appear in the mode line when the minor mode
2478is active. NAME should be either a string starting with a space, or a
2479symbol whose value is such a string.
2480
2481Optional KEYMAP is the keymap for the minor mode that will be added
2482to `minor-mode-map-alist'.
2483
2484Optional AFTER specifies that TOGGLE should be added after AFTER
2485in `minor-mode-alist'.
2486
2487Optional TOGGLE-FUN is an interactive function to toggle the mode.
2488It defaults to (and should by convention be) TOGGLE.
2489
2490If TOGGLE has a non-nil `:included' property, an entry for the mode is
2491included in the mode-line minor mode menu.
2492If TOGGLE has a `:menu-tag', that is used for the menu item's label."
2493 (unless (memq toggle minor-mode-list)
2494 (push toggle minor-mode-list))
2495
2496 (unless toggle-fun (setq toggle-fun toggle))
2497 (unless (eq toggle-fun toggle)
2498 (put toggle :minor-mode-function toggle-fun))
2499 ;; Add the name to the minor-mode-alist.
2500 (when name
2501 (let ((existing (assq toggle minor-mode-alist)))
2502 (if existing
2503 (setcdr existing (list name))
2504 (let ((tail minor-mode-alist) found)
2505 (while (and tail (not found))
2506 (if (eq after (caar tail))
2507 (setq found tail)
2508 (setq tail (cdr tail))))
2509 (if found
2510 (let ((rest (cdr found)))
2511 (setcdr found nil)
2512 (nconc found (list (list toggle name)) rest))
2513 (setq minor-mode-alist (cons (list toggle name)
2514 minor-mode-alist)))))))
2515 ;; Add the toggle to the minor-modes menu if requested.
2516 (when (get toggle :included)
2517 (define-key mode-line-mode-menu
2518 (vector toggle)
2519 (list 'menu-item
2520 (concat
2521 (or (get toggle :menu-tag)
2522 (if (stringp name) name (symbol-name toggle)))
2523 (let ((mode-name (if (symbolp name) (symbol-value name))))
2524 (if (and (stringp mode-name) (string-match "[^ ]+" mode-name))
2525 (concat " (" (match-string 0 mode-name) ")"))))
2526 toggle-fun
2527 :button (cons :toggle toggle))))
2528
2529 ;; Add the map to the minor-mode-map-alist.
2530 (when keymap
2531 (let ((existing (assq toggle minor-mode-map-alist)))
2532 (if existing
2533 (setcdr existing keymap)
2534 (let ((tail minor-mode-map-alist) found)
2535 (while (and tail (not found))
2536 (if (eq after (caar tail))
2537 (setq found tail)
2538 (setq tail (cdr tail))))
2539 (if found
2540 (let ((rest (cdr found)))
2541 (setcdr found nil)
2542 (nconc found (list (cons toggle keymap)) rest))
2543 (setq minor-mode-map-alist (cons (cons toggle keymap)
2544 minor-mode-map-alist))))))))
2545
2546;; Clones ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2547 2599
2548(defun text-clone-maintain (ol1 after beg end &optional len) 2600(defun text-clone-maintain (ol1 after beg end &optional len)
2549 "Propagate the changes made under the overlay OL1 to the other clones. 2601 "Propagate the changes made under the overlay OL1 to the other clones.
@@ -2637,27 +2689,11 @@ clone should be incorporated in the clone."
2637 ;;(overlay-put ol2 'face 'underline) 2689 ;;(overlay-put ol2 'face 'underline)
2638 (overlay-put ol2 'evaporate t) 2690 (overlay-put ol2 'evaporate t)
2639 (overlay-put ol2 'text-clones dups))) 2691 (overlay-put ol2 'text-clones dups)))
2692
2693;;;; Mail user agents.
2640 2694
2641(defun play-sound (sound) 2695;; Here we include just enough for other packages to be able
2642 "SOUND is a list of the form `(sound KEYWORD VALUE...)'. 2696;; to define them.
2643The following keywords are recognized:
2644
2645 :file FILE - read sound data from FILE. If FILE isn't an
2646absolute file name, it is searched in `data-directory'.
2647
2648 :data DATA - read sound data from string DATA.
2649
2650Exactly one of :file or :data must be present.
2651
2652 :volume VOL - set volume to VOL. VOL must an integer in the
2653range 0..100 or a float in the range 0..1.0. If not specified,
2654don't change the volume setting of the sound device.
2655
2656 :device DEVICE - play sound on DEVICE. If not specified,
2657a system-dependent default device name is used."
2658 (if (fboundp 'play-sound-internal)
2659 (play-sound-internal sound)
2660 (error "This Emacs binary lacks sound support")))
2661 2697
2662(defun define-mail-user-agent (symbol composefunc sendfunc 2698(defun define-mail-user-agent (symbol composefunc sendfunc
2663 &optional abortfunc hookvar) 2699 &optional abortfunc hookvar)
@@ -2693,8 +2729,8 @@ The properties used on SYMBOL are `composefunc', `sendfunc',
2693 (put symbol 'sendfunc sendfunc) 2729 (put symbol 'sendfunc sendfunc)
2694 (put symbol 'abortfunc (or abortfunc 'kill-buffer)) 2730 (put symbol 'abortfunc (or abortfunc 'kill-buffer))
2695 (put symbol 'hookvar (or hookvar 'mail-send-hook))) 2731 (put symbol 'hookvar (or hookvar 'mail-send-hook)))
2696 2732
2697;; Standardized progress reporting 2733;;;; Progress reporters.
2698 2734
2699;; Progress reporter has the following structure: 2735;; Progress reporter has the following structure:
2700;; 2736;;
@@ -2851,7 +2887,7 @@ convenience wrapper around `make-progress-reporter' and friends.
2851 nil ,@(cdr (cdr spec))))) 2887 nil ,@(cdr (cdr spec)))))
2852 2888
2853 2889
2854;;;; Compare Version Strings 2890;;;; Comparing version strings.
2855 2891
2856(defvar version-separator "." 2892(defvar version-separator "."
2857 "*Specify the string used to separate the version elements. 2893 "*Specify the string used to separate the version elements.