|
658
|
1 ;;; subr.el --- basic lisp subroutines for Emacs
|
|
787
|
2
|
|
14169
|
3 ;; Copyright (C) 1985, 1986, 1992, 1994, 1995 Free Software Foundation, Inc.
|
|
114
|
4
|
|
|
5 ;; This file is part of GNU Emacs.
|
|
|
6
|
|
|
7 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
8 ;; it under the terms of the GNU General Public License as published by
|
|
707
|
9 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
114
|
10 ;; any later version.
|
|
|
11
|
|
|
12 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
15 ;; GNU General Public License for more details.
|
|
|
16
|
|
|
17 ;; You should have received a copy of the GNU General Public License
|
|
14169
|
18 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
20 ;; Boston, MA 02111-1307, USA.
|
|
114
|
21
|
|
787
|
22 ;;; Code:
|
|
18880
|
23 (defvar custom-declare-variable-list nil
|
|
|
24 "Record `defcustom' calls made before `custom.el' is loaded to handle them.
|
|
|
25 Each element of this list holds the arguments to one call to `defcustom'.")
|
|
114
|
26
|
|
19662
|
27 ;; Use this, rather than defcustom, in subr.el and other files loaded
|
|
18880
|
28 ;; before custom.el.
|
|
|
29 (defun custom-declare-variable-early (&rest arguments)
|
|
|
30 (setq custom-declare-variable-list
|
|
|
31 (cons arguments custom-declare-variable-list)))
|
|
2504
|
32
|
|
|
33 ;;;; Lisp language features.
|
|
|
34
|
|
|
35 (defmacro lambda (&rest cdr)
|
|
|
36 "Return a lambda expression.
|
|
|
37 A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
|
|
|
38 self-quoting; the result of evaluating the lambda expression is the
|
|
|
39 expression itself. The lambda expression may then be treated as a
|
|
10178
|
40 function, i.e., stored as the function value of a symbol, passed to
|
|
|
41 funcall or mapcar, etc.
|
|
|
42
|
|
2504
|
43 ARGS should take the same form as an argument list for a `defun'.
|
|
12395
|
44 DOCSTRING is an optional documentation string.
|
|
|
45 If present, it should describe how to call the function.
|
|
|
46 But documentation strings are usually not useful in nameless functions.
|
|
2504
|
47 INTERACTIVE should be a call to the function `interactive', which see.
|
|
|
48 It may also be omitted.
|
|
|
49 BODY should be a list of lisp expressions."
|
|
|
50 ;; Note that this definition should not use backquotes; subr.el should not
|
|
|
51 ;; depend on backquote.el.
|
|
|
52 (list 'function (cons 'lambda cdr)))
|
|
|
53
|
|
25437
|
54 (defmacro push (newelt listname)
|
|
25580
|
55 "Add NEWELT to the list stored in the symbol LISTNAME.
|
|
25437
|
56 This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)).
|
|
25436
|
57 LISTNAME must be a symbol."
|
|
25469
|
58 (list 'setq listname
|
|
|
59 (list 'cons newelt listname)))
|
|
25436
|
60
|
|
|
61 (defmacro pop (listname)
|
|
|
62 "Return the first element of LISTNAME's value, and remove it from the list.
|
|
|
63 LISTNAME must be a symbol whose value is a list.
|
|
|
64 If the value is nil, `pop' returns nil but does not actually
|
|
|
65 change the list."
|
|
|
66 (list 'prog1 (list 'car listname)
|
|
|
67 (list 'setq listname (list 'cdr listname))))
|
|
|
68
|
|
16845
|
69 (defmacro when (cond &rest body)
|
|
|
70 "(when COND BODY...): if COND yields non-nil, do BODY, else return nil."
|
|
|
71 (list 'if cond (cons 'progn body)))
|
|
17158
|
72 (put 'when 'lisp-indent-function 1)
|
|
|
73 (put 'when 'edebug-form-spec '(&rest form))
|
|
2504
|
74
|
|
16845
|
75 (defmacro unless (cond &rest body)
|
|
|
76 "(unless COND BODY...): if COND yields nil, do BODY, else return nil."
|
|
|
77 (cons 'if (cons cond (cons nil body))))
|
|
17158
|
78 (put 'unless 'lisp-indent-function 1)
|
|
|
79 (put 'unless 'edebug-form-spec '(&rest form))
|
19491
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
80
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
81 (defsubst caar (x)
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
82 "Return the car of the car of X."
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
83 (car (car x)))
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
84
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
85 (defsubst cadr (x)
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
86 "Return the car of the cdr of X."
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
87 (car (cdr x)))
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
88
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
89 (defsubst cdar (x)
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
90 "Return the cdr of the car of X."
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
91 (cdr (car x)))
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
92
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
93 (defsubst cddr (x)
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
94 "Return the cdr of the cdr of X."
|
f5fd22f3462c
(caar, cadr, cdar, cddr): Definitions moved here and changed into defsubsts.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
95 (cdr (cdr x)))
|
|
19492
|
96
|
|
19584
|
97 (defun last (x &optional n)
|
|
|
98 "Return the last link of the list X. Its car is the last element.
|
|
|
99 If X is nil, return nil.
|
|
|
100 If N is non-nil, return the Nth-to-last link of X.
|
|
|
101 If N is bigger than the length of X, return X."
|
|
|
102 (if n
|
|
|
103 (let ((m 0) (p x))
|
|
|
104 (while (consp p)
|
|
|
105 (setq m (1+ m) p (cdr p)))
|
|
|
106 (if (<= n 0) p
|
|
|
107 (if (< n m) (nthcdr (- m n) x) x)))
|
|
|
108 (while (cdr x)
|
|
|
109 (setq x (cdr x)))
|
|
|
110 x))
|
|
22860
|
111
|
|
22959
|
112 (defun assoc-default (key alist &optional test default)
|
|
|
113 "Find object KEY in a pseudo-alist ALIST.
|
|
|
114 ALIST is a list of conses or objects. Each element (or the element's car,
|
|
|
115 if it is a cons) is compared with KEY by evaluating (TEST (car elt) KEY).
|
|
|
116 If that is non-nil, the element matches;
|
|
|
117 then `assoc-default' returns the element's cdr, if it is a cons,
|
|
22860
|
118 or DEFAULT if the element is not a cons.
|
|
22959
|
119
|
|
|
120 If no element matches, the value is nil.
|
|
|
121 If TEST is omitted or nil, `equal' is used."
|
|
|
122 (let (found (tail alist) value)
|
|
|
123 (while (and tail (not found))
|
|
|
124 (let ((elt (car tail)))
|
|
|
125 (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
|
|
|
126 (setq found t value (if (consp elt) (cdr elt) default))))
|
|
|
127 (setq tail (cdr tail)))
|
|
|
128 value))
|
25295
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
129
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
130 (defun assoc-ignore-case (key alist)
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
131 "Like `assoc', but ignores differences in case and text representation.
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
132 KEY must be a string. Upper-case and lower-case letters are treated as equal.
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
133 Unibyte strings are converted to multibyte for comparison."
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
134 (let (element)
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
135 (while (and alist (not element))
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
136 (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil t))
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
137 (setq element (car alist)))
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
138 (setq alist (cdr alist)))
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
139 element))
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
140
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
141 (defun assoc-ignore-representation (key alist)
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
142 "Like `assoc', but ignores differences in text representation.
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
143 KEY must be a string.
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
144 Unibyte strings are converted to multibyte for comparison."
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
145 (let (element)
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
146 (while (and alist (not element))
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
147 (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil))
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
148 (setq element (car alist)))
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
149 (setq alist (cdr alist)))
|
737e82c21934
(assoc-ignore-case, assoc-ignore-representation): Moved here from simple.el.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
150 element))
|
|
2504
|
151
|
|
|
152 ;;;; Keymap support.
|
|
114
|
153
|
|
|
154 (defun undefined ()
|
|
|
155 (interactive)
|
|
|
156 (ding))
|
|
|
157
|
|
|
158 ;Prevent the \{...} documentation construct
|
|
|
159 ;from mentioning keys that run this command.
|
|
|
160 (put 'undefined 'suppress-keymap t)
|
|
|
161
|
|
|
162 (defun suppress-keymap (map &optional nodigits)
|
|
|
163 "Make MAP override all normally self-inserting keys to be undefined.
|
|
|
164 Normally, as an exception, digits and minus-sign are set to make prefix args,
|
|
|
165 but optional second arg NODIGITS non-nil treats them like other chars."
|
|
4767
|
166 (substitute-key-definition 'self-insert-command 'undefined map global-map)
|
|
114
|
167 (or nodigits
|
|
|
168 (let (loop)
|
|
|
169 (define-key map "-" 'negative-argument)
|
|
|
170 ;; Make plain numbers do numeric args.
|
|
|
171 (setq loop ?0)
|
|
|
172 (while (<= loop ?9)
|
|
|
173 (define-key map (char-to-string loop) 'digit-argument)
|
|
|
174 (setq loop (1+ loop))))))
|
|
|
175
|
|
|
176 ;Moved to keymap.c
|
|
|
177 ;(defun copy-keymap (keymap)
|
|
|
178 ; "Return a copy of KEYMAP"
|
|
|
179 ; (while (not (keymapp keymap))
|
|
|
180 ; (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
|
|
|
181 ; (if (vectorp keymap)
|
|
|
182 ; (copy-sequence keymap)
|
|
|
183 ; (copy-alist keymap)))
|
|
|
184
|
|
6167
|
185 (defvar key-substitution-in-progress nil
|
|
|
186 "Used internally by substitute-key-definition.")
|
|
|
187
|
|
1176
|
188 (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
|
|
114
|
189 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
|
|
|
190 In other words, OLDDEF is replaced with NEWDEF where ever it appears.
|
|
1176
|
191 If optional fourth argument OLDMAP is specified, we redefine
|
|
|
192 in KEYMAP as NEWDEF those chars which are defined as OLDDEF in OLDMAP."
|
|
|
193 (or prefix (setq prefix ""))
|
|
|
194 (let* ((scan (or oldmap keymap))
|
|
|
195 (vec1 (vector nil))
|
|
6167
|
196 (prefix1 (vconcat prefix vec1))
|
|
|
197 (key-substitution-in-progress
|
|
|
198 (cons scan key-substitution-in-progress)))
|
|
1176
|
199 ;; Scan OLDMAP, finding each char or event-symbol that
|
|
|
200 ;; has any definition, and act on it with hack-key.
|
|
|
201 (while (consp scan)
|
|
|
202 (if (consp (car scan))
|
|
|
203 (let ((char (car (car scan)))
|
|
|
204 (defn (cdr (car scan))))
|
|
|
205 ;; The inside of this let duplicates exactly
|
|
|
206 ;; the inside of the following let that handles array elements.
|
|
|
207 (aset vec1 0 char)
|
|
|
208 (aset prefix1 (length prefix) char)
|
|
6005
|
209 (let (inner-def skipped)
|
|
1176
|
210 ;; Skip past menu-prompt.
|
|
|
211 (while (stringp (car-safe defn))
|
|
6005
|
212 (setq skipped (cons (car defn) skipped))
|
|
1176
|
213 (setq defn (cdr defn)))
|
|
7615
|
214 ;; Skip past cached key-equivalence data for menu items.
|
|
|
215 (and (consp defn) (consp (car defn))
|
|
|
216 (setq defn (cdr defn)))
|
|
1176
|
217 (setq inner-def defn)
|
|
7615
|
218 ;; Look past a symbol that names a keymap.
|
|
1176
|
219 (while (and (symbolp inner-def)
|
|
|
220 (fboundp inner-def))
|
|
|
221 (setq inner-def (symbol-function inner-def)))
|
|
17215
|
222 (if (or (eq defn olddef)
|
|
|
223 ;; Compare with equal if definition is a key sequence.
|
|
|
224 ;; That is useful for operating on function-key-map.
|
|
|
225 (and (or (stringp defn) (vectorp defn))
|
|
|
226 (equal defn olddef)))
|
|
6005
|
227 (define-key keymap prefix1 (nconc (nreverse skipped) newdef))
|
|
6167
|
228 (if (and (keymapp defn)
|
|
9986
|
229 ;; Avoid recursively scanning
|
|
|
230 ;; where KEYMAP does not have a submap.
|
|
13039
|
231 (let ((elt (lookup-key keymap prefix1)))
|
|
|
232 (or (null elt)
|
|
|
233 (keymapp elt)))
|
|
9986
|
234 ;; Avoid recursively rescanning keymap being scanned.
|
|
6167
|
235 (not (memq inner-def
|
|
|
236 key-substitution-in-progress)))
|
|
7615
|
237 ;; If this one isn't being scanned already,
|
|
|
238 ;; scan it now.
|
|
1176
|
239 (substitute-key-definition olddef newdef keymap
|
|
|
240 inner-def
|
|
|
241 prefix1)))))
|
|
18044
|
242 (if (vectorp (car scan))
|
|
1176
|
243 (let* ((array (car scan))
|
|
|
244 (len (length array))
|
|
|
245 (i 0))
|
|
|
246 (while (< i len)
|
|
|
247 (let ((char i) (defn (aref array i)))
|
|
|
248 ;; The inside of this let duplicates exactly
|
|
|
249 ;; the inside of the previous let.
|
|
|
250 (aset vec1 0 char)
|
|
|
251 (aset prefix1 (length prefix) char)
|
|
6005
|
252 (let (inner-def skipped)
|
|
1176
|
253 ;; Skip past menu-prompt.
|
|
|
254 (while (stringp (car-safe defn))
|
|
6005
|
255 (setq skipped (cons (car defn) skipped))
|
|
1176
|
256 (setq defn (cdr defn)))
|
|
7615
|
257 (and (consp defn) (consp (car defn))
|
|
|
258 (setq defn (cdr defn)))
|
|
1176
|
259 (setq inner-def defn)
|
|
|
260 (while (and (symbolp inner-def)
|
|
|
261 (fboundp inner-def))
|
|
|
262 (setq inner-def (symbol-function inner-def)))
|
|
17215
|
263 (if (or (eq defn olddef)
|
|
|
264 (and (or (stringp defn) (vectorp defn))
|
|
|
265 (equal defn olddef)))
|
|
6005
|
266 (define-key keymap prefix1
|
|
|
267 (nconc (nreverse skipped) newdef))
|
|
6167
|
268 (if (and (keymapp defn)
|
|
13039
|
269 (let ((elt (lookup-key keymap prefix1)))
|
|
|
270 (or (null elt)
|
|
|
271 (keymapp elt)))
|
|
6167
|
272 (not (memq inner-def
|
|
|
273 key-substitution-in-progress)))
|
|
1176
|
274 (substitute-key-definition olddef newdef keymap
|
|
|
275 inner-def
|
|
|
276 prefix1)))))
|
|
17922
|
277 (setq i (1+ i))))
|
|
|
278 (if (char-table-p (car scan))
|
|
|
279 (map-char-table
|
|
|
280 (function (lambda (char defn)
|
|
|
281 (let ()
|
|
|
282 ;; The inside of this let duplicates exactly
|
|
|
283 ;; the inside of the previous let,
|
|
|
284 ;; except that it uses set-char-table-range
|
|
|
285 ;; instead of define-key.
|
|
|
286 (aset vec1 0 char)
|
|
|
287 (aset prefix1 (length prefix) char)
|
|
|
288 (let (inner-def skipped)
|
|
|
289 ;; Skip past menu-prompt.
|
|
|
290 (while (stringp (car-safe defn))
|
|
|
291 (setq skipped (cons (car defn) skipped))
|
|
|
292 (setq defn (cdr defn)))
|
|
|
293 (and (consp defn) (consp (car defn))
|
|
|
294 (setq defn (cdr defn)))
|
|
|
295 (setq inner-def defn)
|
|
|
296 (while (and (symbolp inner-def)
|
|
|
297 (fboundp inner-def))
|
|
|
298 (setq inner-def (symbol-function inner-def)))
|
|
|
299 (if (or (eq defn olddef)
|
|
|
300 (and (or (stringp defn) (vectorp defn))
|
|
|
301 (equal defn olddef)))
|
|
17943
|
302 (define-key keymap prefix1
|
|
|
303 (nconc (nreverse skipped) newdef))
|
|
17922
|
304 (if (and (keymapp defn)
|
|
|
305 (let ((elt (lookup-key keymap prefix1)))
|
|
|
306 (or (null elt)
|
|
|
307 (keymapp elt)))
|
|
|
308 (not (memq inner-def
|
|
|
309 key-substitution-in-progress)))
|
|
|
310 (substitute-key-definition olddef newdef keymap
|
|
|
311 inner-def
|
|
|
312 prefix1)))))))
|
|
|
313 (car scan)))))
|
|
1176
|
314 (setq scan (cdr scan)))))
|
|
2504
|
315
|
|
3902
|
316 (defun define-key-after (keymap key definition after)
|
|
3901
|
317 "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
|
|
|
318 This is like `define-key' except that the binding for KEY is placed
|
|
|
319 just after the binding for the event AFTER, instead of at the beginning
|
16556
3a1df67c6677
(define-key-after): If AFTER is t, always put new binding at the end.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
320 of the map. Note that AFTER must be an event type (like KEY), NOT a command
|
3a1df67c6677
(define-key-after): If AFTER is t, always put new binding at the end.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
321 \(like DEFINITION).
|
3a1df67c6677
(define-key-after): If AFTER is t, always put new binding at the end.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
322
|
3a1df67c6677
(define-key-after): If AFTER is t, always put new binding at the end.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
323 If AFTER is t, the new binding goes at the end of the keymap.
|
3a1df67c6677
(define-key-after): If AFTER is t, always put new binding at the end.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
324
|
|
6725
|
325 KEY must contain just one event type--that is to say, it must be
|
16556
3a1df67c6677
(define-key-after): If AFTER is t, always put new binding at the end.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
326 a string or vector of length 1.
|
3a1df67c6677
(define-key-after): If AFTER is t, always put new binding at the end.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
327
|
3a1df67c6677
(define-key-after): If AFTER is t, always put new binding at the end.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
328 The order of bindings in a keymap matters when it is used as a menu."
|
3a1df67c6677
(define-key-after): If AFTER is t, always put new binding at the end.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
329
|
|
3901
|
330 (or (keymapp keymap)
|
|
|
331 (signal 'wrong-type-argument (list 'keymapp keymap)))
|
|
4188
|
332 (if (> (length key) 1)
|
|
4070
|
333 (error "multi-event key specified in `define-key-after'"))
|
|
3927
|
334 (let ((tail keymap) done inserted
|
|
3901
|
335 (first (aref key 0)))
|
|
|
336 (while (and (not done) tail)
|
|
|
337 ;; Delete any earlier bindings for the same key.
|
|
|
338 (if (eq (car-safe (car (cdr tail))) first)
|
|
|
339 (setcdr tail (cdr (cdr tail))))
|
|
|
340 ;; When we reach AFTER's binding, insert the new binding after.
|
|
|
341 ;; If we reach an inherited keymap, insert just before that.
|
|
3927
|
342 ;; If we reach the end of this keymap, insert at the end.
|
16556
3a1df67c6677
(define-key-after): If AFTER is t, always put new binding at the end.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
343 (if (or (and (eq (car-safe (car tail)) after)
|
3a1df67c6677
(define-key-after): If AFTER is t, always put new binding at the end.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
344 (not (eq after t)))
|
|
3927
|
345 (eq (car (cdr tail)) 'keymap)
|
|
|
346 (null (cdr tail)))
|
|
3901
|
347 (progn
|
|
3927
|
348 ;; Stop the scan only if we find a parent keymap.
|
|
|
349 ;; Keep going past the inserted element
|
|
|
350 ;; so we can delete any duplications that come later.
|
|
|
351 (if (eq (car (cdr tail)) 'keymap)
|
|
|
352 (setq done t))
|
|
|
353 ;; Don't insert more than once.
|
|
|
354 (or inserted
|
|
|
355 (setcdr tail (cons (cons (aref key 0) definition) (cdr tail))))
|
|
|
356 (setq inserted t)))
|
|
3901
|
357 (setq tail (cdr tail)))))
|
|
|
358
|
|
17437
|
359 (defmacro kbd (keys)
|
|
|
360 "Convert KEYS to the internal Emacs key representation.
|
|
|
361 KEYS should be a string constant in the format used for
|
|
|
362 saving keyboard macros (see `insert-kbd-macro')."
|
|
|
363 (read-kbd-macro keys))
|
|
|
364
|
|
15894
|
365 (put 'keyboard-translate-table 'char-table-extra-slots 0)
|
|
|
366
|
|
2504
|
367 (defun keyboard-translate (from to)
|
|
|
368 "Translate character FROM to TO at a low level.
|
|
|
369 This function creates a `keyboard-translate-table' if necessary
|
|
|
370 and then modifies one entry in it."
|
|
15894
|
371 (or (char-table-p keyboard-translate-table)
|
|
|
372 (setq keyboard-translate-table
|
|
|
373 (make-char-table 'keyboard-translate-table nil)))
|
|
2504
|
374 (aset keyboard-translate-table from to))
|
|
|
375
|
|
2071
|
376
|
|
2504
|
377 ;;;; The global keymap tree.
|
|
|
378
|
|
|
379 ;;; global-map, esc-map, and ctl-x-map have their values set up in
|
|
|
380 ;;; keymap.c; we just give them docstrings here.
|
|
|
381
|
|
|
382 (defvar global-map nil
|
|
|
383 "Default global keymap mapping Emacs keyboard input into commands.
|
|
|
384 The value is a keymap which is usually (but not necessarily) Emacs's
|
|
|
385 global map.")
|
|
|
386
|
|
|
387 (defvar esc-map nil
|
|
|
388 "Default keymap for ESC (meta) commands.
|
|
|
389 The normal global definition of the character ESC indirects to this keymap.")
|
|
|
390
|
|
|
391 (defvar ctl-x-map nil
|
|
|
392 "Default keymap for C-x commands.
|
|
|
393 The normal global definition of the character C-x indirects to this keymap.")
|
|
|
394
|
|
|
395 (defvar ctl-x-4-map (make-sparse-keymap)
|
|
|
396 "Keymap for subcommands of C-x 4")
|
|
2569
|
397 (defalias 'ctl-x-4-prefix ctl-x-4-map)
|
|
2504
|
398 (define-key ctl-x-map "4" 'ctl-x-4-prefix)
|
|
|
399
|
|
|
400 (defvar ctl-x-5-map (make-sparse-keymap)
|
|
|
401 "Keymap for frame commands.")
|
|
2569
|
402 (defalias 'ctl-x-5-prefix ctl-x-5-map)
|
|
2504
|
403 (define-key ctl-x-map "5" 'ctl-x-5-prefix)
|
|
|
404
|
|
|
405
|
|
|
406 ;;;; Event manipulation functions.
|
|
|
407
|
10693
0875851842f0
(listify-key-sequence-1, event-modifiers): Don't presume internal bit layout
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
408 ;; The call to `read' is to ensure that the value is computed at load time
|
0875851842f0
(listify-key-sequence-1, event-modifiers): Don't presume internal bit layout
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
409 ;; and not compiled into the .elc file. The value is negative on most
|
0875851842f0
(listify-key-sequence-1, event-modifiers): Don't presume internal bit layout
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
410 ;; machines, but not on all!
|
0875851842f0
(listify-key-sequence-1, event-modifiers): Don't presume internal bit layout
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
411 (defconst listify-key-sequence-1 (logior 128 (read "?\\M-\\^@")))
|
|
3153
|
412
|
|
2021
|
413 (defun listify-key-sequence (key)
|
|
|
414 "Convert a key sequence to a list of events."
|
|
|
415 (if (vectorp key)
|
|
|
416 (append key nil)
|
|
|
417 (mapcar (function (lambda (c)
|
|
|
418 (if (> c 127)
|
|
3153
|
419 (logxor c listify-key-sequence-1)
|
|
2021
|
420 c)))
|
|
|
421 (append key nil))))
|
|
|
422
|
|
2040
|
423 (defsubst eventp (obj)
|
|
|
424 "True if the argument is an event object."
|
|
|
425 (or (integerp obj)
|
|
|
426 (and (symbolp obj)
|
|
|
427 (get obj 'event-symbol-elements))
|
|
|
428 (and (consp obj)
|
|
|
429 (symbolp (car obj))
|
|
|
430 (get (car obj) 'event-symbol-elements))))
|
|
|
431
|
|
|
432 (defun event-modifiers (event)
|
|
|
433 "Returns a list of symbols representing the modifier keys in event EVENT.
|
|
|
434 The elements of the list may include `meta', `control',
|
|
4414
|
435 `shift', `hyper', `super', `alt', `click', `double', `triple', `drag',
|
|
|
436 and `down'."
|
|
2040
|
437 (let ((type event))
|
|
|
438 (if (listp type)
|
|
|
439 (setq type (car type)))
|
|
|
440 (if (symbolp type)
|
|
|
441 (cdr (get type 'event-symbol-elements))
|
|
|
442 (let ((list nil))
|
10693
0875851842f0
(listify-key-sequence-1, event-modifiers): Don't presume internal bit layout
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
443 (or (zerop (logand type ?\M-\^@))
|
|
2040
|
444 (setq list (cons 'meta list)))
|
10693
0875851842f0
(listify-key-sequence-1, event-modifiers): Don't presume internal bit layout
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
445 (or (and (zerop (logand type ?\C-\^@))
|
|
2040
|
446 (>= (logand type 127) 32))
|
|
|
447 (setq list (cons 'control list)))
|
10693
0875851842f0
(listify-key-sequence-1, event-modifiers): Don't presume internal bit layout
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
448 (or (and (zerop (logand type ?\S-\^@))
|
|
2040
|
449 (= (logand type 255) (downcase (logand type 255))))
|
|
|
450 (setq list (cons 'shift list)))
|
10693
0875851842f0
(listify-key-sequence-1, event-modifiers): Don't presume internal bit layout
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
451 (or (zerop (logand type ?\H-\^@))
|
|
2040
|
452 (setq list (cons 'hyper list)))
|
10693
0875851842f0
(listify-key-sequence-1, event-modifiers): Don't presume internal bit layout
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
453 (or (zerop (logand type ?\s-\^@))
|
|
2040
|
454 (setq list (cons 'super list)))
|
10693
0875851842f0
(listify-key-sequence-1, event-modifiers): Don't presume internal bit layout
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
455 (or (zerop (logand type ?\A-\^@))
|
|
2040
|
456 (setq list (cons 'alt list)))
|
|
|
457 list))))
|
|
|
458
|
|
2063
|
459 (defun event-basic-type (event)
|
|
|
460 "Returns the basic type of the given event (all modifiers removed).
|
|
|
461 The value is an ASCII printing character (not upper case) or a symbol."
|
|
3784
|
462 (if (consp event)
|
|
|
463 (setq event (car event)))
|
|
2063
|
464 (if (symbolp event)
|
|
|
465 (car (get event 'event-symbol-elements))
|
|
|
466 (let ((base (logand event (1- (lsh 1 18)))))
|
|
|
467 (downcase (if (< base 32) (logior base 64) base)))))
|
|
|
468
|
|
2071
|
469 (defsubst mouse-movement-p (object)
|
|
|
470 "Return non-nil if OBJECT is a mouse movement event."
|
|
|
471 (and (consp object)
|
|
|
472 (eq (car object) 'mouse-movement)))
|
|
|
473
|
|
|
474 (defsubst event-start (event)
|
|
|
475 "Return the starting position of EVENT.
|
|
|
476 If EVENT is a mouse press or a mouse click, this returns the location
|
|
|
477 of the event.
|
|
|
478 If EVENT is a drag, this returns the drag's starting position.
|
|
|
479 The return value is of the form
|
|
6039
|
480 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
|
|
2071
|
481 The `posn-' functions access elements of such lists."
|
|
|
482 (nth 1 event))
|
|
|
483
|
|
|
484 (defsubst event-end (event)
|
|
|
485 "Return the ending location of EVENT. EVENT should be a click or drag event.
|
|
|
486 If EVENT is a click event, this function is the same as `event-start'.
|
|
|
487 The return value is of the form
|
|
6039
|
488 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
|
|
2071
|
489 The `posn-' functions access elements of such lists."
|
|
3860
|
490 (nth (if (consp (nth 2 event)) 2 1) event))
|
|
2071
|
491
|
|
4414
|
492 (defsubst event-click-count (event)
|
|
|
493 "Return the multi-click count of EVENT, a click or drag event.
|
|
|
494 The return value is a positive integer."
|
|
|
495 (if (integerp (nth 2 event)) (nth 2 event) 1))
|
|
|
496
|
|
2071
|
497 (defsubst posn-window (position)
|
|
|
498 "Return the window in POSITION.
|
|
|
499 POSITION should be a list of the form
|
|
6039
|
500 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
|
|
2071
|
501 as returned by the `event-start' and `event-end' functions."
|
|
|
502 (nth 0 position))
|
|
|
503
|
|
|
504 (defsubst posn-point (position)
|
|
|
505 "Return the buffer location in POSITION.
|
|
|
506 POSITION should be a list of the form
|
|
6039
|
507 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
|
|
2071
|
508 as returned by the `event-start' and `event-end' functions."
|
|
3991
|
509 (if (consp (nth 1 position))
|
|
|
510 (car (nth 1 position))
|
|
|
511 (nth 1 position)))
|
|
2071
|
512
|
|
6039
|
513 (defsubst posn-x-y (position)
|
|
|
514 "Return the x and y coordinates in POSITION.
|
|
2071
|
515 POSITION should be a list of the form
|
|
6039
|
516 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
|
|
2071
|
517 as returned by the `event-start' and `event-end' functions."
|
|
|
518 (nth 2 position))
|
|
|
519
|
|
7636
|
520 (defun posn-col-row (position)
|
|
7693
|
521 "Return the column and row in POSITION, measured in characters.
|
|
6039
|
522 POSITION should be a list of the form
|
|
|
523 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
|
|
7636
|
524 as returned by the `event-start' and `event-end' functions.
|
|
|
525 For a scroll-bar event, the result column is 0, and the row
|
|
|
526 corresponds to the vertical position of the click in the scroll bar."
|
|
|
527 (let ((pair (nth 2 position))
|
|
|
528 (window (posn-window position)))
|
|
7693
|
529 (if (eq (if (consp (nth 1 position))
|
|
|
530 (car (nth 1 position))
|
|
|
531 (nth 1 position))
|
|
7636
|
532 'vertical-scroll-bar)
|
|
|
533 (cons 0 (scroll-bar-scale pair (1- (window-height window))))
|
|
7693
|
534 (if (eq (if (consp (nth 1 position))
|
|
|
535 (car (nth 1 position))
|
|
|
536 (nth 1 position))
|
|
7636
|
537 'horizontal-scroll-bar)
|
|
|
538 (cons (scroll-bar-scale pair (window-width window)) 0)
|
|
7640
|
539 (let* ((frame (if (framep window) window (window-frame window)))
|
|
|
540 (x (/ (car pair) (frame-char-width frame)))
|
|
|
541 (y (/ (cdr pair) (frame-char-height frame))))
|
|
7636
|
542 (cons x y))))))
|
|
6039
|
543
|
|
2071
|
544 (defsubst posn-timestamp (position)
|
|
|
545 "Return the timestamp of POSITION.
|
|
|
546 POSITION should be a list of the form
|
|
6039
|
547 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
|
|
3411
|
548 as returned by the `event-start' and `event-end' functions."
|
|
2071
|
549 (nth 3 position))
|
|
2504
|
550
|
|
2071
|
551
|
|
2504
|
552 ;;;; Obsolescent names for functions.
|
|
|
553
|
|
2569
|
554 (defalias 'dot 'point)
|
|
|
555 (defalias 'dot-marker 'point-marker)
|
|
|
556 (defalias 'dot-min 'point-min)
|
|
|
557 (defalias 'dot-max 'point-max)
|
|
|
558 (defalias 'window-dot 'window-point)
|
|
|
559 (defalias 'set-window-dot 'set-window-point)
|
|
|
560 (defalias 'read-input 'read-string)
|
|
|
561 (defalias 'send-string 'process-send-string)
|
|
|
562 (defalias 'send-region 'process-send-region)
|
|
|
563 (defalias 'show-buffer 'set-window-buffer)
|
|
|
564 (defalias 'buffer-flush-undo 'buffer-disable-undo)
|
|
|
565 (defalias 'eval-current-buffer 'eval-buffer)
|
|
|
566 (defalias 'compiled-function-p 'byte-code-function-p)
|
|
16437
|
567 (defalias 'define-function 'defalias)
|
|
114
|
568
|
|
23134
|
569 (defalias 'sref 'aref)
|
|
|
570 (make-obsolete 'sref 'aref)
|
|
|
571 (make-obsolete 'char-bytes "Now this function always returns 1")
|
|
20605
|
572
|
|
2504
|
573 ;; Some programs still use this as a function.
|
|
|
574 (defun baud-rate ()
|
|
3210
|
575 "Obsolete function returning the value of the `baud-rate' variable.
|
|
|
576 Please convert your programs to use the variable `baud-rate' directly."
|
|
2504
|
577 baud-rate)
|
|
|
578
|
|
15599
|
579 (defalias 'focus-frame 'ignore)
|
|
|
580 (defalias 'unfocus-frame 'ignore)
|
|
2504
|
581
|
|
|
582 ;;;; Alternate names for functions - these are not being phased out.
|
|
|
583
|
|
2569
|
584 (defalias 'string= 'string-equal)
|
|
|
585 (defalias 'string< 'string-lessp)
|
|
|
586 (defalias 'move-marker 'set-marker)
|
|
|
587 (defalias 'not 'null)
|
|
|
588 (defalias 'rplaca 'setcar)
|
|
|
589 (defalias 'rplacd 'setcdr)
|
|
3591
|
590 (defalias 'beep 'ding) ;preserve lingual purity
|
|
2569
|
591 (defalias 'indent-to-column 'indent-to)
|
|
|
592 (defalias 'backward-delete-char 'delete-backward-char)
|
|
|
593 (defalias 'search-forward-regexp (symbol-function 're-search-forward))
|
|
|
594 (defalias 'search-backward-regexp (symbol-function 're-search-backward))
|
|
|
595 (defalias 'int-to-string 'number-to-string)
|
|
21173
|
596 (defalias 'store-match-data 'set-match-data)
|
|
25293
|
597 (defalias 'point-at-eol 'line-end-position)
|
|
|
598 (defalias 'point-at-bol 'line-beginning-position)
|
|
1903
|
599
|
|
|
600 ;;; Should this be an obsolete name? If you decide it should, you get
|
|
|
601 ;;; to go through all the sources and change them.
|
|
2569
|
602 (defalias 'string-to-int 'string-to-number)
|
|
114
|
603
|
|
2504
|
604 ;;;; Hook manipulation functions.
|
|
388
|
605
|
|
9195
|
606 (defun make-local-hook (hook)
|
|
|
607 "Make the hook HOOK local to the current buffer.
|
|
23786
|
608 The return value is HOOK.
|
|
|
609
|
|
9195
|
610 When a hook is local, its local and global values
|
|
|
611 work in concert: running the hook actually runs all the hook
|
|
|
612 functions listed in *either* the local value *or* the global value
|
|
|
613 of the hook variable.
|
|
|
614
|
|
12258
|
615 This function works by making `t' a member of the buffer-local value,
|
|
|
616 which acts as a flag to run the hook functions in the default value as
|
|
|
617 well. This works for all normal hooks, but does not work for most
|
|
|
618 non-normal hooks yet. We will be changing the callers of non-normal
|
|
|
619 hooks so that they can handle localness; this has to be done one by
|
|
|
620 one.
|
|
|
621
|
|
|
622 This function does nothing if HOOK is already local in the current
|
|
|
623 buffer.
|
|
9195
|
624
|
|
|
625 Do not use `make-local-variable' to make a hook variable buffer-local."
|
|
|
626 (if (local-variable-p hook)
|
|
|
627 nil
|
|
|
628 (or (boundp hook) (set hook nil))
|
|
|
629 (make-local-variable hook)
|
|
23786
|
630 (set hook (list t)))
|
|
|
631 hook)
|
|
9195
|
632
|
|
|
633 (defun add-hook (hook function &optional append local)
|
|
4414
|
634 "Add to the value of HOOK the function FUNCTION.
|
|
|
635 FUNCTION is not added if already present.
|
|
|
636 FUNCTION is added (if necessary) at the beginning of the hook list
|
|
|
637 unless the optional argument APPEND is non-nil, in which case
|
|
|
638 FUNCTION is added at the end.
|
|
|
639
|
|
9195
|
640 The optional fourth argument, LOCAL, if non-nil, says to modify
|
|
|
641 the hook's buffer-local value rather than its default value.
|
|
|
642 This makes no difference if the hook is not buffer-local.
|
|
|
643 To make a hook variable buffer-local, always use
|
|
|
644 `make-local-hook', not `make-local-variable'.
|
|
|
645
|
|
4414
|
646 HOOK should be a symbol, and FUNCTION may be any valid function. If
|
|
|
647 HOOK is void, it is first set to nil. If HOOK's value is a single
|
|
8959
|
648 function, it is changed to a list of functions."
|
|
114
|
649 (or (boundp hook) (set hook nil))
|
|
9195
|
650 (or (default-boundp hook) (set-default hook nil))
|
|
4414
|
651 ;; If the hook value is a single function, turn it into a list.
|
|
|
652 (let ((old (symbol-value hook)))
|
|
|
653 (if (or (not (listp old)) (eq (car old) 'lambda))
|
|
|
654 (set hook (list old))))
|
|
9202
|
655 (if (or local
|
|
|
656 ;; Detect the case where make-local-variable was used on a hook
|
|
|
657 ;; and do what we used to do.
|
|
12296
|
658 (and (local-variable-if-set-p hook)
|
|
9202
|
659 (not (memq t (symbol-value hook)))))
|
|
9195
|
660 ;; Alter the local value only.
|
|
22960
|
661 (or (if (or (consp function) (byte-code-function-p function))
|
|
9195
|
662 (member function (symbol-value hook))
|
|
|
663 (memq function (symbol-value hook)))
|
|
|
664 (set hook
|
|
|
665 (if append
|
|
|
666 (append (symbol-value hook) (list function))
|
|
|
667 (cons function (symbol-value hook)))))
|
|
|
668 ;; Alter the global value (which is also the only value,
|
|
|
669 ;; if the hook doesn't have a local value).
|
|
22960
|
670 (or (if (or (consp function) (byte-code-function-p function))
|
|
9195
|
671 (member function (default-value hook))
|
|
|
672 (memq function (default-value hook)))
|
|
|
673 (set-default hook
|
|
|
674 (if append
|
|
|
675 (append (default-value hook) (list function))
|
|
|
676 (cons function (default-value hook)))))))
|
|
2504
|
677
|
|
9195
|
678 (defun remove-hook (hook function &optional local)
|
|
4964
|
679 "Remove from the value of HOOK the function FUNCTION.
|
|
|
680 HOOK should be a symbol, and FUNCTION may be any valid function. If
|
|
|
681 FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
|
|
9195
|
682 list of hooks to run in HOOK, then nothing is done. See `add-hook'.
|
|
|
683
|
|
|
684 The optional third argument, LOCAL, if non-nil, says to modify
|
|
|
685 the hook's buffer-local value rather than its default value.
|
|
|
686 This makes no difference if the hook is not buffer-local.
|
|
|
687 To make a hook variable buffer-local, always use
|
|
|
688 `make-local-hook', not `make-local-variable'."
|
|
4964
|
689 (if (or (not (boundp hook)) ;unbound symbol, or
|
|
21696
|
690 (not (default-boundp hook))
|
|
4964
|
691 (null (symbol-value hook)) ;value is nil, or
|
|
|
692 (null function)) ;function is nil, then
|
|
|
693 nil ;Do nothing.
|
|
9202
|
694 (if (or local
|
|
|
695 ;; Detect the case where make-local-variable was used on a hook
|
|
|
696 ;; and do what we used to do.
|
|
|
697 (and (local-variable-p hook)
|
|
23294
|
698 (consp (symbol-value hook))
|
|
|
699 (not (memq t (symbol-value hook)))))
|
|
9195
|
700 (let ((hook-value (symbol-value hook)))
|
|
|
701 (if (consp hook-value)
|
|
|
702 (if (member function hook-value)
|
|
|
703 (setq hook-value (delete function (copy-sequence hook-value))))
|
|
|
704 (if (equal hook-value function)
|
|
|
705 (setq hook-value nil)))
|
|
|
706 (set hook hook-value))
|
|
|
707 (let ((hook-value (default-value hook)))
|
|
23294
|
708 (if (and (consp hook-value) (not (functionp hook-value)))
|
|
9195
|
709 (if (member function hook-value)
|
|
|
710 (setq hook-value (delete function (copy-sequence hook-value))))
|
|
|
711 (if (equal hook-value function)
|
|
|
712 (setq hook-value nil)))
|
|
|
713 (set-default hook hook-value)))))
|
|
9510
|
714
|
|
|
715 (defun add-to-list (list-var element)
|
|
9535
|
716 "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
|
|
13812
|
717 The test for presence of ELEMENT is done with `equal'.
|
|
24757
|
718 If ELEMENT is added, it is added at the beginning of the list.
|
|
|
719
|
|
9535
|
720 If you want to use `add-to-list' on a variable that is not defined
|
|
|
721 until a certain package is loaded, you should put the call to `add-to-list'
|
|
|
722 into a hook function that will be run only after loading the package.
|
|
|
723 `eval-after-load' provides one way to do this. In some cases
|
|
|
724 other hooks, such as major mode hooks, can do the job."
|
|
21409
|
725 (if (member element (symbol-value list-var))
|
|
|
726 (symbol-value list-var)
|
|
|
727 (set list-var (cons element (symbol-value list-var)))))
|
|
114
|
728
|
|
2504
|
729 ;;;; Specifying things to do after certain files are loaded.
|
|
|
730
|
|
|
731 (defun eval-after-load (file form)
|
|
|
732 "Arrange that, if FILE is ever loaded, FORM will be run at that time.
|
|
|
733 This makes or adds to an entry on `after-load-alist'.
|
|
10794
|
734 If FILE is already loaded, evaluate FORM right now.
|
|
5440
|
735 It does nothing if FORM is already on the list for FILE.
|
|
2504
|
736 FILE should be the name of a library, with no directory name."
|
|
10794
|
737 ;; Make sure there is an element for FILE.
|
|
2504
|
738 (or (assoc file after-load-alist)
|
|
|
739 (setq after-load-alist (cons (list file) after-load-alist)))
|
|
10794
|
740 ;; Add FORM to the element if it isn't there.
|
|
5440
|
741 (let ((elt (assoc file after-load-alist)))
|
|
|
742 (or (member form (cdr elt))
|
|
10794
|
743 (progn
|
|
|
744 (nconc elt (list form))
|
|
|
745 ;; If the file has been loaded already, run FORM right away.
|
|
|
746 (and (assoc file load-history)
|
|
|
747 (eval form)))))
|
|
2504
|
748 form)
|
|
|
749
|
|
|
750 (defun eval-next-after-load (file)
|
|
|
751 "Read the following input sexp, and run it whenever FILE is loaded.
|
|
|
752 This makes or adds to an entry on `after-load-alist'.
|
|
|
753 FILE should be the name of a library, with no directory name."
|
|
|
754 (eval-after-load file (read)))
|
|
|
755
|
|
|
756
|
|
|
757 ;;;; Input and display facilities.
|
|
|
758
|
|
18880
|
759 (defvar read-quoted-char-radix 8
|
|
18828
|
760 "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
|
|
18880
|
761 Legitimate radix values are 8, 10 and 16.")
|
|
|
762
|
|
|
763 (custom-declare-variable-early
|
|
|
764 'read-quoted-char-radix 8
|
|
|
765 "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
|
|
18828
|
766 Legitimate radix values are 8, 10 and 16."
|
|
|
767 :type '(choice (const 8) (const 10) (const 16))
|
|
|
768 :group 'editing-basics)
|
|
|
769
|
|
2504
|
770 (defun read-quoted-char (&optional prompt)
|
|
18821
|
771 "Like `read-char', but do not allow quitting.
|
|
|
772 Also, if the first character read is an octal digit,
|
|
|
773 we read any number of octal digits and return the
|
|
21008
|
774 specified character code. Any nondigit terminates the sequence.
|
|
18828
|
775 If the terminator is RET, it is discarded;
|
|
18821
|
776 any other terminator is used itself as input.
|
|
|
777
|
|
21008
|
778 The optional argument PROMPT specifies a string to use to prompt the user.
|
|
|
779 The variable `read-quoted-char-radix' controls which radix to use
|
|
|
780 for numeric input."
|
|
18821
|
781 (let ((message-log-max nil) done (first t) (code 0) char)
|
|
|
782 (while (not done)
|
|
|
783 (let ((inhibit-quit first)
|
|
12108
|
784 ;; Don't let C-h get the help message--only help function keys.
|
|
|
785 (help-char nil)
|
|
|
786 (help-form
|
|
|
787 "Type the special character you want to use,
|
|
18821
|
788 or the octal character code.
|
|
18828
|
789 RET terminates the character code and is discarded;
|
|
18821
|
790 any other non-digit terminates the character code and is then used as input."))
|
|
23058
|
791 (setq char (read-event (and prompt (format "%s-" prompt)) t))
|
|
2504
|
792 (if inhibit-quit (setq quit-flag nil)))
|
|
18948
|
793 ;; Translate TAB key into control-I ASCII character, and so on.
|
|
|
794 (and char
|
|
|
795 (let ((translated (lookup-key function-key-map (vector char))))
|
|
19175
|
796 (if (arrayp translated)
|
|
18948
|
797 (setq char (aref translated 0)))))
|
|
2504
|
798 (cond ((null char))
|
|
18828
|
799 ((not (integerp char))
|
|
|
800 (setq unread-command-events (list char)
|
|
|
801 done t))
|
|
19175
|
802 ((/= (logand char ?\M-\^@) 0)
|
|
|
803 ;; Turn a meta-character into a character with the 0200 bit set.
|
|
|
804 (setq code (logior (logand char (lognot ?\M-\^@)) 128)
|
|
|
805 done t))
|
|
18828
|
806 ((and (<= ?0 char) (< char (+ ?0 (min 10 read-quoted-char-radix))))
|
|
|
807 (setq code (+ (* code read-quoted-char-radix) (- char ?0)))
|
|
14343
|
808 (and prompt (setq prompt (message "%s %c" prompt char))))
|
|
18828
|
809 ((and (<= ?a (downcase char))
|
|
|
810 (< (downcase char) (+ ?a -10 (min 26 read-quoted-char-radix))))
|
|
19002
|
811 (setq code (+ (* code read-quoted-char-radix)
|
|
|
812 (+ 10 (- (downcase char) ?a))))
|
|
18828
|
813 (and prompt (setq prompt (message "%s %c" prompt char))))
|
|
|
814 ((and (not first) (eq char ?\C-m))
|
|
18821
|
815 (setq done t))
|
|
|
816 ((not first)
|
|
|
817 (setq unread-command-events (list char)
|
|
|
818 done t))
|
|
|
819 (t (setq code char
|
|
|
820 done t)))
|
|
|
821 (setq first nil))
|
|
19175
|
822 code))
|
|
2504
|
823
|
21092
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
824 (defun read-passwd (prompt &optional confirm default)
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
825 "Read a password, prompting with PROMPT. Echo `.' for each character typed.
|
|
20472
|
826 End with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line.
|
21092
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
827 Optional argument CONFIRM, if non-nil, then read it twice to make sure.
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
828 Optional DEFAULT is a default password to use instead of empty input."
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
829 (if confirm
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
830 (let (success)
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
831 (while (not success)
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
832 (let ((first (read-passwd prompt nil default))
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
833 (second (read-passwd "Confirm password: " nil default)))
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
834 (if (equal first second)
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
835 (setq success first)
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
836 (message "Password not repeated accurately; please start over")
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
837 (sit-for 1))))
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
838 success)
|
|
23437
|
839 (clear-this-command-keys)
|
21092
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
840 (let ((pass nil)
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
841 (c 0)
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
842 (echo-keystrokes 0)
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
843 (cursor-in-echo-area t))
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
844 (while (progn (message "%s%s"
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
845 prompt
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
846 (make-string (length pass) ?.))
|
|
23907
|
847 (setq c (read-char nil t))
|
21092
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
848 (and (/= c ?\r) (/= c ?\n) (/= c ?\e)))
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
849 (if (= c ?\C-u)
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
850 (setq pass "")
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
851 (if (and (/= c ?\b) (/= c ?\177))
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
852 (setq pass (concat pass (char-to-string c)))
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
853 (if (> (length pass) 0)
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
854 (setq pass (substring pass 0 -1))))))
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
855 (message nil)
|
7726f8d9eff0
(read-passwd): Renamed from read-password. New second arg CONFIRM.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
856 (or pass default ""))))
|
|
20472
|
857
|
|
2504
|
858 (defun force-mode-line-update (&optional all)
|
|
|
859 "Force the mode-line of the current buffer to be redisplayed.
|
|
6795
|
860 With optional non-nil ALL, force redisplay of all mode-lines."
|
|
2504
|
861 (if all (save-excursion (set-buffer (other-buffer))))
|
|
|
862 (set-buffer-modified-p (buffer-modified-p)))
|
|
|
863
|
|
114
|
864 (defun momentary-string-display (string pos &optional exit-char message)
|
|
|
865 "Momentarily display STRING in the buffer at POS.
|
|
|
866 Display remains until next character is typed.
|
|
|
867 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
|
|
|
868 otherwise it is then available as input (as a command if nothing else).
|
|
|
869 Display MESSAGE (optional fourth arg) in the echo area.
|
|
|
870 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
|
|
|
871 (or exit-char (setq exit-char ?\ ))
|
|
24322
|
872 (let ((inhibit-read-only t)
|
|
6553
|
873 ;; Don't modify the undo list at all.
|
|
|
874 (buffer-undo-list t)
|
|
114
|
875 (modified (buffer-modified-p))
|
|
|
876 (name buffer-file-name)
|
|
|
877 insert-end)
|
|
|
878 (unwind-protect
|
|
|
879 (progn
|
|
|
880 (save-excursion
|
|
|
881 (goto-char pos)
|
|
|
882 ;; defeat file locking... don't try this at home, kids!
|
|
|
883 (setq buffer-file-name nil)
|
|
|
884 (insert-before-markers string)
|
4620
5474175de175
(momentary-string-display): Scroll to keep the string on the screen.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
885 (setq insert-end (point))
|
5474175de175
(momentary-string-display): Scroll to keep the string on the screen.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
886 ;; If the message end is off screen, recenter now.
|
|
21173
|
887 (if (< (window-end nil t) insert-end)
|
4620
5474175de175
(momentary-string-display): Scroll to keep the string on the screen.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
888 (recenter (/ (window-height) 2)))
|
5474175de175
(momentary-string-display): Scroll to keep the string on the screen.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
889 ;; If that pushed message start off the screen,
|
5474175de175
(momentary-string-display): Scroll to keep the string on the screen.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
890 ;; scroll to start it at the top of the screen.
|
5474175de175
(momentary-string-display): Scroll to keep the string on the screen.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
891 (move-to-window-line 0)
|
5474175de175
(momentary-string-display): Scroll to keep the string on the screen.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
892 (if (> (point) pos)
|
5474175de175
(momentary-string-display): Scroll to keep the string on the screen.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
893 (progn
|
5474175de175
(momentary-string-display): Scroll to keep the string on the screen.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
894 (goto-char pos)
|
5474175de175
(momentary-string-display): Scroll to keep the string on the screen.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
895 (recenter 0))))
|
|
114
|
896 (message (or message "Type %s to continue editing.")
|
|
|
897 (single-key-description exit-char))
|
2033
10cdd2928c7d
(momentary-string-display): Handle any event when flushing the display.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
898 (let ((char (read-event)))
|
|
114
|
899 (or (eq char exit-char)
|
|
1821
|
900 (setq unread-command-events (list char)))))
|
|
114
|
901 (if insert-end
|
|
|
902 (save-excursion
|
|
|
903 (delete-region pos insert-end)))
|
|
|
904 (setq buffer-file-name name)
|
|
|
905 (set-buffer-modified-p modified))))
|
|
|
906
|
|
2504
|
907
|
|
|
908 ;;;; Miscellanea.
|
|
|
909
|
|
10254
|
910 ;; A number of major modes set this locally.
|
|
|
911 ;; Give it a global value to avoid compiler warnings.
|
|
|
912 (defvar font-lock-defaults nil)
|
|
|
913
|
|
20846
|
914 (defvar suspend-hook nil
|
|
|
915 "Normal hook run by `suspend-emacs', before suspending.")
|
|
|
916
|
|
|
917 (defvar suspend-resume-hook nil
|
|
|
918 "Normal hook run by `suspend-emacs', after Emacs is continued.")
|
|
|
919
|
|
10254
|
920 ;; Avoid compiler warnings about this variable,
|
|
|
921 ;; which has a special meaning on certain system types.
|
|
|
922 (defvar buffer-file-type nil
|
|
|
923 "Non-nil if the visited file is a binary file.
|
|
|
924 This variable is meaningful on MS-DOG and Windows NT.
|
|
|
925 On those systems, it is automatically local in every buffer.
|
|
|
926 On other systems, this variable is normally always nil.")
|
|
|
927
|
|
14515
|
928 ;; This should probably be written in C (i.e., without using `walk-windows').
|
|
14707
|
929 (defun get-buffer-window-list (buffer &optional minibuf frame)
|
|
14515
|
930 "Return windows currently displaying BUFFER, or nil if none.
|
|
14707
|
931 See `walk-windows' for the meaning of MINIBUF and FRAME."
|
14517
8b88e5c2a6d5
Cope if get-buffer-window-list is given a buffer name (like get-buffer-window does).
Simon Marshall <simon@gnu.org>
diff
changeset
|
932 (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows)
|
|
14515
|
933 (walk-windows (function (lambda (window)
|
|
|
934 (if (eq (window-buffer window) buffer)
|
|
|
935 (setq windows (cons window windows)))))
|
|
14707
|
936 minibuf frame)
|
|
14515
|
937 windows))
|
|
|
938
|
|
8211
|
939 (defun ignore (&rest ignore)
|
|
|
940 "Do nothing and return nil.
|
|
|
941 This function accepts any number of arguments, but ignores them."
|
|
7400
|
942 (interactive)
|
|
2504
|
943 nil)
|
|
|
944
|
|
|
945 (defun error (&rest args)
|
|
13936
|
946 "Signal an error, making error message by passing all args to `format'.
|
|
|
947 In Emacs, the convention is that error messages start with a capital
|
|
|
948 letter but *do not* end with a period. Please follow this convention
|
|
|
949 for the sake of consistency."
|
|
2504
|
950 (while t
|
|
|
951 (signal 'error (list (apply 'format args)))))
|
|
|
952
|
5912
909b94d547c4
(user-original-login-name): Reduce to a defalias, since it's redundant with
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
953 (defalias 'user-original-login-name 'user-login-name)
|
|
2504
|
954
|
|
114
|
955 (defun start-process-shell-command (name buffer &rest args)
|
|
|
956 "Start a program in a subprocess. Return the process object for it.
|
|
|
957 Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
|
|
|
958 NAME is name for process. It is modified if necessary to make it unique.
|
|
|
959 BUFFER is the buffer or (buffer-name) to associate with the process.
|
|
|
960 Process output goes at end of that buffer, unless you specify
|
|
|
961 an output stream or filter function to handle the output.
|
|
|
962 BUFFER may be also nil, meaning that this process is not associated
|
|
|
963 with any buffer
|
|
|
964 Third arg is command name, the name of a shell command.
|
|
|
965 Remaining arguments are the arguments for the command.
|
|
5460
|
966 Wildcards and redirection are handled as usual in the shell."
|
|
9822
|
967 (cond
|
|
|
968 ((eq system-type 'vax-vms)
|
|
|
969 (apply 'start-process name buffer args))
|
|
10025
|
970 ;; We used to use `exec' to replace the shell with the command,
|
|
|
971 ;; but that failed to handle (...) and semicolon, etc.
|
|
9822
|
972 (t
|
|
|
973 (start-process name buffer shell-file-name shell-command-switch
|
|
10025
|
974 (mapconcat 'identity args " ")))))
|
|
16359
|
975
|
|
16277
|
976 (defmacro with-current-buffer (buffer &rest body)
|
|
|
977 "Execute the forms in BODY with BUFFER as the current buffer.
|
|
16379
|
978 The value returned is the value of the last form in BODY.
|
|
|
979 See also `with-temp-buffer'."
|
|
16277
|
980 `(save-current-buffer
|
|
|
981 (set-buffer ,buffer)
|
|
16379
|
982 ,@body))
|
|
16277
|
983
|
|
23736
|
984 (defmacro with-temp-file (file &rest body)
|
|
|
985 "Create a new buffer, evaluate BODY there, and write the buffer to FILE.
|
|
|
986 The value returned is the value of the last form in BODY.
|
|
16379
|
987 See also `with-temp-buffer'."
|
|
16359
|
988 (let ((temp-file (make-symbol "temp-file"))
|
|
16379
|
989 (temp-buffer (make-symbol "temp-buffer")))
|
|
|
990 `(let ((,temp-file ,file)
|
|
|
991 (,temp-buffer
|
|
|
992 (get-buffer-create (generate-new-buffer-name " *temp file*"))))
|
|
|
993 (unwind-protect
|
|
|
994 (prog1
|
|
|
995 (with-current-buffer ,temp-buffer
|
|
23736
|
996 ,@body)
|
|
16379
|
997 (with-current-buffer ,temp-buffer
|
|
|
998 (widen)
|
|
|
999 (write-region (point-min) (point-max) ,temp-file nil 0)))
|
|
|
1000 (and (buffer-name ,temp-buffer)
|
|
|
1001 (kill-buffer ,temp-buffer))))))
|
|
|
1002
|
|
23736
|
1003 (defmacro with-temp-message (message &rest body)
|
|
24011
|
1004 "Display MESSAGE temporarily if non-nil while BODY is evaluated.
|
|
23736
|
1005 The original message is restored to the echo area after BODY has finished.
|
|
|
1006 The value returned is the value of the last form in BODY.
|
|
24011
|
1007 MESSAGE is written to the message log buffer if `message-log-max' is non-nil.
|
|
|
1008 If MESSAGE is nil, the echo area and message log buffer are unchanged.
|
|
|
1009 Use a MESSAGE of \"\" to temporarily clear the echo area."
|
|
24000
|
1010 (let ((current-message (make-symbol "current-message"))
|
|
|
1011 (temp-message (make-symbol "with-temp-message")))
|
|
|
1012 `(let ((,temp-message ,message)
|
|
|
1013 (,current-message))
|
|
23736
|
1014 (unwind-protect
|
|
|
1015 (progn
|
|
24000
|
1016 (when ,temp-message
|
|
|
1017 (setq ,current-message (current-message))
|
|
24699
|
1018 (message "%s" ,temp-message))
|
|
23736
|
1019 ,@body)
|
|
24385
|
1020 (and ,temp-message ,current-message
|
|
|
1021 (message "%s" ,current-message))))))
|
|
23736
|
1022
|
|
|
1023 (defmacro with-temp-buffer (&rest body)
|
|
|
1024 "Create a temporary buffer, and evaluate BODY there like `progn'.
|
|
16379
|
1025 See also `with-temp-file' and `with-output-to-string'."
|
|
|
1026 (let ((temp-buffer (make-symbol "temp-buffer")))
|
|
|
1027 `(let ((,temp-buffer
|
|
|
1028 (get-buffer-create (generate-new-buffer-name " *temp*"))))
|
|
|
1029 (unwind-protect
|
|
|
1030 (with-current-buffer ,temp-buffer
|
|
23736
|
1031 ,@body)
|
|
16379
|
1032 (and (buffer-name ,temp-buffer)
|
|
|
1033 (kill-buffer ,temp-buffer))))))
|
|
|
1034
|
|
16311
|
1035 (defmacro with-output-to-string (&rest body)
|
|
|
1036 "Execute BODY, return the text it sent to `standard-output', as a string."
|
|
16379
|
1037 `(let ((standard-output
|
|
|
1038 (get-buffer-create (generate-new-buffer-name " *string-output*"))))
|
|
16311
|
1039 (let ((standard-output standard-output))
|
|
|
1040 ,@body)
|
|
16379
|
1041 (with-current-buffer standard-output
|
|
|
1042 (prog1
|
|
|
1043 (buffer-string)
|
|
|
1044 (kill-buffer nil)))))
|
|
16549
|
1045
|
|
|
1046 (defmacro combine-after-change-calls (&rest body)
|
|
|
1047 "Execute BODY, but don't call the after-change functions till the end.
|
|
|
1048 If BODY makes changes in the buffer, they are recorded
|
|
|
1049 and the functions on `after-change-functions' are called several times
|
|
|
1050 when BODY is finished.
|
|
17146
|
1051 The return value is the value of the last form in BODY.
|
|
16549
|
1052
|
|
|
1053 If `before-change-functions' is non-nil, then calls to the after-change
|
|
|
1054 functions can't be deferred, so in that case this macro has no effect.
|
|
|
1055
|
|
|
1056 Do not alter `after-change-functions' or `before-change-functions'
|
|
|
1057 in BODY."
|
|
|
1058 `(unwind-protect
|
|
|
1059 (let ((combine-after-change-calls t))
|
|
|
1060 . ,body)
|
|
|
1061 (combine-after-change-execute)))
|
|
|
1062
|
|
16379
|
1063
|
|
15955
|
1064 (defvar save-match-data-internal)
|
|
|
1065
|
|
|
1066 ;; We use save-match-data-internal as the local variable because
|
|
|
1067 ;; that works ok in practice (people should not use that variable elsewhere).
|
|
|
1068 ;; We used to use an uninterned symbol; the compiler handles that properly
|
|
|
1069 ;; now, but it generates slower code.
|
|
2504
|
1070 (defmacro save-match-data (&rest body)
|
|
|
1071 "Execute the BODY forms, restoring the global value of the match data."
|
|
15983
|
1072 `(let ((save-match-data-internal (match-data)))
|
|
15955
|
1073 (unwind-protect
|
|
|
1074 (progn ,@body)
|
|
21173
|
1075 (set-match-data save-match-data-internal))))
|
|
144
|
1076
|
11115
9414f249cd8b
Changed match-string to defun, but still return nil (no error) if no match.
Simon Marshall <simon@gnu.org>
diff
changeset
|
1077 (defun match-string (num &optional string)
|
11101
67231dca5f32
Change to macro, and return nil if there was no match at the specified depth.
Simon Marshall <simon@gnu.org>
diff
changeset
|
1078 "Return string of text matched by last search.
|
67231dca5f32
Change to macro, and return nil if there was no match at the specified depth.
Simon Marshall <simon@gnu.org>
diff
changeset
|
1079 NUM specifies which parenthesized expression in the last regexp.
|
67231dca5f32
Change to macro, and return nil if there was no match at the specified depth.
Simon Marshall <simon@gnu.org>
diff
changeset
|
1080 Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
|
67231dca5f32
Change to macro, and return nil if there was no match at the specified depth.
Simon Marshall <simon@gnu.org>
diff
changeset
|
1081 Zero means the entire text matched by the whole regexp or whole string.
|
67231dca5f32
Change to macro, and return nil if there was no match at the specified depth.
Simon Marshall <simon@gnu.org>
diff
changeset
|
1082 STRING should be given if the last search was by `string-match' on STRING."
|
11115
9414f249cd8b
Changed match-string to defun, but still return nil (no error) if no match.
Simon Marshall <simon@gnu.org>
diff
changeset
|
1083 (if (match-beginning num)
|
9414f249cd8b
Changed match-string to defun, but still return nil (no error) if no match.
Simon Marshall <simon@gnu.org>
diff
changeset
|
1084 (if string
|
9414f249cd8b
Changed match-string to defun, but still return nil (no error) if no match.
Simon Marshall <simon@gnu.org>
diff
changeset
|
1085 (substring string (match-beginning num) (match-end num))
|
9414f249cd8b
Changed match-string to defun, but still return nil (no error) if no match.
Simon Marshall <simon@gnu.org>
diff
changeset
|
1086 (buffer-substring (match-beginning num) (match-end num)))))
|
|
10560
|
1087
|
|
20491
|
1088 (defun match-string-no-properties (num &optional string)
|
|
|
1089 "Return string of text matched by last search, without text properties.
|
|
|
1090 NUM specifies which parenthesized expression in the last regexp.
|
|
|
1091 Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
|
|
|
1092 Zero means the entire text matched by the whole regexp or whole string.
|
|
|
1093 STRING should be given if the last search was by `string-match' on STRING."
|
|
|
1094 (if (match-beginning num)
|
|
|
1095 (if string
|
|
|
1096 (let ((result
|
|
|
1097 (substring string (match-beginning num) (match-end num))))
|
|
|
1098 (set-text-properties 0 (length result) nil result)
|
|
|
1099 result)
|
|
|
1100 (buffer-substring-no-properties (match-beginning num)
|
|
|
1101 (match-end num)))))
|
|
|
1102
|
|
16314
|
1103 (defun split-string (string &optional separators)
|
|
|
1104 "Splits STRING into substrings where there are matches for SEPARATORS.
|
|
|
1105 Each match for SEPARATORS is a splitting point.
|
|
|
1106 The substrings between the splitting points are made into a list
|
|
|
1107 which is returned.
|
|
20476
|
1108 If SEPARATORS is absent, it defaults to \"[ \\f\\t\\n\\r\\v]+\".
|
|
|
1109
|
|
|
1110 If there is match for SEPARATORS at the beginning of STRING, we do not
|
|
|
1111 include a null substring for that. Likewise, if there is a match
|
|
|
1112 at the end of STRING, we don't include a null substring for that."
|
|
16314
|
1113 (let ((rexp (or separators "[ \f\t\n\r\v]+"))
|
|
|
1114 (start 0)
|
|
20476
|
1115 notfirst
|
|
16314
|
1116 (list nil))
|
|
20476
|
1117 (while (and (string-match rexp string
|
|
|
1118 (if (and notfirst
|
|
|
1119 (= start (match-beginning 0))
|
|
|
1120 (< start (length string)))
|
|
|
1121 (1+ start) start))
|
|
|
1122 (< (match-beginning 0) (length string)))
|
|
|
1123 (setq notfirst t)
|
|
16333
|
1124 (or (eq (match-beginning 0) 0)
|
|
20476
|
1125 (and (eq (match-beginning 0) (match-end 0))
|
|
|
1126 (eq (match-beginning 0) start))
|
|
16314
|
1127 (setq list
|
|
|
1128 (cons (substring string start (match-beginning 0))
|
|
|
1129 list)))
|
|
|
1130 (setq start (match-end 0)))
|
|
|
1131 (or (eq start (length string))
|
|
|
1132 (setq list
|
|
|
1133 (cons (substring string start)
|
|
|
1134 list)))
|
|
|
1135 (nreverse list)))
|
|
24089
|
1136
|
|
|
1137 (defun subst-char-in-string (fromchar tochar string &optional inplace)
|
|
|
1138 "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
|
|
|
1139 Unless optional argument INPLACE is non-nil, return a new string."
|
|
|
1140 (let ((i (length string))
|
|
|
1141 (newstr (if inplace string (copy-sequence string))))
|
|
|
1142 (while (> i 0)
|
|
|
1143 (setq i (1- i))
|
|
|
1144 (if (eq (aref newstr i) fromchar)
|
|
|
1145 (aset newstr i tochar)))
|
|
|
1146 newstr))
|
|
16359
|
1147
|
|
5385
|
1148 (defun shell-quote-argument (argument)
|
|
|
1149 "Quote an argument for passing as argument to an inferior shell."
|
|
12465
|
1150 (if (eq system-type 'ms-dos)
|
|
25706
|
1151 ;; Quote using double quotes, but escape any existing quotes in
|
|
|
1152 ;; the argument with backslashes.
|
|
|
1153 (let ((result "")
|
|
|
1154 (start 0)
|
|
|
1155 end)
|
|
|
1156 (if (or (null (string-match "[^\"]" argument))
|
|
|
1157 (< (match-end 0) (length argument)))
|
|
|
1158 (while (string-match "[\"]" argument start)
|
|
|
1159 (setq end (match-beginning 0)
|
|
|
1160 result (concat result (substring argument start end)
|
|
|
1161 "\\" (substring argument end (1+ end)))
|
|
|
1162 start (1+ end))))
|
|
|
1163 (concat "\"" result (substring argument start) "\""))
|
|
12465
|
1164 (if (eq system-type 'windows-nt)
|
|
|
1165 (concat "\"" argument "\"")
|
|
17610
|
1166 (if (equal argument "")
|
|
|
1167 "''"
|
|
|
1168 ;; Quote everything except POSIX filename characters.
|
|
|
1169 ;; This should be safe enough even for really weird shells.
|
|
|
1170 (let ((result "") (start 0) end)
|
|
|
1171 (while (string-match "[^-0-9a-zA-Z_./]" argument start)
|
|
|
1172 (setq end (match-beginning 0)
|
|
|
1173 result (concat result (substring argument start end)
|
|
|
1174 "\\" (substring argument end (1+ end)))
|
|
|
1175 start (1+ end)))
|
|
|
1176 (concat result (substring argument start)))))))
|
|
5385
|
1177
|
5844
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1178 (defun make-syntax-table (&optional oldtable)
|
|
5421
|
1179 "Return a new syntax table.
|
|
17612
|
1180 If OLDTABLE is non-nil, copy OLDTABLE.
|
|
|
1181 Otherwise, create a syntax table which inherits
|
|
|
1182 all letters and control characters from the standard syntax table;
|
|
|
1183 other characters are copied from the standard syntax table."
|
5844
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1184 (if oldtable
|
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1185 (copy-syntax-table oldtable)
|
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1186 (let ((table (copy-syntax-table))
|
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1187 i)
|
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1188 (setq i 0)
|
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1189 (while (<= i 31)
|
|
13186
|
1190 (aset table i nil)
|
5844
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1191 (setq i (1+ i)))
|
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1192 (setq i ?A)
|
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1193 (while (<= i ?Z)
|
|
13186
|
1194 (aset table i nil)
|
5844
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1195 (setq i (1+ i)))
|
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1196 (setq i ?a)
|
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1197 (while (<= i ?z)
|
|
13186
|
1198 (aset table i nil)
|
5844
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1199 (setq i (1+ i)))
|
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1200 (setq i 128)
|
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1201 (while (<= i 255)
|
|
13186
|
1202 (aset table i nil)
|
5844
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1203 (setq i (1+ i)))
|
445de172c217
(make-syntax-table): Behave like copy-syntax-table if an argument is given,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1204 table)))
|
|
17146
|
1205
|
|
|
1206 (defun add-to-invisibility-spec (arg)
|
|
|
1207 "Add elements to `buffer-invisibility-spec'.
|
|
|
1208 See documentation for `buffer-invisibility-spec' for the kind of elements
|
|
|
1209 that can be added."
|
|
|
1210 (cond
|
|
|
1211 ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t))
|
|
|
1212 (setq buffer-invisibility-spec (list arg)))
|
|
|
1213 (t
|
|
17158
|
1214 (setq buffer-invisibility-spec
|
|
|
1215 (cons arg buffer-invisibility-spec)))))
|
|
17146
|
1216
|
|
|
1217 (defun remove-from-invisibility-spec (arg)
|
|
|
1218 "Remove elements from `buffer-invisibility-spec'."
|
|
24245
|
1219 (if (consp buffer-invisibility-spec)
|
|
17152
|
1220 (setq buffer-invisibility-spec (delete arg buffer-invisibility-spec))))
|
|
10825
|
1221
|
|
|
1222 (defun global-set-key (key command)
|
|
|
1223 "Give KEY a global binding as COMMAND.
|
|
20410
|
1224 COMMAND is the command definition to use; usually it is
|
|
|
1225 a symbol naming an interactively-callable function.
|
|
|
1226 KEY is a key sequence; noninteractively, it is a string or vector
|
|
|
1227 of characters or event types, and non-ASCII characters with codes
|
|
|
1228 above 127 (such as ISO Latin-1) can be included if you use a vector.
|
|
|
1229
|
|
|
1230 Note that if KEY has a local binding in the current buffer,
|
|
|
1231 that local binding will continue to shadow any global binding
|
|
|
1232 that you make with this function."
|
|
10825
|
1233 (interactive "KSet key globally: \nCSet key %s to command: ")
|
|
|
1234 (or (vectorp key) (stringp key)
|
|
|
1235 (signal 'wrong-type-argument (list 'arrayp key)))
|
21578
6175866e1b71
(local-set-key, global-set-key): Return what define-key returns.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
1236 (define-key (current-global-map) key command))
|
|
5421
|
1237
|
|
10825
|
1238 (defun local-set-key (key command)
|
|
|
1239 "Give KEY a local binding as COMMAND.
|
|
20410
|
1240 COMMAND is the command definition to use; usually it is
|
|
|
1241 a symbol naming an interactively-callable function.
|
|
|
1242 KEY is a key sequence; noninteractively, it is a string or vector
|
|
|
1243 of characters or event types, and non-ASCII characters with codes
|
|
|
1244 above 127 (such as ISO Latin-1) can be included if you use a vector.
|
|
|
1245
|
|
10825
|
1246 The binding goes in the current buffer's local map,
|
|
|
1247 which in most cases is shared with all other buffers in the same major mode."
|
|
|
1248 (interactive "KSet key locally: \nCSet key %s locally to command: ")
|
|
|
1249 (let ((map (current-local-map)))
|
|
|
1250 (or map
|
|
|
1251 (use-local-map (setq map (make-sparse-keymap))))
|
|
|
1252 (or (vectorp key) (stringp key)
|
|
|
1253 (signal 'wrong-type-argument (list 'arrayp key)))
|
21578
6175866e1b71
(local-set-key, global-set-key): Return what define-key returns.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
1254 (define-key map key command)))
|
|
10825
|
1255
|
|
|
1256 (defun global-unset-key (key)
|
|
|
1257 "Remove global binding of KEY.
|
|
|
1258 KEY is a string representing a sequence of keystrokes."
|
|
|
1259 (interactive "kUnset key globally: ")
|
|
|
1260 (global-set-key key nil))
|
|
|
1261
|
|
10826
|
1262 (defun local-unset-key (key)
|
|
10825
|
1263 "Remove local binding of KEY.
|
|
|
1264 KEY is a string representing a sequence of keystrokes."
|
|
|
1265 (interactive "kUnset key locally: ")
|
|
|
1266 (if (current-local-map)
|
|
10826
|
1267 (local-set-key key nil))
|
|
10825
|
1268 nil)
|
|
|
1269
|
|
12016
|
1270 ;; We put this here instead of in frame.el so that it's defined even on
|
|
|
1271 ;; systems where frame.el isn't loaded.
|
|
|
1272 (defun frame-configuration-p (object)
|
|
|
1273 "Return non-nil if OBJECT seems to be a frame configuration.
|
|
|
1274 Any list whose car is `frame-configuration' is assumed to be a frame
|
|
|
1275 configuration."
|
|
|
1276 (and (consp object)
|
|
|
1277 (eq (car object) 'frame-configuration)))
|
|
|
1278
|
|
17418
|
1279 (defun functionp (object)
|
|
18880
|
1280 "Non-nil if OBJECT is a type of object that can be called as a function."
|
19176
d8eb24685152
(functionp): Use byte-code-function-p, not compiled-function-p.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
1281 (or (subrp object) (byte-code-function-p object)
|
|
17418
|
1282 (eq (car-safe object) 'lambda)
|
|
|
1283 (and (symbolp object) (fboundp object))))
|
|
|
1284
|
|
2504
|
1285 ;; now in fns.c
|
|
|
1286 ;(defun nth (n list)
|
|
|
1287 ; "Returns the Nth element of LIST.
|
|
|
1288 ;N counts from zero. If LIST is not that long, nil is returned."
|
|
|
1289 ; (car (nthcdr n list)))
|
|
|
1290 ;
|
|
|
1291 ;(defun copy-alist (alist)
|
|
|
1292 ; "Return a copy of ALIST.
|
|
|
1293 ;This is a new alist which represents the same mapping
|
|
|
1294 ;from objects to objects, but does not share the alist structure with ALIST.
|
|
|
1295 ;The objects mapped (cars and cdrs of elements of the alist)
|
|
|
1296 ;are shared, however."
|
|
|
1297 ; (setq alist (copy-sequence alist))
|
|
|
1298 ; (let ((tail alist))
|
|
|
1299 ; (while tail
|
|
|
1300 ; (if (consp (car tail))
|
|
|
1301 ; (setcar tail (cons (car (car tail)) (cdr (car tail)))))
|
|
|
1302 ; (setq tail (cdr tail))))
|
|
|
1303 ; alist)
|
|
787
|
1304
|
|
25140
|
1305 (defun assoc-delete-all (key alist)
|
|
|
1306 "Delete from ALIST all elements whose car is KEY.
|
|
|
1307 Return the modified alist."
|
|
|
1308 (setq alist (copy-sequence alist))
|
|
|
1309 (let ((tail alist))
|
|
|
1310 (while tail
|
|
|
1311 (if (eq (car (car tail)) key)
|
|
|
1312 (setq alist (delq (car tail) alist)))
|
|
|
1313 (setq tail (cdr tail)))
|
|
|
1314 alist))
|
|
|
1315
|
|
25631
|
1316 (defun make-temp-file (prefix &optional dir-flag)
|
|
|
1317 "Create a temporary file.
|
|
|
1318 The returned file name (created by appending some random characters at the end
|
|
|
1319 of PREFIX, and expanding against `temporary-file-directory' if necessary,
|
|
|
1320 is guaranteed to point to a newly created empty file.
|
|
|
1321 You can then use `write-region' to write new data into the file.
|
|
|
1322
|
|
|
1323 If DIR-FLAG is non-nil, create a new empty directory instead of a file."
|
|
|
1324 (let (file)
|
|
|
1325 (while (condition-case ()
|
|
|
1326 (progn
|
|
|
1327 (setq file
|
|
|
1328 (make-temp-name
|
|
|
1329 (expand-file-name prefix temporary-file-directory)))
|
|
|
1330 (if dir-flag
|
|
|
1331 (make-directory file)
|
|
|
1332 (write-region "" nil file nil 'silent nil 'excl))
|
|
|
1333 nil)
|
|
|
1334 (file-already-exists t))
|
|
|
1335 ;; the file was somehow created by someone else between
|
|
|
1336 ;; `make-temp-name' and `write-region', let's try again.
|
|
|
1337 nil)
|
|
|
1338 file))
|
|
|
1339
|
|
787
|
1340 ;;; subr.el ends here
|
