]> code.delx.au - gnu-emacs/blob - lisp/subr.el
(add-to-history): New function.
[gnu-emacs] / lisp / subr.el
1 ;;; subr.el --- basic lisp subroutines for Emacs
2
3 ;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1999, 2000, 2001, 2002, 2003,
4 ;; 2004, 2005, 2006 Free Software Foundation, Inc.
5
6 ;; Maintainer: FSF
7 ;; Keywords: internal
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
25
26 ;;; Commentary:
27
28 ;;; Code:
29 (defvar custom-declare-variable-list nil
30 "Record `defcustom' calls made before `custom.el' is loaded to handle them.
31 Each element of this list holds the arguments to one call to `defcustom'.")
32
33 ;; Use this, rather than defcustom, in subr.el and other files loaded
34 ;; before custom.el.
35 (defun custom-declare-variable-early (&rest arguments)
36 (setq custom-declare-variable-list
37 (cons arguments custom-declare-variable-list)))
38
39 \f
40 ;;;; Basic Lisp macros.
41
42 (defalias 'not 'null)
43
44 (defmacro noreturn (form)
45 "Evaluate FORM, expecting it not to return.
46 If FORM does return, signal an error."
47 `(prog1 ,form
48 (error "Form marked with `noreturn' did return")))
49
50 (defmacro 1value (form)
51 "Evaluate FORM, expecting a constant return value.
52 This is the global do-nothing version. There is also `testcover-1value'
53 that complains if FORM ever does return differing values."
54 form)
55
56 (defmacro lambda (&rest cdr)
57 "Return a lambda expression.
58 A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
59 self-quoting; the result of evaluating the lambda expression is the
60 expression itself. The lambda expression may then be treated as a
61 function, i.e., stored as the function value of a symbol, passed to
62 `funcall' or `mapcar', etc.
63
64 ARGS should take the same form as an argument list for a `defun'.
65 DOCSTRING is an optional documentation string.
66 If present, it should describe how to call the function.
67 But documentation strings are usually not useful in nameless functions.
68 INTERACTIVE should be a call to the function `interactive', which see.
69 It may also be omitted.
70 BODY should be a list of Lisp expressions.
71
72 \(fn ARGS [DOCSTRING] [INTERACTIVE] BODY)"
73 ;; Note that this definition should not use backquotes; subr.el should not
74 ;; depend on backquote.el.
75 (list 'function (cons 'lambda cdr)))
76
77 (defmacro push (newelt listname)
78 "Add NEWELT to the list stored in the symbol LISTNAME.
79 This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)).
80 LISTNAME must be a symbol."
81 (declare (debug (form sexp)))
82 (list 'setq listname
83 (list 'cons newelt listname)))
84
85 (defmacro pop (listname)
86 "Return the first element of LISTNAME's value, and remove it from the list.
87 LISTNAME must be a symbol whose value is a list.
88 If the value is nil, `pop' returns nil but does not actually
89 change the list."
90 (declare (debug (sexp)))
91 (list 'car
92 (list 'prog1 listname
93 (list 'setq listname (list 'cdr listname)))))
94
95 (defmacro when (cond &rest body)
96 "If COND yields non-nil, do BODY, else return nil."
97 (declare (indent 1) (debug t))
98 (list 'if cond (cons 'progn body)))
99
100 (defmacro unless (cond &rest body)
101 "If COND yields nil, do BODY, else return nil."
102 (declare (indent 1) (debug t))
103 (cons 'if (cons cond (cons nil body))))
104
105 (defmacro dolist (spec &rest body)
106 "Loop over a list.
107 Evaluate BODY with VAR bound to each car from LIST, in turn.
108 Then evaluate RESULT to get return value, default nil.
109
110 \(fn (VAR LIST [RESULT]) BODY...)"
111 (declare (indent 1) (debug ((symbolp form &optional form) body)))
112 (let ((temp (make-symbol "--dolist-temp--")))
113 `(let ((,temp ,(nth 1 spec))
114 ,(car spec))
115 (while ,temp
116 (setq ,(car spec) (car ,temp))
117 (setq ,temp (cdr ,temp))
118 ,@body)
119 ,@(if (cdr (cdr spec))
120 `((setq ,(car spec) nil) ,@(cdr (cdr spec)))))))
121
122 (defmacro dotimes (spec &rest body)
123 "Loop a certain number of times.
124 Evaluate BODY with VAR bound to successive integers running from 0,
125 inclusive, to COUNT, exclusive. Then evaluate RESULT to get
126 the return value (nil if RESULT is omitted).
127
128 \(fn (VAR COUNT [RESULT]) BODY...)"
129 (declare (indent 1) (debug dolist))
130 (let ((temp (make-symbol "--dotimes-temp--"))
131 (start 0)
132 (end (nth 1 spec)))
133 `(let ((,temp ,end)
134 (,(car spec) ,start))
135 (while (< ,(car spec) ,temp)
136 ,@body
137 (setq ,(car spec) (1+ ,(car spec))))
138 ,@(cdr (cdr spec)))))
139
140 (defmacro declare (&rest specs)
141 "Do not evaluate any arguments and return nil.
142 Treated as a declaration when used at the right place in a
143 `defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)"
144 nil)
145 \f
146 ;;;; Basic Lisp functions.
147
148 (defun ignore (&rest ignore)
149 "Do nothing and return nil.
150 This function accepts any number of arguments, but ignores them."
151 (interactive)
152 nil)
153
154 (defun error (&rest args)
155 "Signal an error, making error message by passing all args to `format'.
156 In Emacs, the convention is that error messages start with a capital
157 letter but *do not* end with a period. Please follow this convention
158 for the sake of consistency."
159 (while t
160 (signal 'error (list (apply 'format args)))))
161
162 ;; We put this here instead of in frame.el so that it's defined even on
163 ;; systems where frame.el isn't loaded.
164 (defun frame-configuration-p (object)
165 "Return non-nil if OBJECT seems to be a frame configuration.
166 Any list whose car is `frame-configuration' is assumed to be a frame
167 configuration."
168 (and (consp object)
169 (eq (car object) 'frame-configuration)))
170
171 (defun functionp (object)
172 "Non-nil if OBJECT is any kind of function or a special form.
173 Also non-nil if OBJECT is a symbol and its function definition is
174 \(recursively) a function or special form. This does not include
175 macros."
176 (or (and (symbolp object) (fboundp object)
177 (condition-case nil
178 (setq object (indirect-function object))
179 (error nil))
180 (eq (car-safe object) 'autoload)
181 (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))
182 (subrp object) (byte-code-function-p object)
183 (eq (car-safe object) 'lambda)))
184 \f
185 ;;;; List functions.
186
187 (defsubst caar (x)
188 "Return the car of the car of X."
189 (car (car x)))
190
191 (defsubst cadr (x)
192 "Return the car of the cdr of X."
193 (car (cdr x)))
194
195 (defsubst cdar (x)
196 "Return the cdr of the car of X."
197 (cdr (car x)))
198
199 (defsubst cddr (x)
200 "Return the cdr of the cdr of X."
201 (cdr (cdr x)))
202
203 (defun last (list &optional n)
204 "Return the last link of LIST. Its car is the last element.
205 If LIST is nil, return nil.
206 If N is non-nil, return the Nth-to-last link of LIST.
207 If N is bigger than the length of LIST, return LIST."
208 (if n
209 (let ((m 0) (p list))
210 (while (consp p)
211 (setq m (1+ m) p (cdr p)))
212 (if (<= n 0) p
213 (if (< n m) (nthcdr (- m n) list) list)))
214 (while (consp (cdr list))
215 (setq list (cdr list)))
216 list))
217
218 (defun butlast (list &optional n)
219 "Return a copy of LIST with the last N elements removed."
220 (if (and n (<= n 0)) list
221 (nbutlast (copy-sequence list) n)))
222
223 (defun nbutlast (list &optional n)
224 "Modifies LIST to remove the last N elements."
225 (let ((m (length list)))
226 (or n (setq n 1))
227 (and (< n m)
228 (progn
229 (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
230 list))))
231
232 (defun delete-dups (list)
233 "Destructively remove `equal' duplicates from LIST.
234 Store the result in LIST and return it. LIST must be a proper list.
235 Of several `equal' occurrences of an element in LIST, the first
236 one is kept."
237 (let ((tail list))
238 (while tail
239 (setcdr tail (delete (car tail) (cdr tail)))
240 (setq tail (cdr tail))))
241 list)
242
243 (defun number-sequence (from &optional to inc)
244 "Return a sequence of numbers from FROM to TO (both inclusive) as a list.
245 INC is the increment used between numbers in the sequence and defaults to 1.
246 So, the Nth element of the list is \(+ FROM \(* N INC)) where N counts from
247 zero. TO is only included if there is an N for which TO = FROM + N * INC.
248 If TO is nil or numerically equal to FROM, return \(FROM).
249 If INC is positive and TO is less than FROM, or INC is negative
250 and TO is larger than FROM, return nil.
251 If INC is zero and TO is neither nil nor numerically equal to
252 FROM, signal an error.
253
254 This function is primarily designed for integer arguments.
255 Nevertheless, FROM, TO and INC can be integer or float. However,
256 floating point arithmetic is inexact. For instance, depending on
257 the machine, it may quite well happen that
258 \(number-sequence 0.4 0.6 0.2) returns the one element list \(0.4),
259 whereas \(number-sequence 0.4 0.8 0.2) returns a list with three
260 elements. Thus, if some of the arguments are floats and one wants
261 to make sure that TO is included, one may have to explicitly write
262 TO as \(+ FROM \(* N INC)) or use a variable whose value was
263 computed with this exact expression. Alternatively, you can,
264 of course, also replace TO with a slightly larger value
265 \(or a slightly more negative value if INC is negative)."
266 (if (or (not to) (= from to))
267 (list from)
268 (or inc (setq inc 1))
269 (when (zerop inc) (error "The increment can not be zero"))
270 (let (seq (n 0) (next from))
271 (if (> inc 0)
272 (while (<= next to)
273 (setq seq (cons next seq)
274 n (1+ n)
275 next (+ from (* n inc))))
276 (while (>= next to)
277 (setq seq (cons next seq)
278 n (1+ n)
279 next (+ from (* n inc)))))
280 (nreverse seq))))
281
282 (defun copy-tree (tree &optional vecp)
283 "Make a copy of TREE.
284 If TREE is a cons cell, this recursively copies both its car and its cdr.
285 Contrast to `copy-sequence', which copies only along the cdrs. With second
286 argument VECP, this copies vectors as well as conses."
287 (if (consp tree)
288 (let (result)
289 (while (consp tree)
290 (let ((newcar (car tree)))
291 (if (or (consp (car tree)) (and vecp (vectorp (car tree))))
292 (setq newcar (copy-tree (car tree) vecp)))
293 (push newcar result))
294 (setq tree (cdr tree)))
295 (nconc (nreverse result) tree))
296 (if (and vecp (vectorp tree))
297 (let ((i (length (setq tree (copy-sequence tree)))))
298 (while (>= (setq i (1- i)) 0)
299 (aset tree i (copy-tree (aref tree i) vecp)))
300 tree)
301 tree)))
302 \f
303 ;;;; Various list-search functions.
304
305 (defun assoc-default (key alist &optional test default)
306 "Find object KEY in a pseudo-alist ALIST.
307 ALIST is a list of conses or objects. Each element (or the element's car,
308 if it is a cons) is compared with KEY by evaluating (TEST (car elt) KEY).
309 If that is non-nil, the element matches;
310 then `assoc-default' returns the element's cdr, if it is a cons,
311 or DEFAULT if the element is not a cons.
312
313 If no element matches, the value is nil.
314 If TEST is omitted or nil, `equal' is used."
315 (let (found (tail alist) value)
316 (while (and tail (not found))
317 (let ((elt (car tail)))
318 (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
319 (setq found t value (if (consp elt) (cdr elt) default))))
320 (setq tail (cdr tail)))
321 value))
322
323 (make-obsolete 'assoc-ignore-case 'assoc-string)
324 (defun assoc-ignore-case (key alist)
325 "Like `assoc', but ignores differences in case and text representation.
326 KEY must be a string. Upper-case and lower-case letters are treated as equal.
327 Unibyte strings are converted to multibyte for comparison."
328 (assoc-string key alist t))
329
330 (make-obsolete 'assoc-ignore-representation 'assoc-string)
331 (defun assoc-ignore-representation (key alist)
332 "Like `assoc', but ignores differences in text representation.
333 KEY must be a string.
334 Unibyte strings are converted to multibyte for comparison."
335 (assoc-string key alist nil))
336
337 (defun member-ignore-case (elt list)
338 "Like `member', but ignores differences in case and text representation.
339 ELT must be a string. Upper-case and lower-case letters are treated as equal.
340 Unibyte strings are converted to multibyte for comparison.
341 Non-strings in LIST are ignored."
342 (while (and list
343 (not (and (stringp (car list))
344 (eq t (compare-strings elt 0 nil (car list) 0 nil t)))))
345 (setq list (cdr list)))
346 list)
347
348 (defun assq-delete-all (key alist)
349 "Delete from ALIST all elements whose car is `eq' to KEY.
350 Return the modified alist.
351 Elements of ALIST that are not conses are ignored."
352 (while (and (consp (car alist))
353 (eq (car (car alist)) key))
354 (setq alist (cdr alist)))
355 (let ((tail alist) tail-cdr)
356 (while (setq tail-cdr (cdr tail))
357 (if (and (consp (car tail-cdr))
358 (eq (car (car tail-cdr)) key))
359 (setcdr tail (cdr tail-cdr))
360 (setq tail tail-cdr))))
361 alist)
362
363 (defun rassq-delete-all (value alist)
364 "Delete from ALIST all elements whose cdr is `eq' to VALUE.
365 Return the modified alist.
366 Elements of ALIST that are not conses are ignored."
367 (while (and (consp (car alist))
368 (eq (cdr (car alist)) value))
369 (setq alist (cdr alist)))
370 (let ((tail alist) tail-cdr)
371 (while (setq tail-cdr (cdr tail))
372 (if (and (consp (car tail-cdr))
373 (eq (cdr (car tail-cdr)) value))
374 (setcdr tail (cdr tail-cdr))
375 (setq tail tail-cdr))))
376 alist)
377
378 (defun remove (elt seq)
379 "Return a copy of SEQ with all occurrences of ELT removed.
380 SEQ must be a list, vector, or string. The comparison is done with `equal'."
381 (if (nlistp seq)
382 ;; If SEQ isn't a list, there's no need to copy SEQ because
383 ;; `delete' will return a new object.
384 (delete elt seq)
385 (delete elt (copy-sequence seq))))
386
387 (defun remq (elt list)
388 "Return LIST with all occurrences of ELT removed.
389 The comparison is done with `eq'. Contrary to `delq', this does not use
390 side-effects, and the argument LIST is not modified."
391 (if (memq elt list)
392 (delq elt (copy-sequence list))
393 list))
394 \f
395 ;;;; Keymap support.
396
397 (defmacro kbd (keys)
398 "Convert KEYS to the internal Emacs key representation.
399 KEYS should be a string constant in the format used for
400 saving keyboard macros (see `edmacro-mode')."
401 (read-kbd-macro keys))
402
403 (defun undefined ()
404 (interactive)
405 (ding))
406
407 ;; Prevent the \{...} documentation construct
408 ;; from mentioning keys that run this command.
409 (put 'undefined 'suppress-keymap t)
410
411 (defun suppress-keymap (map &optional nodigits)
412 "Make MAP override all normally self-inserting keys to be undefined.
413 Normally, as an exception, digits and minus-sign are set to make prefix args,
414 but optional second arg NODIGITS non-nil treats them like other chars."
415 (define-key map [remap self-insert-command] 'undefined)
416 (or nodigits
417 (let (loop)
418 (define-key map "-" 'negative-argument)
419 ;; Make plain numbers do numeric args.
420 (setq loop ?0)
421 (while (<= loop ?9)
422 (define-key map (char-to-string loop) 'digit-argument)
423 (setq loop (1+ loop))))))
424
425 (defun define-key-after (keymap key definition &optional after)
426 "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
427 This is like `define-key' except that the binding for KEY is placed
428 just after the binding for the event AFTER, instead of at the beginning
429 of the map. Note that AFTER must be an event type (like KEY), NOT a command
430 \(like DEFINITION).
431
432 If AFTER is t or omitted, the new binding goes at the end of the keymap.
433 AFTER should be a single event type--a symbol or a character, not a sequence.
434
435 Bindings are always added before any inherited map.
436
437 The order of bindings in a keymap matters when it is used as a menu."
438 (unless after (setq after t))
439 (or (keymapp keymap)
440 (signal 'wrong-type-argument (list 'keymapp keymap)))
441 (setq key
442 (if (<= (length key) 1) (aref key 0)
443 (setq keymap (lookup-key keymap
444 (apply 'vector
445 (butlast (mapcar 'identity key)))))
446 (aref key (1- (length key)))))
447 (let ((tail keymap) done inserted)
448 (while (and (not done) tail)
449 ;; Delete any earlier bindings for the same key.
450 (if (eq (car-safe (car (cdr tail))) key)
451 (setcdr tail (cdr (cdr tail))))
452 ;; If we hit an included map, go down that one.
453 (if (keymapp (car tail)) (setq tail (car tail)))
454 ;; When we reach AFTER's binding, insert the new binding after.
455 ;; If we reach an inherited keymap, insert just before that.
456 ;; If we reach the end of this keymap, insert at the end.
457 (if (or (and (eq (car-safe (car tail)) after)
458 (not (eq after t)))
459 (eq (car (cdr tail)) 'keymap)
460 (null (cdr tail)))
461 (progn
462 ;; Stop the scan only if we find a parent keymap.
463 ;; Keep going past the inserted element
464 ;; so we can delete any duplications that come later.
465 (if (eq (car (cdr tail)) 'keymap)
466 (setq done t))
467 ;; Don't insert more than once.
468 (or inserted
469 (setcdr tail (cons (cons key definition) (cdr tail))))
470 (setq inserted t)))
471 (setq tail (cdr tail)))))
472
473 (defun map-keymap-internal (function keymap &optional sort-first)
474 "Implement `map-keymap' with sorting.
475 Don't call this function; it is for internal use only."
476 (if sort-first
477 (let (list)
478 (map-keymap (lambda (a b) (push (cons a b) list))
479 keymap)
480 (setq list (sort list
481 (lambda (a b)
482 (setq a (car a) b (car b))
483 (if (integerp a)
484 (if (integerp b) (< a b)
485 t)
486 (if (integerp b) t
487 (string< a b))))))
488 (dolist (p list)
489 (funcall function (car p) (cdr p))))
490 (map-keymap function keymap)))
491
492 (put 'keyboard-translate-table 'char-table-extra-slots 0)
493
494 (defun keyboard-translate (from to)
495 "Translate character FROM to TO at a low level.
496 This function creates a `keyboard-translate-table' if necessary
497 and then modifies one entry in it."
498 (or (char-table-p keyboard-translate-table)
499 (setq keyboard-translate-table
500 (make-char-table 'keyboard-translate-table nil)))
501 (aset keyboard-translate-table from to))
502 \f
503 ;;;; Key binding commands.
504
505 (defun global-set-key (key command)
506 "Give KEY a global binding as COMMAND.
507 COMMAND is the command definition to use; usually it is
508 a symbol naming an interactively-callable function.
509 KEY is a key sequence; noninteractively, it is a string or vector
510 of characters or event types, and non-ASCII characters with codes
511 above 127 (such as ISO Latin-1) can be included if you use a vector.
512
513 Note that if KEY has a local binding in the current buffer,
514 that local binding will continue to shadow any global binding
515 that you make with this function."
516 (interactive "KSet key globally: \nCSet key %s to command: ")
517 (or (vectorp key) (stringp key)
518 (signal 'wrong-type-argument (list 'arrayp key)))
519 (define-key (current-global-map) key command))
520
521 (defun local-set-key (key command)
522 "Give KEY a local binding as COMMAND.
523 COMMAND is the command definition to use; usually it is
524 a symbol naming an interactively-callable function.
525 KEY is a key sequence; noninteractively, it is a string or vector
526 of characters or event types, and non-ASCII characters with codes
527 above 127 (such as ISO Latin-1) can be included if you use a vector.
528
529 The binding goes in the current buffer's local map,
530 which in most cases is shared with all other buffers in the same major mode."
531 (interactive "KSet key locally: \nCSet key %s locally to command: ")
532 (let ((map (current-local-map)))
533 (or map
534 (use-local-map (setq map (make-sparse-keymap))))
535 (or (vectorp key) (stringp key)
536 (signal 'wrong-type-argument (list 'arrayp key)))
537 (define-key map key command)))
538
539 (defun global-unset-key (key)
540 "Remove global binding of KEY.
541 KEY is a string or vector representing a sequence of keystrokes."
542 (interactive "kUnset key globally: ")
543 (global-set-key key nil))
544
545 (defun local-unset-key (key)
546 "Remove local binding of KEY.
547 KEY is a string or vector representing a sequence of keystrokes."
548 (interactive "kUnset key locally: ")
549 (if (current-local-map)
550 (local-set-key key nil))
551 nil)
552 \f
553 ;;;; substitute-key-definition and its subroutines.
554
555 (defvar key-substitution-in-progress nil
556 "Used internally by `substitute-key-definition'.")
557
558 (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
559 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
560 In other words, OLDDEF is replaced with NEWDEF where ever it appears.
561 Alternatively, if optional fourth argument OLDMAP is specified, we redefine
562 in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP.
563
564 If you don't specify OLDMAP, you can usually get the same results
565 in a cleaner way with command remapping, like this:
566 \(define-key KEYMAP [remap OLDDEF] NEWDEF)
567 \n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)"
568 ;; Don't document PREFIX in the doc string because we don't want to
569 ;; advertise it. It's meant for recursive calls only. Here's its
570 ;; meaning
571
572 ;; If optional argument PREFIX is specified, it should be a key
573 ;; prefix, a string. Redefined bindings will then be bound to the
574 ;; original key, with PREFIX added at the front.
575 (or prefix (setq prefix ""))
576 (let* ((scan (or oldmap keymap))
577 (prefix1 (vconcat prefix [nil]))
578 (key-substitution-in-progress
579 (cons scan key-substitution-in-progress)))
580 ;; Scan OLDMAP, finding each char or event-symbol that
581 ;; has any definition, and act on it with hack-key.
582 (map-keymap
583 (lambda (char defn)
584 (aset prefix1 (length prefix) char)
585 (substitute-key-definition-key defn olddef newdef prefix1 keymap))
586 scan)))
587
588 (defun substitute-key-definition-key (defn olddef newdef prefix keymap)
589 (let (inner-def skipped menu-item)
590 ;; Find the actual command name within the binding.
591 (if (eq (car-safe defn) 'menu-item)
592 (setq menu-item defn defn (nth 2 defn))
593 ;; Skip past menu-prompt.
594 (while (stringp (car-safe defn))
595 (push (pop defn) skipped))
596 ;; Skip past cached key-equivalence data for menu items.
597 (if (consp (car-safe defn))
598 (setq defn (cdr defn))))
599 (if (or (eq defn olddef)
600 ;; Compare with equal if definition is a key sequence.
601 ;; That is useful for operating on function-key-map.
602 (and (or (stringp defn) (vectorp defn))
603 (equal defn olddef)))
604 (define-key keymap prefix
605 (if menu-item
606 (let ((copy (copy-sequence menu-item)))
607 (setcar (nthcdr 2 copy) newdef)
608 copy)
609 (nconc (nreverse skipped) newdef)))
610 ;; Look past a symbol that names a keymap.
611 (setq inner-def
612 (or (indirect-function defn t) defn))
613 ;; For nested keymaps, we use `inner-def' rather than `defn' so as to
614 ;; avoid autoloading a keymap. This is mostly done to preserve the
615 ;; original non-autoloading behavior of pre-map-keymap times.
616 (if (and (keymapp inner-def)
617 ;; Avoid recursively scanning
618 ;; where KEYMAP does not have a submap.
619 (let ((elt (lookup-key keymap prefix)))
620 (or (null elt) (natnump elt) (keymapp elt)))
621 ;; Avoid recursively rescanning keymap being scanned.
622 (not (memq inner-def key-substitution-in-progress)))
623 ;; If this one isn't being scanned already, scan it now.
624 (substitute-key-definition olddef newdef keymap inner-def prefix)))))
625
626 \f
627 ;;;; The global keymap tree.
628
629 ;;; global-map, esc-map, and ctl-x-map have their values set up in
630 ;;; keymap.c; we just give them docstrings here.
631
632 (defvar global-map nil
633 "Default global keymap mapping Emacs keyboard input into commands.
634 The value is a keymap which is usually (but not necessarily) Emacs's
635 global map.")
636
637 (defvar esc-map nil
638 "Default keymap for ESC (meta) commands.
639 The normal global definition of the character ESC indirects to this keymap.")
640
641 (defvar ctl-x-map nil
642 "Default keymap for C-x commands.
643 The normal global definition of the character C-x indirects to this keymap.")
644
645 (defvar ctl-x-4-map (make-sparse-keymap)
646 "Keymap for subcommands of C-x 4.")
647 (defalias 'ctl-x-4-prefix ctl-x-4-map)
648 (define-key ctl-x-map "4" 'ctl-x-4-prefix)
649
650 (defvar ctl-x-5-map (make-sparse-keymap)
651 "Keymap for frame commands.")
652 (defalias 'ctl-x-5-prefix ctl-x-5-map)
653 (define-key ctl-x-map "5" 'ctl-x-5-prefix)
654
655 \f
656 ;;;; Event manipulation functions.
657
658 ;; The call to `read' is to ensure that the value is computed at load time
659 ;; and not compiled into the .elc file. The value is negative on most
660 ;; machines, but not on all!
661 (defconst listify-key-sequence-1 (logior 128 (read "?\\M-\\^@")))
662
663 (defun listify-key-sequence (key)
664 "Convert a key sequence to a list of events."
665 (if (vectorp key)
666 (append key nil)
667 (mapcar (function (lambda (c)
668 (if (> c 127)
669 (logxor c listify-key-sequence-1)
670 c)))
671 key)))
672
673 (defsubst eventp (obj)
674 "True if the argument is an event object."
675 (or (and (integerp obj)
676 ;; Filter out integers too large to be events.
677 ;; M is the biggest modifier.
678 (zerop (logand obj (lognot (1- (lsh ?\M-\^@ 1)))))
679 (char-valid-p (event-basic-type obj)))
680 (and (symbolp obj)
681 (get obj 'event-symbol-elements))
682 (and (consp obj)
683 (symbolp (car obj))
684 (get (car obj) 'event-symbol-elements))))
685
686 (defun event-modifiers (event)
687 "Return a list of symbols representing the modifier keys in event EVENT.
688 The elements of the list may include `meta', `control',
689 `shift', `hyper', `super', `alt', `click', `double', `triple', `drag',
690 and `down'.
691 EVENT may be an event or an event type. If EVENT is a symbol
692 that has never been used in an event that has been read as input
693 in the current Emacs session, then this function can return nil,
694 even when EVENT actually has modifiers."
695 (let ((type event))
696 (if (listp type)
697 (setq type (car type)))
698 (if (symbolp type)
699 (cdr (get type 'event-symbol-elements))
700 (let ((list nil)
701 (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
702 ?\H-\^@ ?\s-\^@ ?\A-\^@)))))
703 (if (not (zerop (logand type ?\M-\^@)))
704 (push 'meta list))
705 (if (or (not (zerop (logand type ?\C-\^@)))
706 (< char 32))
707 (push 'control list))
708 (if (or (not (zerop (logand type ?\S-\^@)))
709 (/= char (downcase char)))
710 (push 'shift list))
711 (or (zerop (logand type ?\H-\^@))
712 (push 'hyper list))
713 (or (zerop (logand type ?\s-\^@))
714 (push 'super list))
715 (or (zerop (logand type ?\A-\^@))
716 (push 'alt list))
717 list))))
718
719 (defun event-basic-type (event)
720 "Return the basic type of the given event (all modifiers removed).
721 The value is a printing character (not upper case) or a symbol.
722 EVENT may be an event or an event type. If EVENT is a symbol
723 that has never been used in an event that has been read as input
724 in the current Emacs session, then this function may return nil."
725 (if (consp event)
726 (setq event (car event)))
727 (if (symbolp event)
728 (car (get event 'event-symbol-elements))
729 (let* ((base (logand event (1- ?\A-\^@)))
730 (uncontrolled (if (< base 32) (logior base 64) base)))
731 ;; There are some numbers that are invalid characters and
732 ;; cause `downcase' to get an error.
733 (condition-case ()
734 (downcase uncontrolled)
735 (error uncontrolled)))))
736
737 (defsubst mouse-movement-p (object)
738 "Return non-nil if OBJECT is a mouse movement event."
739 (eq (car-safe object) 'mouse-movement))
740
741 (defsubst event-start (event)
742 "Return the starting position of EVENT.
743 If EVENT is a mouse or key press or a mouse click, this returns the location
744 of the event.
745 If EVENT is a drag, this returns the drag's starting position.
746 The return value is of the form
747 (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
748 IMAGE (DX . DY) (WIDTH . HEIGHT))
749 The `posn-' functions access elements of such lists."
750 (if (consp event) (nth 1 event)
751 (list (selected-window) (point) '(0 . 0) 0)))
752
753 (defsubst event-end (event)
754 "Return the ending location of EVENT.
755 EVENT should be a click, drag, or key press event.
756 If EVENT is a click event, this function is the same as `event-start'.
757 The return value is of the form
758 (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
759 IMAGE (DX . DY) (WIDTH . HEIGHT))
760 The `posn-' functions access elements of such lists."
761 (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event)
762 (list (selected-window) (point) '(0 . 0) 0)))
763
764 (defsubst event-click-count (event)
765 "Return the multi-click count of EVENT, a click or drag event.
766 The return value is a positive integer."
767 (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1))
768 \f
769 ;;;; Extracting fields of the positions in an event.
770
771 (defsubst posn-window (position)
772 "Return the window in POSITION.
773 POSITION should be a list of the form returned by the `event-start'
774 and `event-end' functions."
775 (nth 0 position))
776
777 (defsubst posn-area (position)
778 "Return the window area recorded in POSITION, or nil for the text area.
779 POSITION should be a list of the form returned by the `event-start'
780 and `event-end' functions."
781 (let ((area (if (consp (nth 1 position))
782 (car (nth 1 position))
783 (nth 1 position))))
784 (and (symbolp area) area)))
785
786 (defsubst posn-point (position)
787 "Return the buffer location in POSITION.
788 POSITION should be a list of the form returned by the `event-start'
789 and `event-end' functions."
790 (or (nth 5 position)
791 (if (consp (nth 1 position))
792 (car (nth 1 position))
793 (nth 1 position))))
794
795 (defun posn-set-point (position)
796 "Move point to POSITION.
797 Select the corresponding window as well."
798 (if (not (windowp (posn-window position)))
799 (error "Position not in text area of window"))
800 (select-window (posn-window position))
801 (if (numberp (posn-point position))
802 (goto-char (posn-point position))))
803
804 (defsubst posn-x-y (position)
805 "Return the x and y coordinates in POSITION.
806 POSITION should be a list of the form returned by the `event-start'
807 and `event-end' functions."
808 (nth 2 position))
809
810 (defun posn-col-row (position)
811 "Return the nominal column and row in POSITION, measured in characters.
812 The column and row values are approximations calculated from the x
813 and y coordinates in POSITION and the frame's default character width
814 and height.
815 For a scroll-bar event, the result column is 0, and the row
816 corresponds to the vertical position of the click in the scroll bar.
817 POSITION should be a list of the form returned by the `event-start'
818 and `event-end' functions."
819 (let* ((pair (posn-x-y position))
820 (window (posn-window position))
821 (area (posn-area position)))
822 (cond
823 ((null window)
824 '(0 . 0))
825 ((eq area 'vertical-scroll-bar)
826 (cons 0 (scroll-bar-scale pair (1- (window-height window)))))
827 ((eq area 'horizontal-scroll-bar)
828 (cons (scroll-bar-scale pair (window-width window)) 0))
829 (t
830 (let* ((frame (if (framep window) window (window-frame window)))
831 (x (/ (car pair) (frame-char-width frame)))
832 (y (/ (cdr pair) (+ (frame-char-height frame)
833 (or (frame-parameter frame 'line-spacing)
834 default-line-spacing
835 0)))))
836 (cons x y))))))
837
838 (defun posn-actual-col-row (position)
839 "Return the actual column and row in POSITION, measured in characters.
840 These are the actual row number in the window and character number in that row.
841 Return nil if POSITION does not contain the actual position; in that case
842 `posn-col-row' can be used to get approximate values.
843 POSITION should be a list of the form returned by the `event-start'
844 and `event-end' functions."
845 (nth 6 position))
846
847 (defsubst posn-timestamp (position)
848 "Return the timestamp of POSITION.
849 POSITION should be a list of the form returned by the `event-start'
850 and `event-end' functions."
851 (nth 3 position))
852
853 (defsubst posn-string (position)
854 "Return the string object of POSITION.
855 Value is a cons (STRING . STRING-POS), or nil if not a string.
856 POSITION should be a list of the form returned by the `event-start'
857 and `event-end' functions."
858 (nth 4 position))
859
860 (defsubst posn-image (position)
861 "Return the image object of POSITION.
862 Value is an list (image ...), or nil if not an image.
863 POSITION should be a list of the form returned by the `event-start'
864 and `event-end' functions."
865 (nth 7 position))
866
867 (defsubst posn-object (position)
868 "Return the object (image or string) of POSITION.
869 Value is a list (image ...) for an image object, a cons cell
870 \(STRING . STRING-POS) for a string object, and nil for a buffer position.
871 POSITION should be a list of the form returned by the `event-start'
872 and `event-end' functions."
873 (or (posn-image position) (posn-string position)))
874
875 (defsubst posn-object-x-y (position)
876 "Return the x and y coordinates relative to the object of POSITION.
877 POSITION should be a list of the form returned by the `event-start'
878 and `event-end' functions."
879 (nth 8 position))
880
881 (defsubst posn-object-width-height (position)
882 "Return the pixel width and height of the object of POSITION.
883 POSITION should be a list of the form returned by the `event-start'
884 and `event-end' functions."
885 (nth 9 position))
886
887 \f
888 ;;;; Obsolescent names for functions.
889
890 (define-obsolete-function-alias 'window-dot 'window-point "22.1")
891 (define-obsolete-function-alias 'set-window-dot 'set-window-point "22.1")
892 (define-obsolete-function-alias 'read-input 'read-string "22.1")
893 (define-obsolete-function-alias 'show-buffer 'set-window-buffer "22.1")
894 (define-obsolete-function-alias 'eval-current-buffer 'eval-buffer "22.1")
895 (define-obsolete-function-alias 'string-to-int 'string-to-number "22.1")
896
897 (make-obsolete 'char-bytes "now always returns 1." "20.4")
898
899 (defun insert-string (&rest args)
900 "Mocklisp-compatibility insert function.
901 Like the function `insert' except that any argument that is a number
902 is converted into a string by expressing it in decimal."
903 (dolist (el args)
904 (insert (if (integerp el) (number-to-string el) el))))
905 (make-obsolete 'insert-string 'insert "22.1")
906
907 (defun makehash (&optional test) (make-hash-table :test (or test 'eql)))
908 (make-obsolete 'makehash 'make-hash-table "22.1")
909
910 ;; Some programs still use this as a function.
911 (defun baud-rate ()
912 "Return the value of the `baud-rate' variable."
913 baud-rate)
914 (make-obsolete 'baud-rate "use the `baud-rate' variable instead." "before 19.15")
915
916 ;; These are used by VM and some old programs
917 (defalias 'focus-frame 'ignore "")
918 (make-obsolete 'focus-frame "it does nothing." "22.1")
919 (defalias 'unfocus-frame 'ignore "")
920 (make-obsolete 'unfocus-frame "it does nothing." "22.1")
921
922 \f
923 ;;;; Obsolescence declarations for variables, and aliases.
924
925 (make-obsolete-variable 'directory-sep-char "do not use it." "21.1")
926 (make-obsolete-variable 'mode-line-inverse-video "use the appropriate faces instead." "21.1")
927 (make-obsolete-variable 'unread-command-char
928 "use `unread-command-events' instead. That variable is a list of events to reread, so it now uses nil to mean `no event', instead of -1."
929 "before 19.15")
930
931 ;; Lisp manual only updated in 22.1.
932 (define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro
933 "before 19.34")
934
935 (defvaralias 'x-lost-selection-hooks 'x-lost-selection-functions)
936 (make-obsolete-variable 'x-lost-selection-hooks 'x-lost-selection-functions "22.1")
937 (defvaralias 'x-sent-selection-hooks 'x-sent-selection-functions)
938 (make-obsolete-variable 'x-sent-selection-hooks 'x-sent-selection-functions "22.1")
939
940 (defvaralias 'messages-buffer-max-lines 'message-log-max)
941 \f
942 ;;;; Alternate names for functions - these are not being phased out.
943
944 (defalias 'send-string 'process-send-string)
945 (defalias 'send-region 'process-send-region)
946 (defalias 'string= 'string-equal)
947 (defalias 'string< 'string-lessp)
948 (defalias 'move-marker 'set-marker)
949 (defalias 'rplaca 'setcar)
950 (defalias 'rplacd 'setcdr)
951 (defalias 'beep 'ding) ;preserve lingual purity
952 (defalias 'indent-to-column 'indent-to)
953 (defalias 'backward-delete-char 'delete-backward-char)
954 (defalias 'search-forward-regexp (symbol-function 're-search-forward))
955 (defalias 'search-backward-regexp (symbol-function 're-search-backward))
956 (defalias 'int-to-string 'number-to-string)
957 (defalias 'store-match-data 'set-match-data)
958 (defalias 'make-variable-frame-localizable 'make-variable-frame-local)
959 ;; These are the XEmacs names:
960 (defalias 'point-at-eol 'line-end-position)
961 (defalias 'point-at-bol 'line-beginning-position)
962
963 (defalias 'user-original-login-name 'user-login-name)
964
965 \f
966 ;;;; Hook manipulation functions.
967
968 (defun make-local-hook (hook)
969 "Make the hook HOOK local to the current buffer.
970 The return value is HOOK.
971
972 You never need to call this function now that `add-hook' does it for you
973 if its LOCAL argument is non-nil.
974
975 When a hook is local, its local and global values
976 work in concert: running the hook actually runs all the hook
977 functions listed in *either* the local value *or* the global value
978 of the hook variable.
979
980 This function works by making t a member of the buffer-local value,
981 which acts as a flag to run the hook functions in the default value as
982 well. This works for all normal hooks, but does not work for most
983 non-normal hooks yet. We will be changing the callers of non-normal
984 hooks so that they can handle localness; this has to be done one by
985 one.
986
987 This function does nothing if HOOK is already local in the current
988 buffer.
989
990 Do not use `make-local-variable' to make a hook variable buffer-local."
991 (if (local-variable-p hook)
992 nil
993 (or (boundp hook) (set hook nil))
994 (make-local-variable hook)
995 (set hook (list t)))
996 hook)
997 (make-obsolete 'make-local-hook "not necessary any more." "21.1")
998
999 (defun add-hook (hook function &optional append local)
1000 "Add to the value of HOOK the function FUNCTION.
1001 FUNCTION is not added if already present.
1002 FUNCTION is added (if necessary) at the beginning of the hook list
1003 unless the optional argument APPEND is non-nil, in which case
1004 FUNCTION is added at the end.
1005
1006 The optional fourth argument, LOCAL, if non-nil, says to modify
1007 the hook's buffer-local value rather than its default value.
1008 This makes the hook buffer-local if needed, and it makes t a member
1009 of the buffer-local value. That acts as a flag to run the hook
1010 functions in the default value as well as in the local value.
1011
1012 HOOK should be a symbol, and FUNCTION may be any valid function. If
1013 HOOK is void, it is first set to nil. If HOOK's value is a single
1014 function, it is changed to a list of functions."
1015 (or (boundp hook) (set hook nil))
1016 (or (default-boundp hook) (set-default hook nil))
1017 (if local (unless (local-variable-if-set-p hook)
1018 (set (make-local-variable hook) (list t)))
1019 ;; Detect the case where make-local-variable was used on a hook
1020 ;; and do what we used to do.
1021 (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
1022 (setq local t)))
1023 (let ((hook-value (if local (symbol-value hook) (default-value hook))))
1024 ;; If the hook value is a single function, turn it into a list.
1025 (when (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
1026 (setq hook-value (list hook-value)))
1027 ;; Do the actual addition if necessary
1028 (unless (member function hook-value)
1029 (setq hook-value
1030 (if append
1031 (append hook-value (list function))
1032 (cons function hook-value))))
1033 ;; Set the actual variable
1034 (if local (set hook hook-value) (set-default hook hook-value))))
1035
1036 (defun remove-hook (hook function &optional local)
1037 "Remove from the value of HOOK the function FUNCTION.
1038 HOOK should be a symbol, and FUNCTION may be any valid function. If
1039 FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
1040 list of hooks to run in HOOK, then nothing is done. See `add-hook'.
1041
1042 The optional third argument, LOCAL, if non-nil, says to modify
1043 the hook's buffer-local value rather than its default value."
1044 (or (boundp hook) (set hook nil))
1045 (or (default-boundp hook) (set-default hook nil))
1046 ;; Do nothing if LOCAL is t but this hook has no local binding.
1047 (unless (and local (not (local-variable-p hook)))
1048 ;; Detect the case where make-local-variable was used on a hook
1049 ;; and do what we used to do.
1050 (when (and (local-variable-p hook)
1051 (not (and (consp (symbol-value hook))
1052 (memq t (symbol-value hook)))))
1053 (setq local t))
1054 (let ((hook-value (if local (symbol-value hook) (default-value hook))))
1055 ;; Remove the function, for both the list and the non-list cases.
1056 (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
1057 (if (equal hook-value function) (setq hook-value nil))
1058 (setq hook-value (delete function (copy-sequence hook-value))))
1059 ;; If the function is on the global hook, we need to shadow it locally
1060 ;;(when (and local (member function (default-value hook))
1061 ;; (not (member (cons 'not function) hook-value)))
1062 ;; (push (cons 'not function) hook-value))
1063 ;; Set the actual variable
1064 (if (not local)
1065 (set-default hook hook-value)
1066 (if (equal hook-value '(t))
1067 (kill-local-variable hook)
1068 (set hook hook-value))))))
1069
1070 (defun add-to-list (list-var element &optional append)
1071 "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
1072 The test for presence of ELEMENT is done with `equal'.
1073 If ELEMENT is added, it is added at the beginning of the list,
1074 unless the optional argument APPEND is non-nil, in which case
1075 ELEMENT is added at the end.
1076
1077 The return value is the new value of LIST-VAR.
1078
1079 If you want to use `add-to-list' on a variable that is not defined
1080 until a certain package is loaded, you should put the call to `add-to-list'
1081 into a hook function that will be run only after loading the package.
1082 `eval-after-load' provides one way to do this. In some cases
1083 other hooks, such as major mode hooks, can do the job."
1084 (if (member element (symbol-value list-var))
1085 (symbol-value list-var)
1086 (set list-var
1087 (if append
1088 (append (symbol-value list-var) (list element))
1089 (cons element (symbol-value list-var))))))
1090
1091
1092 (defun add-to-ordered-list (list-var element &optional order)
1093 "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
1094 The test for presence of ELEMENT is done with `eq'.
1095
1096 The resulting list is reordered so that the elements are in the
1097 order given by each element's numeric list order. Elements
1098 without a numeric list order are placed at the end of the list.
1099
1100 If the third optional argument ORDER is a number (integer or
1101 float), set the element's list order to the given value. If
1102 ORDER is nil or omitted, do not change the numeric order of
1103 ELEMENT. If ORDER has any other value, remove the numeric order
1104 of ELEMENT if it has one.
1105
1106 The list order for each element is stored in LIST-VAR's
1107 `list-order' property.
1108
1109 The return value is the new value of LIST-VAR."
1110 (let ((ordering (get list-var 'list-order)))
1111 (unless ordering
1112 (put list-var 'list-order
1113 (setq ordering (make-hash-table :weakness 'key :test 'eq))))
1114 (when order
1115 (puthash element (and (numberp order) order) ordering))
1116 (unless (memq element (symbol-value list-var))
1117 (set list-var (cons element (symbol-value list-var))))
1118 (set list-var (sort (symbol-value list-var)
1119 (lambda (a b)
1120 (let ((oa (gethash a ordering))
1121 (ob (gethash b ordering)))
1122 (if (and oa ob)
1123 (< oa ob)
1124 oa)))))))
1125
1126 (defun add-to-history (history-var newelt &optional maxelt keep-dups)
1127 "Add NEWELT to the history list stored in the variable HISTORY-VAR.
1128 Return the new history list.
1129 If MAXELT is non-nil, it specifies the maximum length of the history.
1130 Otherwise, the maximum history length is the value of the `history-length'
1131 property on symbol HISTORY-VAR, if set, or the value of the `history-length'
1132 variable.
1133 Remove duplicates of NEWELT unless `history-delete-duplicates' is nil
1134 or KEEP-DUPS is non-nil."
1135 (unless maxelt
1136 (setq maxelt (or (get history-var 'history-length)
1137 history-length)))
1138 (let ((history (symbol-value history-var))
1139 tail)
1140 (if (and history-delete-duplicates (not keep-dups))
1141 (setq history (delete newelt history)))
1142 (setq history (cons newelt history))
1143 (when (integerp maxelt)
1144 (if (= 0 maxelt)
1145 (setq history nil)
1146 (setq tail (nthcdr (1- maxelt) history))
1147 (when (consp tail)
1148 (setcdr tail nil))))
1149 (set history-var history)))
1150
1151 \f
1152 ;;;; Mode hooks.
1153
1154 (defvar delay-mode-hooks nil
1155 "If non-nil, `run-mode-hooks' should delay running the hooks.")
1156 (defvar delayed-mode-hooks nil
1157 "List of delayed mode hooks waiting to be run.")
1158 (make-variable-buffer-local 'delayed-mode-hooks)
1159 (put 'delay-mode-hooks 'permanent-local t)
1160
1161 (defvar after-change-major-mode-hook nil
1162 "Normal hook run at the very end of major mode functions.")
1163
1164 (defun run-mode-hooks (&rest hooks)
1165 "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS.
1166 Execution is delayed if `delay-mode-hooks' is non-nil.
1167 If `delay-mode-hooks' is nil, run `after-change-major-mode-hook'
1168 after running the mode hooks.
1169 Major mode functions should use this."
1170 (if delay-mode-hooks
1171 ;; Delaying case.
1172 (dolist (hook hooks)
1173 (push hook delayed-mode-hooks))
1174 ;; Normal case, just run the hook as before plus any delayed hooks.
1175 (setq hooks (nconc (nreverse delayed-mode-hooks) hooks))
1176 (setq delayed-mode-hooks nil)
1177 (apply 'run-hooks hooks)
1178 (run-hooks 'after-change-major-mode-hook)))
1179
1180 (defmacro delay-mode-hooks (&rest body)
1181 "Execute BODY, but delay any `run-mode-hooks'.
1182 These hooks will be executed by the first following call to
1183 `run-mode-hooks' that occurs outside any `delayed-mode-hooks' form.
1184 Only affects hooks run in the current buffer."
1185 (declare (debug t) (indent 0))
1186 `(progn
1187 (make-local-variable 'delay-mode-hooks)
1188 (let ((delay-mode-hooks t))
1189 ,@body)))
1190
1191 ;; PUBLIC: find if the current mode derives from another.
1192
1193 (defun derived-mode-p (&rest modes)
1194 "Non-nil if the current major mode is derived from one of MODES.
1195 Uses the `derived-mode-parent' property of the symbol to trace backwards."
1196 (let ((parent major-mode))
1197 (while (and (not (memq parent modes))
1198 (setq parent (get parent 'derived-mode-parent))))
1199 parent))
1200 \f
1201 ;;;; Minor modes.
1202
1203 ;; If a minor mode is not defined with define-minor-mode,
1204 ;; add it here explicitly.
1205 ;; isearch-mode is deliberately excluded, since you should
1206 ;; not call it yourself.
1207 (defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode
1208 overwrite-mode view-mode
1209 hs-minor-mode)
1210 "List of all minor mode functions.")
1211
1212 (defun add-minor-mode (toggle name &optional keymap after toggle-fun)
1213 "Register a new minor mode.
1214
1215 This is an XEmacs-compatibility function. Use `define-minor-mode' instead.
1216
1217 TOGGLE is a symbol which is the name of a buffer-local variable that
1218 is toggled on or off to say whether the minor mode is active or not.
1219
1220 NAME specifies what will appear in the mode line when the minor mode
1221 is active. NAME should be either a string starting with a space, or a
1222 symbol whose value is such a string.
1223
1224 Optional KEYMAP is the keymap for the minor mode that will be added
1225 to `minor-mode-map-alist'.
1226
1227 Optional AFTER specifies that TOGGLE should be added after AFTER
1228 in `minor-mode-alist'.
1229
1230 Optional TOGGLE-FUN is an interactive function to toggle the mode.
1231 It defaults to (and should by convention be) TOGGLE.
1232
1233 If TOGGLE has a non-nil `:included' property, an entry for the mode is
1234 included in the mode-line minor mode menu.
1235 If TOGGLE has a `:menu-tag', that is used for the menu item's label."
1236 (unless (memq toggle minor-mode-list)
1237 (push toggle minor-mode-list))
1238
1239 (unless toggle-fun (setq toggle-fun toggle))
1240 (unless (eq toggle-fun toggle)
1241 (put toggle :minor-mode-function toggle-fun))
1242 ;; Add the name to the minor-mode-alist.
1243 (when name
1244 (let ((existing (assq toggle minor-mode-alist)))
1245 (if existing
1246 (setcdr existing (list name))
1247 (let ((tail minor-mode-alist) found)
1248 (while (and tail (not found))
1249 (if (eq after (caar tail))
1250 (setq found tail)
1251 (setq tail (cdr tail))))
1252 (if found
1253 (let ((rest (cdr found)))
1254 (setcdr found nil)
1255 (nconc found (list (list toggle name)) rest))
1256 (setq minor-mode-alist (cons (list toggle name)
1257 minor-mode-alist)))))))
1258 ;; Add the toggle to the minor-modes menu if requested.
1259 (when (get toggle :included)
1260 (define-key mode-line-mode-menu
1261 (vector toggle)
1262 (list 'menu-item
1263 (concat
1264 (or (get toggle :menu-tag)
1265 (if (stringp name) name (symbol-name toggle)))
1266 (let ((mode-name (if (symbolp name) (symbol-value name))))
1267 (if (and (stringp mode-name) (string-match "[^ ]+" mode-name))
1268 (concat " (" (match-string 0 mode-name) ")"))))
1269 toggle-fun
1270 :button (cons :toggle toggle))))
1271
1272 ;; Add the map to the minor-mode-map-alist.
1273 (when keymap
1274 (let ((existing (assq toggle minor-mode-map-alist)))
1275 (if existing
1276 (setcdr existing keymap)
1277 (let ((tail minor-mode-map-alist) found)
1278 (while (and tail (not found))
1279 (if (eq after (caar tail))
1280 (setq found tail)
1281 (setq tail (cdr tail))))
1282 (if found
1283 (let ((rest (cdr found)))
1284 (setcdr found nil)
1285 (nconc found (list (cons toggle keymap)) rest))
1286 (setq minor-mode-map-alist (cons (cons toggle keymap)
1287 minor-mode-map-alist))))))))
1288 \f
1289 ;;; Load history
1290
1291 ;; (defvar symbol-file-load-history-loaded nil
1292 ;; "Non-nil means we have loaded the file `fns-VERSION.el' in `exec-directory'.
1293 ;; That file records the part of `load-history' for preloaded files,
1294 ;; which is cleared out before dumping to make Emacs smaller.")
1295
1296 ;; (defun load-symbol-file-load-history ()
1297 ;; "Load the file `fns-VERSION.el' in `exec-directory' if not already done.
1298 ;; That file records the part of `load-history' for preloaded files,
1299 ;; which is cleared out before dumping to make Emacs smaller."
1300 ;; (unless symbol-file-load-history-loaded
1301 ;; (load (expand-file-name
1302 ;; ;; fns-XX.YY.ZZ.el does not work on DOS filesystem.
1303 ;; (if (eq system-type 'ms-dos)
1304 ;; "fns.el"
1305 ;; (format "fns-%s.el" emacs-version))
1306 ;; exec-directory)
1307 ;; ;; The file name fns-%s.el already has a .el extension.
1308 ;; nil nil t)
1309 ;; (setq symbol-file-load-history-loaded t)))
1310
1311 (defun symbol-file (symbol &optional type)
1312 "Return the input source in which SYMBOL was defined.
1313 The value is an absolute file name.
1314 It can also be nil, if the definition is not associated with any file.
1315
1316 If TYPE is nil, then any kind of definition is acceptable.
1317 If TYPE is `defun' or `defvar', that specifies function
1318 definition only or variable definition only.
1319 `defface' specifies a face definition only."
1320 (if (and (or (null type) (eq type 'defun))
1321 (symbolp symbol) (fboundp symbol)
1322 (eq 'autoload (car-safe (symbol-function symbol))))
1323 (nth 1 (symbol-function symbol))
1324 (let ((files load-history)
1325 file)
1326 (while files
1327 (if (if type
1328 (if (eq type 'defvar)
1329 ;; Variables are present just as their names.
1330 (member symbol (cdr (car files)))
1331 ;; Other types are represented as (TYPE . NAME).
1332 (member (cons type symbol) (cdr (car files))))
1333 ;; We accept all types, so look for variable def
1334 ;; and then for any other kind.
1335 (or (member symbol (cdr (car files)))
1336 (rassq symbol (cdr (car files)))))
1337 (setq file (car (car files)) files nil))
1338 (setq files (cdr files)))
1339 file)))
1340
1341 ;;;###autoload
1342 (defun locate-library (library &optional nosuffix path interactive-call)
1343 "Show the precise file name of Emacs library LIBRARY.
1344 This command searches the directories in `load-path' like `\\[load-library]'
1345 to find the file that `\\[load-library] RET LIBRARY RET' would load.
1346 Optional second arg NOSUFFIX non-nil means don't add suffixes `load-suffixes'
1347 to the specified name LIBRARY.
1348
1349 If the optional third arg PATH is specified, that list of directories
1350 is used instead of `load-path'.
1351
1352 When called from a program, the file name is normaly returned as a
1353 string. When run interactively, the argument INTERACTIVE-CALL is t,
1354 and the file name is displayed in the echo area."
1355 (interactive (list (completing-read "Locate library: "
1356 'locate-file-completion
1357 (cons load-path (get-load-suffixes)))
1358 nil nil
1359 t))
1360 (let ((file (locate-file library
1361 (or path load-path)
1362 (append (unless nosuffix (get-load-suffixes))
1363 load-file-rep-suffixes))))
1364 (if interactive-call
1365 (if file
1366 (message "Library is file %s" (abbreviate-file-name file))
1367 (message "No library %s in search path" library)))
1368 file))
1369
1370 \f
1371 ;;;; Specifying things to do later.
1372
1373 (defmacro eval-at-startup (&rest body)
1374 "Make arrangements to evaluate BODY when Emacs starts up.
1375 If this is run after Emacs startup, evaluate BODY immediately.
1376 Always returns nil.
1377
1378 This works by adding a function to `before-init-hook'.
1379 That function's doc string says which file created it."
1380 `(progn
1381 (if command-line-processed
1382 (progn . ,body)
1383 (add-hook 'before-init-hook
1384 '(lambda () ,(concat "From " (or load-file-name "no file"))
1385 . ,body)
1386 t))
1387 nil))
1388
1389 (defun eval-after-load (file form)
1390 "Arrange that, if FILE is ever loaded, FORM will be run at that time.
1391 This makes or adds to an entry on `after-load-alist'.
1392 If FILE is already loaded, evaluate FORM right now.
1393 It does nothing if FORM is already on the list for FILE.
1394 FILE must match exactly. Normally FILE is the name of a library,
1395 with no directory or extension specified, since that is how `load'
1396 is normally called.
1397 FILE can also be a feature (i.e. a symbol), in which case FORM is
1398 evaluated whenever that feature is `provide'd."
1399 (let ((elt (assoc file after-load-alist)))
1400 ;; Make sure there is an element for FILE.
1401 (unless elt (setq elt (list file)) (push elt after-load-alist))
1402 ;; Add FORM to the element if it isn't there.
1403 (unless (member form (cdr elt))
1404 (nconc elt (list form))
1405 ;; If the file has been loaded already, run FORM right away.
1406 (if (if (symbolp file)
1407 (featurep file)
1408 ;; Make sure `load-history' contains the files dumped with
1409 ;; Emacs for the case that FILE is one of them.
1410 ;; (load-symbol-file-load-history)
1411 (when (locate-library file)
1412 (assoc (locate-library file) load-history)))
1413 (eval form))))
1414 form)
1415
1416 (defun eval-next-after-load (file)
1417 "Read the following input sexp, and run it whenever FILE is loaded.
1418 This makes or adds to an entry on `after-load-alist'.
1419 FILE should be the name of a library, with no directory name."
1420 (eval-after-load file (read)))
1421 \f
1422 ;;;; Process stuff.
1423
1424 ;; open-network-stream is a wrapper around make-network-process.
1425
1426 (when (featurep 'make-network-process)
1427 (defun open-network-stream (name buffer host service)
1428 "Open a TCP connection for a service to a host.
1429 Returns a subprocess-object to represent the connection.
1430 Input and output work as for subprocesses; `delete-process' closes it.
1431
1432 Args are NAME BUFFER HOST SERVICE.
1433 NAME is name for process. It is modified if necessary to make it unique.
1434 BUFFER is the buffer (or buffer name) to associate with the process.
1435 Process output goes at end of that buffer, unless you specify
1436 an output stream or filter function to handle the output.
1437 BUFFER may be also nil, meaning that this process is not associated
1438 with any buffer.
1439 HOST is name of the host to connect to, or its IP address.
1440 SERVICE is name of the service desired, or an integer specifying
1441 a port number to connect to."
1442 (make-network-process :name name :buffer buffer
1443 :host host :service service)))
1444
1445 ;; compatibility
1446
1447 (make-obsolete 'process-kill-without-query
1448 "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
1449 "22.1")
1450 (defun process-kill-without-query (process &optional flag)
1451 "Say no query needed if PROCESS is running when Emacs is exited.
1452 Optional second argument if non-nil says to require a query.
1453 Value is t if a query was formerly required."
1454 (let ((old (process-query-on-exit-flag process)))
1455 (set-process-query-on-exit-flag process nil)
1456 old))
1457
1458 ;; process plist management
1459
1460 (defun process-get (process propname)
1461 "Return the value of PROCESS' PROPNAME property.
1462 This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'."
1463 (plist-get (process-plist process) propname))
1464
1465 (defun process-put (process propname value)
1466 "Change PROCESS' PROPNAME property to VALUE.
1467 It can be retrieved with `(process-get PROCESS PROPNAME)'."
1468 (set-process-plist process
1469 (plist-put (process-plist process) propname value)))
1470
1471 \f
1472 ;;;; Input and display facilities.
1473
1474 (defvar read-quoted-char-radix 8
1475 "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
1476 Legitimate radix values are 8, 10 and 16.")
1477
1478 (custom-declare-variable-early
1479 'read-quoted-char-radix 8
1480 "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
1481 Legitimate radix values are 8, 10 and 16."
1482 :type '(choice (const 8) (const 10) (const 16))
1483 :group 'editing-basics)
1484
1485 (defun read-quoted-char (&optional prompt)
1486 "Like `read-char', but do not allow quitting.
1487 Also, if the first character read is an octal digit,
1488 we read any number of octal digits and return the
1489 specified character code. Any nondigit terminates the sequence.
1490 If the terminator is RET, it is discarded;
1491 any other terminator is used itself as input.
1492
1493 The optional argument PROMPT specifies a string to use to prompt the user.
1494 The variable `read-quoted-char-radix' controls which radix to use
1495 for numeric input."
1496 (let ((message-log-max nil) done (first t) (code 0) char translated)
1497 (while (not done)
1498 (let ((inhibit-quit first)
1499 ;; Don't let C-h get the help message--only help function keys.
1500 (help-char nil)
1501 (help-form
1502 "Type the special character you want to use,
1503 or the octal character code.
1504 RET terminates the character code and is discarded;
1505 any other non-digit terminates the character code and is then used as input."))
1506 (setq char (read-event (and prompt (format "%s-" prompt)) t))
1507 (if inhibit-quit (setq quit-flag nil)))
1508 ;; Translate TAB key into control-I ASCII character, and so on.
1509 ;; Note: `read-char' does it using the `ascii-character' property.
1510 ;; We could try and use read-key-sequence instead, but then C-q ESC
1511 ;; or C-q C-x might not return immediately since ESC or C-x might be
1512 ;; bound to some prefix in function-key-map or key-translation-map.
1513 (setq translated char)
1514 (let ((translation (lookup-key function-key-map (vector char))))
1515 (if (arrayp translation)
1516 (setq translated (aref translation 0))))
1517 (cond ((null translated))
1518 ((not (integerp translated))
1519 (setq unread-command-events (list char)
1520 done t))
1521 ((/= (logand translated ?\M-\^@) 0)
1522 ;; Turn a meta-character into a character with the 0200 bit set.
1523 (setq code (logior (logand translated (lognot ?\M-\^@)) 128)
1524 done t))
1525 ((and (<= ?0 translated) (< translated (+ ?0 (min 10 read-quoted-char-radix))))
1526 (setq code (+ (* code read-quoted-char-radix) (- translated ?0)))
1527 (and prompt (setq prompt (message "%s %c" prompt translated))))
1528 ((and (<= ?a (downcase translated))
1529 (< (downcase translated) (+ ?a -10 (min 36 read-quoted-char-radix))))
1530 (setq code (+ (* code read-quoted-char-radix)
1531 (+ 10 (- (downcase translated) ?a))))
1532 (and prompt (setq prompt (message "%s %c" prompt translated))))
1533 ((and (not first) (eq translated ?\C-m))
1534 (setq done t))
1535 ((not first)
1536 (setq unread-command-events (list char)
1537 done t))
1538 (t (setq code translated
1539 done t)))
1540 (setq first nil))
1541 code))
1542
1543 (defun read-passwd (prompt &optional confirm default)
1544 "Read a password, prompting with PROMPT, and return it.
1545 If optional CONFIRM is non-nil, read the password twice to make sure.
1546 Optional DEFAULT is a default password to use instead of empty input.
1547
1548 This function echoes `.' for each character that the user types.
1549 The user ends with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line.
1550 C-g quits; if `inhibit-quit' was non-nil around this function,
1551 then it returns nil if the user types C-g.
1552
1553 Once the caller uses the password, it can erase the password
1554 by doing (clear-string STRING)."
1555 (with-local-quit
1556 (if confirm
1557 (let (success)
1558 (while (not success)
1559 (let ((first (read-passwd prompt nil default))
1560 (second (read-passwd "Confirm password: " nil default)))
1561 (if (equal first second)
1562 (progn
1563 (and (arrayp second) (clear-string second))
1564 (setq success first))
1565 (and (arrayp first) (clear-string first))
1566 (and (arrayp second) (clear-string second))
1567 (message "Password not repeated accurately; please start over")
1568 (sit-for 1))))
1569 success)
1570 (let ((pass nil)
1571 (c 0)
1572 (echo-keystrokes 0)
1573 (cursor-in-echo-area t)
1574 (message-log-max nil))
1575 (add-text-properties 0 (length prompt)
1576 minibuffer-prompt-properties prompt)
1577 (while (progn (message "%s%s"
1578 prompt
1579 (make-string (length pass) ?.))
1580 (setq c (read-char-exclusive nil t))
1581 (and (/= c ?\r) (/= c ?\n) (/= c ?\e)))
1582 (clear-this-command-keys)
1583 (if (= c ?\C-u)
1584 (progn
1585 (and (arrayp pass) (clear-string pass))
1586 (setq pass ""))
1587 (if (and (/= c ?\b) (/= c ?\177))
1588 (let* ((new-char (char-to-string c))
1589 (new-pass (concat pass new-char)))
1590 (and (arrayp pass) (clear-string pass))
1591 (clear-string new-char)
1592 (setq c ?\0)
1593 (setq pass new-pass))
1594 (if (> (length pass) 0)
1595 (let ((new-pass (substring pass 0 -1)))
1596 (and (arrayp pass) (clear-string pass))
1597 (setq pass new-pass))))))
1598 (message nil)
1599 (or pass default "")))))
1600
1601 ;; This should be used by `call-interactively' for `n' specs.
1602 (defun read-number (prompt &optional default)
1603 (let ((n nil))
1604 (when default
1605 (setq prompt
1606 (if (string-match "\\(\\):[ \t]*\\'" prompt)
1607 (replace-match (format " (default %s)" default) t t prompt 1)
1608 (replace-regexp-in-string "[ \t]*\\'"
1609 (format " (default %s) " default)
1610 prompt t t))))
1611 (while
1612 (progn
1613 (let ((str (read-from-minibuffer prompt nil nil nil nil
1614 (and default
1615 (number-to-string default)))))
1616 (setq n (cond
1617 ((zerop (length str)) default)
1618 ((stringp str) (read str)))))
1619 (unless (numberp n)
1620 (message "Please enter a number.")
1621 (sit-for 1)
1622 t)))
1623 n))
1624 \f
1625 ;;; Atomic change groups.
1626
1627 (defmacro atomic-change-group (&rest body)
1628 "Perform BODY as an atomic change group.
1629 This means that if BODY exits abnormally,
1630 all of its changes to the current buffer are undone.
1631 This works regardless of whether undo is enabled in the buffer.
1632
1633 This mechanism is transparent to ordinary use of undo;
1634 if undo is enabled in the buffer and BODY succeeds, the
1635 user can undo the change normally."
1636 (declare (indent 0) (debug t))
1637 (let ((handle (make-symbol "--change-group-handle--"))
1638 (success (make-symbol "--change-group-success--")))
1639 `(let ((,handle (prepare-change-group))
1640 (,success nil))
1641 (unwind-protect
1642 (progn
1643 ;; This is inside the unwind-protect because
1644 ;; it enables undo if that was disabled; we need
1645 ;; to make sure that it gets disabled again.
1646 (activate-change-group ,handle)
1647 ,@body
1648 (setq ,success t))
1649 ;; Either of these functions will disable undo
1650 ;; if it was disabled before.
1651 (if ,success
1652 (accept-change-group ,handle)
1653 (cancel-change-group ,handle))))))
1654
1655 (defun prepare-change-group (&optional buffer)
1656 "Return a handle for the current buffer's state, for a change group.
1657 If you specify BUFFER, make a handle for BUFFER's state instead.
1658
1659 Pass the handle to `activate-change-group' afterward to initiate
1660 the actual changes of the change group.
1661
1662 To finish the change group, call either `accept-change-group' or
1663 `cancel-change-group' passing the same handle as argument. Call
1664 `accept-change-group' to accept the changes in the group as final;
1665 call `cancel-change-group' to undo them all. You should use
1666 `unwind-protect' to make sure the group is always finished. The call
1667 to `activate-change-group' should be inside the `unwind-protect'.
1668 Once you finish the group, don't use the handle again--don't try to
1669 finish the same group twice. For a simple example of correct use, see
1670 the source code of `atomic-change-group'.
1671
1672 The handle records only the specified buffer. To make a multibuffer
1673 change group, call this function once for each buffer you want to
1674 cover, then use `nconc' to combine the returned values, like this:
1675
1676 (nconc (prepare-change-group buffer-1)
1677 (prepare-change-group buffer-2))
1678
1679 You can then activate that multibuffer change group with a single
1680 call to `activate-change-group' and finish it with a single call
1681 to `accept-change-group' or `cancel-change-group'."
1682
1683 (if buffer
1684 (list (cons buffer (with-current-buffer buffer buffer-undo-list)))
1685 (list (cons (current-buffer) buffer-undo-list))))
1686
1687 (defun activate-change-group (handle)
1688 "Activate a change group made with `prepare-change-group' (which see)."
1689 (dolist (elt handle)
1690 (with-current-buffer (car elt)
1691 (if (eq buffer-undo-list t)
1692 (setq buffer-undo-list nil)))))
1693
1694 (defun accept-change-group (handle)
1695 "Finish a change group made with `prepare-change-group' (which see).
1696 This finishes the change group by accepting its changes as final."
1697 (dolist (elt handle)
1698 (with-current-buffer (car elt)
1699 (if (eq elt t)
1700 (setq buffer-undo-list t)))))
1701
1702 (defun cancel-change-group (handle)
1703 "Finish a change group made with `prepare-change-group' (which see).
1704 This finishes the change group by reverting all of its changes."
1705 (dolist (elt handle)
1706 (with-current-buffer (car elt)
1707 (setq elt (cdr elt))
1708 (let ((old-car
1709 (if (consp elt) (car elt)))
1710 (old-cdr
1711 (if (consp elt) (cdr elt))))
1712 ;; Temporarily truncate the undo log at ELT.
1713 (when (consp elt)
1714 (setcar elt nil) (setcdr elt nil))
1715 (unless (eq last-command 'undo) (undo-start))
1716 ;; Make sure there's no confusion.
1717 (when (and (consp elt) (not (eq elt (last pending-undo-list))))
1718 (error "Undoing to some unrelated state"))
1719 ;; Undo it all.
1720 (while (listp pending-undo-list) (undo-more 1))
1721 ;; Reset the modified cons cell ELT to its original content.
1722 (when (consp elt)
1723 (setcar elt old-car)
1724 (setcdr elt old-cdr))
1725 ;; Revert the undo info to what it was when we grabbed the state.
1726 (setq buffer-undo-list elt)))))
1727 \f
1728 ;;;; Display-related functions.
1729
1730 ;; For compatibility.
1731 (defalias 'redraw-modeline 'force-mode-line-update)
1732
1733 (defun force-mode-line-update (&optional all)
1734 "Force redisplay of the current buffer's mode line and header line.
1735 With optional non-nil ALL, force redisplay of all mode lines and
1736 header lines. This function also forces recomputation of the
1737 menu bar menus and the frame title."
1738 (if all (save-excursion (set-buffer (other-buffer))))
1739 (set-buffer-modified-p (buffer-modified-p)))
1740
1741 (defun momentary-string-display (string pos &optional exit-char message)
1742 "Momentarily display STRING in the buffer at POS.
1743 Display remains until next event is input.
1744 Optional third arg EXIT-CHAR can be a character, event or event
1745 description list. EXIT-CHAR defaults to SPC. If the input is
1746 EXIT-CHAR it is swallowed; otherwise it is then available as
1747 input (as a command if nothing else).
1748 Display MESSAGE (optional fourth arg) in the echo area.
1749 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
1750 (or exit-char (setq exit-char ?\ ))
1751 (let ((inhibit-read-only t)
1752 ;; Don't modify the undo list at all.
1753 (buffer-undo-list t)
1754 (modified (buffer-modified-p))
1755 (name buffer-file-name)
1756 insert-end)
1757 (unwind-protect
1758 (progn
1759 (save-excursion
1760 (goto-char pos)
1761 ;; defeat file locking... don't try this at home, kids!
1762 (setq buffer-file-name nil)
1763 (insert-before-markers string)
1764 (setq insert-end (point))
1765 ;; If the message end is off screen, recenter now.
1766 (if (< (window-end nil t) insert-end)
1767 (recenter (/ (window-height) 2)))
1768 ;; If that pushed message start off the screen,
1769 ;; scroll to start it at the top of the screen.
1770 (move-to-window-line 0)
1771 (if (> (point) pos)
1772 (progn
1773 (goto-char pos)
1774 (recenter 0))))
1775 (message (or message "Type %s to continue editing.")
1776 (single-key-description exit-char))
1777 (let (char)
1778 (if (integerp exit-char)
1779 (condition-case nil
1780 (progn
1781 (setq char (read-char))
1782 (or (eq char exit-char)
1783 (setq unread-command-events (list char))))
1784 (error
1785 ;; `exit-char' is a character, hence it differs
1786 ;; from char, which is an event.
1787 (setq unread-command-events (list char))))
1788 ;; `exit-char' can be an event, or an event description
1789 ;; list.
1790 (setq char (read-event))
1791 (or (eq char exit-char)
1792 (eq char (event-convert-list exit-char))
1793 (setq unread-command-events (list char))))))
1794 (if insert-end
1795 (save-excursion
1796 (delete-region pos insert-end)))
1797 (setq buffer-file-name name)
1798 (set-buffer-modified-p modified))))
1799
1800 \f
1801 ;;;; Overlay operations
1802
1803 (defun copy-overlay (o)
1804 "Return a copy of overlay O."
1805 (let ((o1 (make-overlay (overlay-start o) (overlay-end o)
1806 ;; FIXME: there's no easy way to find the
1807 ;; insertion-type of the two markers.
1808 (overlay-buffer o)))
1809 (props (overlay-properties o)))
1810 (while props
1811 (overlay-put o1 (pop props) (pop props)))
1812 o1))
1813
1814 (defun remove-overlays (&optional beg end name val)
1815 "Clear BEG and END of overlays whose property NAME has value VAL.
1816 Overlays might be moved and/or split.
1817 BEG and END default respectively to the beginning and end of buffer."
1818 (unless beg (setq beg (point-min)))
1819 (unless end (setq end (point-max)))
1820 (if (< end beg)
1821 (setq beg (prog1 end (setq end beg))))
1822 (save-excursion
1823 (dolist (o (overlays-in beg end))
1824 (when (eq (overlay-get o name) val)
1825 ;; Either push this overlay outside beg...end
1826 ;; or split it to exclude beg...end
1827 ;; or delete it entirely (if it is contained in beg...end).
1828 (if (< (overlay-start o) beg)
1829 (if (> (overlay-end o) end)
1830 (progn
1831 (move-overlay (copy-overlay o)
1832 (overlay-start o) beg)
1833 (move-overlay o end (overlay-end o)))
1834 (move-overlay o (overlay-start o) beg))
1835 (if (> (overlay-end o) end)
1836 (move-overlay o end (overlay-end o))
1837 (delete-overlay o)))))))
1838 \f
1839 ;;;; Miscellanea.
1840
1841 (defvar suspend-hook nil
1842 "Normal hook run by `suspend-emacs', before suspending.")
1843
1844 (defvar suspend-resume-hook nil
1845 "Normal hook run by `suspend-emacs', after Emacs is continued.")
1846
1847 (defvar temp-buffer-show-hook nil
1848 "Normal hook run by `with-output-to-temp-buffer' after displaying the buffer.
1849 When the hook runs, the temporary buffer is current, and the window it
1850 was displayed in is selected. This hook is normally set up with a
1851 function to make the buffer read only, and find function names and
1852 variable names in it, provided the major mode is still Help mode.")
1853
1854 (defvar temp-buffer-setup-hook nil
1855 "Normal hook run by `with-output-to-temp-buffer' at the start.
1856 When the hook runs, the temporary buffer is current.
1857 This hook is normally set up with a function to put the buffer in Help
1858 mode.")
1859
1860 ;; Avoid compiler warnings about this variable,
1861 ;; which has a special meaning on certain system types.
1862 (defvar buffer-file-type nil
1863 "Non-nil if the visited file is a binary file.
1864 This variable is meaningful on MS-DOG and Windows NT.
1865 On those systems, it is automatically local in every buffer.
1866 On other systems, this variable is normally always nil.")
1867
1868 ;; The `assert' macro from the cl package signals
1869 ;; `cl-assertion-failed' at runtime so always define it.
1870 (put 'cl-assertion-failed 'error-conditions '(error))
1871 (put 'cl-assertion-failed 'error-message "Assertion failed")
1872
1873 \f
1874 ;;;; Misc. useful functions.
1875
1876 (defun find-tag-default ()
1877 "Determine default tag to search for, based on text at point.
1878 If there is no plausible default, return nil."
1879 (save-excursion
1880 (while (looking-at "\\sw\\|\\s_")
1881 (forward-char 1))
1882 (if (or (re-search-backward "\\sw\\|\\s_"
1883 (save-excursion (beginning-of-line) (point))
1884 t)
1885 (re-search-forward "\\(\\sw\\|\\s_\\)+"
1886 (save-excursion (end-of-line) (point))
1887 t))
1888 (progn
1889 (goto-char (match-end 0))
1890 (condition-case nil
1891 (buffer-substring-no-properties
1892 (point)
1893 (progn (forward-sexp -1)
1894 (while (looking-at "\\s'")
1895 (forward-char 1))
1896 (point)))
1897 (error nil)))
1898 nil)))
1899
1900 (defun play-sound (sound)
1901 "SOUND is a list of the form `(sound KEYWORD VALUE...)'.
1902 The following keywords are recognized:
1903
1904 :file FILE - read sound data from FILE. If FILE isn't an
1905 absolute file name, it is searched in `data-directory'.
1906
1907 :data DATA - read sound data from string DATA.
1908
1909 Exactly one of :file or :data must be present.
1910
1911 :volume VOL - set volume to VOL. VOL must an integer in the
1912 range 0..100 or a float in the range 0..1.0. If not specified,
1913 don't change the volume setting of the sound device.
1914
1915 :device DEVICE - play sound on DEVICE. If not specified,
1916 a system-dependent default device name is used."
1917 (if (fboundp 'play-sound-internal)
1918 (play-sound-internal sound)
1919 (error "This Emacs binary lacks sound support")))
1920
1921 (defun shell-quote-argument (argument)
1922 "Quote an argument for passing as argument to an inferior shell."
1923 (if (eq system-type 'ms-dos)
1924 ;; Quote using double quotes, but escape any existing quotes in
1925 ;; the argument with backslashes.
1926 (let ((result "")
1927 (start 0)
1928 end)
1929 (if (or (null (string-match "[^\"]" argument))
1930 (< (match-end 0) (length argument)))
1931 (while (string-match "[\"]" argument start)
1932 (setq end (match-beginning 0)
1933 result (concat result (substring argument start end)
1934 "\\" (substring argument end (1+ end)))
1935 start (1+ end))))
1936 (concat "\"" result (substring argument start) "\""))
1937 (if (eq system-type 'windows-nt)
1938 (concat "\"" argument "\"")
1939 (if (equal argument "")
1940 "''"
1941 ;; Quote everything except POSIX filename characters.
1942 ;; This should be safe enough even for really weird shells.
1943 (let ((result "") (start 0) end)
1944 (while (string-match "[^-0-9a-zA-Z_./]" argument start)
1945 (setq end (match-beginning 0)
1946 result (concat result (substring argument start end)
1947 "\\" (substring argument end (1+ end)))
1948 start (1+ end)))
1949 (concat result (substring argument start)))))))
1950
1951 (defun string-or-null-p (object)
1952 "Return t if OBJECT is a string or nil.
1953 Otherwise, return nil."
1954 (or (stringp object) (null object)))
1955
1956 (defun booleanp (object)
1957 "Return non-nil if OBJECT is one of the two canonical boolean values: t or nil."
1958 (memq object '(nil t)))
1959
1960 \f
1961 ;;;; Support for yanking and text properties.
1962
1963 (defvar yank-excluded-properties)
1964
1965 (defun remove-yank-excluded-properties (start end)
1966 "Remove `yank-excluded-properties' between START and END positions.
1967 Replaces `category' properties with their defined properties."
1968 (let ((inhibit-read-only t))
1969 ;; Replace any `category' property with the properties it stands for.
1970 (unless (memq yank-excluded-properties '(t nil))
1971 (save-excursion
1972 (goto-char start)
1973 (while (< (point) end)
1974 (let ((cat (get-text-property (point) 'category))
1975 run-end)
1976 (setq run-end
1977 (next-single-property-change (point) 'category nil end))
1978 (when cat
1979 (let (run-end2 original)
1980 (remove-list-of-text-properties (point) run-end '(category))
1981 (while (< (point) run-end)
1982 (setq run-end2 (next-property-change (point) nil run-end))
1983 (setq original (text-properties-at (point)))
1984 (set-text-properties (point) run-end2 (symbol-plist cat))
1985 (add-text-properties (point) run-end2 original)
1986 (goto-char run-end2))))
1987 (goto-char run-end)))))
1988 (if (eq yank-excluded-properties t)
1989 (set-text-properties start end nil)
1990 (remove-list-of-text-properties start end yank-excluded-properties))))
1991
1992 (defvar yank-undo-function)
1993
1994 (defun insert-for-yank (string)
1995 "Calls `insert-for-yank-1' repetitively for each `yank-handler' segment.
1996
1997 See `insert-for-yank-1' for more details."
1998 (let (to)
1999 (while (setq to (next-single-property-change 0 'yank-handler string))
2000 (insert-for-yank-1 (substring string 0 to))
2001 (setq string (substring string to))))
2002 (insert-for-yank-1 string))
2003
2004 (defun insert-for-yank-1 (string)
2005 "Insert STRING at point, stripping some text properties.
2006
2007 Strip text properties from the inserted text according to
2008 `yank-excluded-properties'. Otherwise just like (insert STRING).
2009
2010 If STRING has a non-nil `yank-handler' property on the first character,
2011 the normal insert behavior is modified in various ways. The value of
2012 the yank-handler property must be a list with one to four elements
2013 with the following format: (FUNCTION PARAM NOEXCLUDE UNDO).
2014 When FUNCTION is present and non-nil, it is called instead of `insert'
2015 to insert the string. FUNCTION takes one argument--the object to insert.
2016 If PARAM is present and non-nil, it replaces STRING as the object
2017 passed to FUNCTION (or `insert'); for example, if FUNCTION is
2018 `yank-rectangle', PARAM may be a list of strings to insert as a
2019 rectangle.
2020 If NOEXCLUDE is present and non-nil, the normal removal of the
2021 yank-excluded-properties is not performed; instead FUNCTION is
2022 responsible for removing those properties. This may be necessary
2023 if FUNCTION adjusts point before or after inserting the object.
2024 If UNDO is present and non-nil, it is a function that will be called
2025 by `yank-pop' to undo the insertion of the current object. It is
2026 called with two arguments, the start and end of the current region.
2027 FUNCTION may set `yank-undo-function' to override the UNDO value."
2028 (let* ((handler (and (stringp string)
2029 (get-text-property 0 'yank-handler string)))
2030 (param (or (nth 1 handler) string))
2031 (opoint (point)))
2032 (setq yank-undo-function t)
2033 (if (nth 0 handler) ;; FUNCTION
2034 (funcall (car handler) param)
2035 (insert param))
2036 (unless (nth 2 handler) ;; NOEXCLUDE
2037 (remove-yank-excluded-properties opoint (point)))
2038 (if (eq yank-undo-function t) ;; not set by FUNCTION
2039 (setq yank-undo-function (nth 3 handler))) ;; UNDO
2040 (if (nth 4 handler) ;; COMMAND
2041 (setq this-command (nth 4 handler)))))
2042
2043 (defun insert-buffer-substring-no-properties (buffer &optional start end)
2044 "Insert before point a substring of BUFFER, without text properties.
2045 BUFFER may be a buffer or a buffer name.
2046 Arguments START and END are character positions specifying the substring.
2047 They default to the values of (point-min) and (point-max) in BUFFER."
2048 (let ((opoint (point)))
2049 (insert-buffer-substring buffer start end)
2050 (let ((inhibit-read-only t))
2051 (set-text-properties opoint (point) nil))))
2052
2053 (defun insert-buffer-substring-as-yank (buffer &optional start end)
2054 "Insert before point a part of BUFFER, stripping some text properties.
2055 BUFFER may be a buffer or a buffer name.
2056 Arguments START and END are character positions specifying the substring.
2057 They default to the values of (point-min) and (point-max) in BUFFER.
2058 Strip text properties from the inserted text according to
2059 `yank-excluded-properties'."
2060 ;; Since the buffer text should not normally have yank-handler properties,
2061 ;; there is no need to handle them here.
2062 (let ((opoint (point)))
2063 (insert-buffer-substring buffer start end)
2064 (remove-yank-excluded-properties opoint (point))))
2065
2066 \f
2067 ;;;; Synchronous shell commands.
2068
2069 (defun start-process-shell-command (name buffer &rest args)
2070 "Start a program in a subprocess. Return the process object for it.
2071 NAME is name for process. It is modified if necessary to make it unique.
2072 BUFFER is the buffer (or buffer name) to associate with the process.
2073 Process output goes at end of that buffer, unless you specify
2074 an output stream or filter function to handle the output.
2075 BUFFER may be also nil, meaning that this process is not associated
2076 with any buffer
2077 COMMAND is the name of a shell command.
2078 Remaining arguments are the arguments for the command.
2079 Wildcards and redirection are handled as usual in the shell.
2080
2081 \(fn NAME BUFFER COMMAND &rest COMMAND-ARGS)"
2082 (cond
2083 ((eq system-type 'vax-vms)
2084 (apply 'start-process name buffer args))
2085 ;; We used to use `exec' to replace the shell with the command,
2086 ;; but that failed to handle (...) and semicolon, etc.
2087 (t
2088 (start-process name buffer shell-file-name shell-command-switch
2089 (mapconcat 'identity args " ")))))
2090
2091 (defun call-process-shell-command (command &optional infile buffer display
2092 &rest args)
2093 "Execute the shell command COMMAND synchronously in separate process.
2094 The remaining arguments are optional.
2095 The program's input comes from file INFILE (nil means `/dev/null').
2096 Insert output in BUFFER before point; t means current buffer;
2097 nil for BUFFER means discard it; 0 means discard and don't wait.
2098 BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
2099 REAL-BUFFER says what to do with standard output, as above,
2100 while STDERR-FILE says what to do with standard error in the child.
2101 STDERR-FILE may be nil (discard standard error output),
2102 t (mix it with ordinary output), or a file name string.
2103
2104 Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
2105 Remaining arguments are strings passed as additional arguments for COMMAND.
2106 Wildcards and redirection are handled as usual in the shell.
2107
2108 If BUFFER is 0, `call-process-shell-command' returns immediately with value nil.
2109 Otherwise it waits for COMMAND to terminate and returns a numeric exit
2110 status or a signal description string.
2111 If you quit, the process is killed with SIGINT, or SIGKILL if you quit again."
2112 (cond
2113 ((eq system-type 'vax-vms)
2114 (apply 'call-process command infile buffer display args))
2115 ;; We used to use `exec' to replace the shell with the command,
2116 ;; but that failed to handle (...) and semicolon, etc.
2117 (t
2118 (call-process shell-file-name
2119 infile buffer display
2120 shell-command-switch
2121 (mapconcat 'identity (cons command args) " ")))))
2122 \f
2123 ;;;; Lisp macros to do various things temporarily.
2124
2125 (defmacro with-current-buffer (buffer &rest body)
2126 "Execute the forms in BODY with BUFFER as the current buffer.
2127 The value returned is the value of the last form in BODY.
2128 See also `with-temp-buffer'."
2129 (declare (indent 1) (debug t))
2130 `(save-current-buffer
2131 (set-buffer ,buffer)
2132 ,@body))
2133
2134 (defmacro with-selected-window (window &rest body)
2135 "Execute the forms in BODY with WINDOW as the selected window.
2136 The value returned is the value of the last form in BODY.
2137
2138 This macro saves and restores the current buffer, since otherwise
2139 its normal operation could potentially make a different
2140 buffer current. It does not alter the buffer list ordering.
2141
2142 This macro saves and restores the selected window, as well as
2143 the selected window in each frame. If the previously selected
2144 window of some frame is no longer live at the end of BODY, that
2145 frame's selected window is left alone. If the selected window is
2146 no longer live, then whatever window is selected at the end of
2147 BODY remains selected.
2148 See also `with-temp-buffer'."
2149 (declare (indent 1) (debug t))
2150 ;; Most of this code is a copy of save-selected-window.
2151 `(let ((save-selected-window-window (selected-window))
2152 ;; It is necessary to save all of these, because calling
2153 ;; select-window changes frame-selected-window for whatever
2154 ;; frame that window is in.
2155 (save-selected-window-alist
2156 (mapcar (lambda (frame) (list frame (frame-selected-window frame)))
2157 (frame-list))))
2158 (save-current-buffer
2159 (unwind-protect
2160 (progn (select-window ,window 'norecord)
2161 ,@body)
2162 (dolist (elt save-selected-window-alist)
2163 (and (frame-live-p (car elt))
2164 (window-live-p (cadr elt))
2165 (set-frame-selected-window (car elt) (cadr elt))))
2166 (if (window-live-p save-selected-window-window)
2167 (select-window save-selected-window-window 'norecord))))))
2168
2169 (defmacro with-temp-file (file &rest body)
2170 "Create a new buffer, evaluate BODY there, and write the buffer to FILE.
2171 The value returned is the value of the last form in BODY.
2172 See also `with-temp-buffer'."
2173 (declare (debug t))
2174 (let ((temp-file (make-symbol "temp-file"))
2175 (temp-buffer (make-symbol "temp-buffer")))
2176 `(let ((,temp-file ,file)
2177 (,temp-buffer
2178 (get-buffer-create (generate-new-buffer-name " *temp file*"))))
2179 (unwind-protect
2180 (prog1
2181 (with-current-buffer ,temp-buffer
2182 ,@body)
2183 (with-current-buffer ,temp-buffer
2184 (widen)
2185 (write-region (point-min) (point-max) ,temp-file nil 0)))
2186 (and (buffer-name ,temp-buffer)
2187 (kill-buffer ,temp-buffer))))))
2188
2189 (defmacro with-temp-message (message &rest body)
2190 "Display MESSAGE temporarily if non-nil while BODY is evaluated.
2191 The original message is restored to the echo area after BODY has finished.
2192 The value returned is the value of the last form in BODY.
2193 MESSAGE is written to the message log buffer if `message-log-max' is non-nil.
2194 If MESSAGE is nil, the echo area and message log buffer are unchanged.
2195 Use a MESSAGE of \"\" to temporarily clear the echo area."
2196 (declare (debug t))
2197 (let ((current-message (make-symbol "current-message"))
2198 (temp-message (make-symbol "with-temp-message")))
2199 `(let ((,temp-message ,message)
2200 (,current-message))
2201 (unwind-protect
2202 (progn
2203 (when ,temp-message
2204 (setq ,current-message (current-message))
2205 (message "%s" ,temp-message))
2206 ,@body)
2207 (and ,temp-message
2208 (if ,current-message
2209 (message "%s" ,current-message)
2210 (message nil)))))))
2211
2212 (defmacro with-temp-buffer (&rest body)
2213 "Create a temporary buffer, and evaluate BODY there like `progn'.
2214 See also `with-temp-file' and `with-output-to-string'."
2215 (declare (indent 0) (debug t))
2216 (let ((temp-buffer (make-symbol "temp-buffer")))
2217 `(let ((,temp-buffer (generate-new-buffer " *temp*")))
2218 (unwind-protect
2219 (with-current-buffer ,temp-buffer
2220 ,@body)
2221 (and (buffer-name ,temp-buffer)
2222 (kill-buffer ,temp-buffer))))))
2223
2224 (defmacro with-output-to-string (&rest body)
2225 "Execute BODY, return the text it sent to `standard-output', as a string."
2226 (declare (indent 0) (debug t))
2227 `(let ((standard-output
2228 (get-buffer-create (generate-new-buffer-name " *string-output*"))))
2229 (let ((standard-output standard-output))
2230 ,@body)
2231 (with-current-buffer standard-output
2232 (prog1
2233 (buffer-string)
2234 (kill-buffer nil)))))
2235
2236 (defmacro with-local-quit (&rest body)
2237 "Execute BODY, allowing quits to terminate BODY but not escape further.
2238 When a quit terminates BODY, `with-local-quit' returns nil but
2239 requests another quit. That quit will be processed, the next time quitting
2240 is allowed once again."
2241 (declare (debug t) (indent 0))
2242 `(condition-case nil
2243 (let ((inhibit-quit nil))
2244 ,@body)
2245 (quit (setq quit-flag t) nil)))
2246
2247 (defmacro while-no-input (&rest body)
2248 "Execute BODY only as long as there's no pending input.
2249 If input arrives, that ends the execution of BODY,
2250 and `while-no-input' returns t. Quitting makes it return nil.
2251 If BODY finishes, `while-no-input' returns whatever value BODY produced."
2252 (declare (debug t) (indent 0))
2253 (let ((catch-sym (make-symbol "input")))
2254 `(with-local-quit
2255 (catch ',catch-sym
2256 (let ((throw-on-input ',catch-sym))
2257 (or (not (sit-for 0 0 t))
2258 ,@body))))))
2259
2260 (defmacro combine-after-change-calls (&rest body)
2261 "Execute BODY, but don't call the after-change functions till the end.
2262 If BODY makes changes in the buffer, they are recorded
2263 and the functions on `after-change-functions' are called several times
2264 when BODY is finished.
2265 The return value is the value of the last form in BODY.
2266
2267 If `before-change-functions' is non-nil, then calls to the after-change
2268 functions can't be deferred, so in that case this macro has no effect.
2269
2270 Do not alter `after-change-functions' or `before-change-functions'
2271 in BODY."
2272 (declare (indent 0) (debug t))
2273 `(unwind-protect
2274 (let ((combine-after-change-calls t))
2275 . ,body)
2276 (combine-after-change-execute)))
2277 \f
2278 ;;;; Constructing completion tables.
2279
2280 (defmacro dynamic-completion-table (fun)
2281 "Use function FUN as a dynamic completion table.
2282 FUN is called with one argument, the string for which completion is required,
2283 and it should return an alist containing all the intended possible
2284 completions. This alist may be a full list of possible completions so that FUN
2285 can ignore the value of its argument. If completion is performed in the
2286 minibuffer, FUN will be called in the buffer from which the minibuffer was
2287 entered.
2288
2289 The result of the `dynamic-completion-table' form is a function
2290 that can be used as the ALIST argument to `try-completion' and
2291 `all-completion'. See Info node `(elisp)Programmed Completion'."
2292 (declare (debug (lambda-expr)))
2293 (let ((win (make-symbol "window"))
2294 (string (make-symbol "string"))
2295 (predicate (make-symbol "predicate"))
2296 (mode (make-symbol "mode")))
2297 `(lambda (,string ,predicate ,mode)
2298 (with-current-buffer (let ((,win (minibuffer-selected-window)))
2299 (if (window-live-p ,win) (window-buffer ,win)
2300 (current-buffer)))
2301 (cond
2302 ((eq ,mode t) (all-completions ,string (,fun ,string) ,predicate))
2303 ((not ,mode) (try-completion ,string (,fun ,string) ,predicate))
2304 (t (test-completion ,string (,fun ,string) ,predicate)))))))
2305
2306 (defmacro lazy-completion-table (var fun)
2307 ;; We used to have `&rest args' where `args' were evaluated late (at the
2308 ;; time of the call to `fun'), which was counter intuitive. But to get
2309 ;; them to be evaluated early, we have to either use lexical-let (which is
2310 ;; not available in subr.el) or use `(lambda (,str) ...) which prevents the use
2311 ;; of lexical-let in the callers.
2312 ;; So we just removed the argument. Callers can then simply use either of:
2313 ;; (lazy-completion-table var (lambda () (fun x y)))
2314 ;; or
2315 ;; (lazy-completion-table var `(lambda () (fun ',x ',y)))
2316 ;; or
2317 ;; (lexical-let ((x x)) ((y y))
2318 ;; (lazy-completion-table var (lambda () (fun x y))))
2319 ;; depending on the behavior they want.
2320 "Initialize variable VAR as a lazy completion table.
2321 If the completion table VAR is used for the first time (e.g., by passing VAR
2322 as an argument to `try-completion'), the function FUN is called with no
2323 arguments. FUN must return the completion table that will be stored in VAR.
2324 If completion is requested in the minibuffer, FUN will be called in the buffer
2325 from which the minibuffer was entered. The return value of
2326 `lazy-completion-table' must be used to initialize the value of VAR.
2327
2328 You should give VAR a non-nil `risky-local-variable' property."
2329 (declare (debug (symbol lambda-expr)))
2330 (let ((str (make-symbol "string")))
2331 `(dynamic-completion-table
2332 (lambda (,str)
2333 (when (functionp ,var)
2334 (setq ,var (,fun)))
2335 ,var))))
2336
2337 (defmacro complete-in-turn (a b)
2338 "Create a completion table that first tries completion in A and then in B.
2339 A and B should not be costly (or side-effecting) expressions."
2340 (declare (debug (def-form def-form)))
2341 `(lambda (string predicate mode)
2342 (cond
2343 ((eq mode t)
2344 (or (all-completions string ,a predicate)
2345 (all-completions string ,b predicate)))
2346 ((eq mode nil)
2347 (or (try-completion string ,a predicate)
2348 (try-completion string ,b predicate)))
2349 (t
2350 (or (test-completion string ,a predicate)
2351 (test-completion string ,b predicate))))))
2352 \f
2353 ;;; Matching and match data.
2354
2355 (defvar save-match-data-internal)
2356
2357 ;; We use save-match-data-internal as the local variable because
2358 ;; that works ok in practice (people should not use that variable elsewhere).
2359 ;; We used to use an uninterned symbol; the compiler handles that properly
2360 ;; now, but it generates slower code.
2361 (defmacro save-match-data (&rest body)
2362 "Execute the BODY forms, restoring the global value of the match data.
2363 The value returned is the value of the last form in BODY."
2364 ;; It is better not to use backquote here,
2365 ;; because that makes a bootstrapping problem
2366 ;; if you need to recompile all the Lisp files using interpreted code.
2367 (declare (indent 0) (debug t))
2368 (list 'let
2369 '((save-match-data-internal (match-data)))
2370 (list 'unwind-protect
2371 (cons 'progn body)
2372 ;; It is safe to free (evaporate) markers immediately here,
2373 ;; as Lisp programs should not copy from save-match-data-internal.
2374 '(set-match-data save-match-data-internal 'evaporate))))
2375
2376 (defun match-string (num &optional string)
2377 "Return string of text matched by last search.
2378 NUM specifies which parenthesized expression in the last regexp.
2379 Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
2380 Zero means the entire text matched by the whole regexp or whole string.
2381 STRING should be given if the last search was by `string-match' on STRING."
2382 (if (match-beginning num)
2383 (if string
2384 (substring string (match-beginning num) (match-end num))
2385 (buffer-substring (match-beginning num) (match-end num)))))
2386
2387 (defun match-string-no-properties (num &optional string)
2388 "Return string of text matched by last search, without text properties.
2389 NUM specifies which parenthesized expression in the last regexp.
2390 Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
2391 Zero means the entire text matched by the whole regexp or whole string.
2392 STRING should be given if the last search was by `string-match' on STRING."
2393 (if (match-beginning num)
2394 (if string
2395 (substring-no-properties string (match-beginning num)
2396 (match-end num))
2397 (buffer-substring-no-properties (match-beginning num)
2398 (match-end num)))))
2399
2400 (defun looking-back (regexp &optional limit greedy)
2401 "Return non-nil if text before point matches regular expression REGEXP.
2402 Like `looking-at' except matches before point, and is slower.
2403 LIMIT if non-nil speeds up the search by specifying how far back the
2404 match can start.
2405
2406 If GREEDY is non-nil, extend the match backwards as far as possible,
2407 stopping when a single additional previous character cannot be part
2408 of a match for REGEXP."
2409 (let ((start (point))
2410 (pos
2411 (save-excursion
2412 (and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)
2413 (point)))))
2414 (if (and greedy pos)
2415 (save-restriction
2416 (narrow-to-region (point-min) start)
2417 (while (and (> pos (point-min))
2418 (save-excursion
2419 (goto-char pos)
2420 (backward-char 1)
2421 (looking-at (concat "\\(?:" regexp "\\)\\'"))))
2422 (setq pos (1- pos)))
2423 (save-excursion
2424 (goto-char pos)
2425 (looking-at (concat "\\(?:" regexp "\\)\\'")))))
2426 (not (null pos))))
2427
2428 (defun subregexp-context-p (regexp pos &optional start)
2429 "Return non-nil if POS is in a normal subregexp context in REGEXP.
2430 A subregexp context is one where a sub-regexp can appear.
2431 A non-subregexp context is for example within brackets, or within a
2432 repetition bounds operator `\\=\\{...\\}', or right after a `\\'.
2433 If START is non-nil, it should be a position in REGEXP, smaller
2434 than POS, and known to be in a subregexp context."
2435 ;; Here's one possible implementation, with the great benefit that it
2436 ;; reuses the regexp-matcher's own parser, so it understands all the
2437 ;; details of the syntax. A disadvantage is that it needs to match the
2438 ;; error string.
2439 (condition-case err
2440 (progn
2441 (string-match (substring regexp (or start 0) pos) "")
2442 t)
2443 (invalid-regexp
2444 (not (member (cadr err) '("Unmatched [ or [^"
2445 "Unmatched \\{"
2446 "Trailing backslash")))))
2447 ;; An alternative implementation:
2448 ;; (defconst re-context-re
2449 ;; (let* ((harmless-ch "[^\\[]")
2450 ;; (harmless-esc "\\\\[^{]")
2451 ;; (class-harmless-ch "[^][]")
2452 ;; (class-lb-harmless "[^]:]")
2453 ;; (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?")
2454 ;; (class-lb (concat "\\[\\(" class-lb-harmless
2455 ;; "\\|" class-lb-colon-maybe-charclass "\\)"))
2456 ;; (class
2457 ;; (concat "\\[^?]?"
2458 ;; "\\(" class-harmless-ch
2459 ;; "\\|" class-lb "\\)*"
2460 ;; "\\[?]")) ; special handling for bare [ at end of re
2461 ;; (braces "\\\\{[0-9,]+\\\\}"))
2462 ;; (concat "\\`\\(" harmless-ch "\\|" harmless-esc
2463 ;; "\\|" class "\\|" braces "\\)*\\'"))
2464 ;; "Matches any prefix that corresponds to a normal subregexp context.")
2465 ;; (string-match re-context-re (substring regexp (or start 0) pos))
2466 )
2467 \f
2468 ;;;; split-string
2469
2470 (defconst split-string-default-separators "[ \f\t\n\r\v]+"
2471 "The default value of separators for `split-string'.
2472
2473 A regexp matching strings of whitespace. May be locale-dependent
2474 \(as yet unimplemented). Should not match non-breaking spaces.
2475
2476 Warning: binding this to a different value and using it as default is
2477 likely to have undesired semantics.")
2478
2479 ;; The specification says that if both SEPARATORS and OMIT-NULLS are
2480 ;; defaulted, OMIT-NULLS should be treated as t. Simplifying the logical
2481 ;; expression leads to the equivalent implementation that if SEPARATORS
2482 ;; is defaulted, OMIT-NULLS is treated as t.
2483 (defun split-string (string &optional separators omit-nulls)
2484 "Split STRING into substrings bounded by matches for SEPARATORS.
2485
2486 The beginning and end of STRING, and each match for SEPARATORS, are
2487 splitting points. The substrings matching SEPARATORS are removed, and
2488 the substrings between the splitting points are collected as a list,
2489 which is returned.
2490
2491 If SEPARATORS is non-nil, it should be a regular expression matching text
2492 which separates, but is not part of, the substrings. If nil it defaults to
2493 `split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and
2494 OMIT-NULLS is forced to t.
2495
2496 If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
2497 that for the default value of SEPARATORS leading and trailing whitespace
2498 are effectively trimmed). If nil, all zero-length substrings are retained,
2499 which correctly parses CSV format, for example.
2500
2501 Note that the effect of `(split-string STRING)' is the same as
2502 `(split-string STRING split-string-default-separators t)'). In the rare
2503 case that you wish to retain zero-length substrings when splitting on
2504 whitespace, use `(split-string STRING split-string-default-separators)'.
2505
2506 Modifies the match data; use `save-match-data' if necessary."
2507 (let ((keep-nulls (not (if separators omit-nulls t)))
2508 (rexp (or separators split-string-default-separators))
2509 (start 0)
2510 notfirst
2511 (list nil))
2512 (while (and (string-match rexp string
2513 (if (and notfirst
2514 (= start (match-beginning 0))
2515 (< start (length string)))
2516 (1+ start) start))
2517 (< start (length string)))
2518 (setq notfirst t)
2519 (if (or keep-nulls (< start (match-beginning 0)))
2520 (setq list
2521 (cons (substring string start (match-beginning 0))
2522 list)))
2523 (setq start (match-end 0)))
2524 (if (or keep-nulls (< start (length string)))
2525 (setq list
2526 (cons (substring string start)
2527 list)))
2528 (nreverse list)))
2529 \f
2530 ;;;; Replacement in strings.
2531
2532 (defun subst-char-in-string (fromchar tochar string &optional inplace)
2533 "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
2534 Unless optional argument INPLACE is non-nil, return a new string."
2535 (let ((i (length string))
2536 (newstr (if inplace string (copy-sequence string))))
2537 (while (> i 0)
2538 (setq i (1- i))
2539 (if (eq (aref newstr i) fromchar)
2540 (aset newstr i tochar)))
2541 newstr))
2542
2543 (defun replace-regexp-in-string (regexp rep string &optional
2544 fixedcase literal subexp start)
2545 "Replace all matches for REGEXP with REP in STRING.
2546
2547 Return a new string containing the replacements.
2548
2549 Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the
2550 arguments with the same names of function `replace-match'. If START
2551 is non-nil, start replacements at that index in STRING.
2552
2553 REP is either a string used as the NEWTEXT arg of `replace-match' or a
2554 function. If it is a function, it is called with the actual text of each
2555 match, and its value is used as the replacement text. When REP is called,
2556 the match-data are the result of matching REGEXP against a substring
2557 of STRING.
2558
2559 To replace only the first match (if any), make REGEXP match up to \\'
2560 and replace a sub-expression, e.g.
2561 (replace-regexp-in-string \"\\\\(foo\\\\).*\\\\'\" \"bar\" \" foo foo\" nil nil 1)
2562 => \" bar foo\"
2563 "
2564
2565 ;; To avoid excessive consing from multiple matches in long strings,
2566 ;; don't just call `replace-match' continually. Walk down the
2567 ;; string looking for matches of REGEXP and building up a (reversed)
2568 ;; list MATCHES. This comprises segments of STRING which weren't
2569 ;; matched interspersed with replacements for segments that were.
2570 ;; [For a `large' number of replacements it's more efficient to
2571 ;; operate in a temporary buffer; we can't tell from the function's
2572 ;; args whether to choose the buffer-based implementation, though it
2573 ;; might be reasonable to do so for long enough STRING.]
2574 (let ((l (length string))
2575 (start (or start 0))
2576 matches str mb me)
2577 (save-match-data
2578 (while (and (< start l) (string-match regexp string start))
2579 (setq mb (match-beginning 0)
2580 me (match-end 0))
2581 ;; If we matched the empty string, make sure we advance by one char
2582 (when (= me mb) (setq me (min l (1+ mb))))
2583 ;; Generate a replacement for the matched substring.
2584 ;; Operate only on the substring to minimize string consing.
2585 ;; Set up match data for the substring for replacement;
2586 ;; presumably this is likely to be faster than munging the
2587 ;; match data directly in Lisp.
2588 (string-match regexp (setq str (substring string mb me)))
2589 (setq matches
2590 (cons (replace-match (if (stringp rep)
2591 rep
2592 (funcall rep (match-string 0 str)))
2593 fixedcase literal str subexp)
2594 (cons (substring string start mb) ; unmatched prefix
2595 matches)))
2596 (setq start me))
2597 ;; Reconstruct a string from the pieces.
2598 (setq matches (cons (substring string start l) matches)) ; leftover
2599 (apply #'concat (nreverse matches)))))
2600 \f
2601 ;;;; invisibility specs
2602
2603 (defun add-to-invisibility-spec (element)
2604 "Add ELEMENT to `buffer-invisibility-spec'.
2605 See documentation for `buffer-invisibility-spec' for the kind of elements
2606 that can be added."
2607 (if (eq buffer-invisibility-spec t)
2608 (setq buffer-invisibility-spec (list t)))
2609 (setq buffer-invisibility-spec
2610 (cons element buffer-invisibility-spec)))
2611
2612 (defun remove-from-invisibility-spec (element)
2613 "Remove ELEMENT from `buffer-invisibility-spec'."
2614 (if (consp buffer-invisibility-spec)
2615 (setq buffer-invisibility-spec (delete element buffer-invisibility-spec))))
2616 \f
2617 ;;;; Syntax tables.
2618
2619 (defmacro with-syntax-table (table &rest body)
2620 "Evaluate BODY with syntax table of current buffer set to TABLE.
2621 The syntax table of the current buffer is saved, BODY is evaluated, and the
2622 saved table is restored, even in case of an abnormal exit.
2623 Value is what BODY returns."
2624 (declare (debug t))
2625 (let ((old-table (make-symbol "table"))
2626 (old-buffer (make-symbol "buffer")))
2627 `(let ((,old-table (syntax-table))
2628 (,old-buffer (current-buffer)))
2629 (unwind-protect
2630 (progn
2631 (set-syntax-table ,table)
2632 ,@body)
2633 (save-current-buffer
2634 (set-buffer ,old-buffer)
2635 (set-syntax-table ,old-table))))))
2636
2637 (defun make-syntax-table (&optional oldtable)
2638 "Return a new syntax table.
2639 Create a syntax table which inherits from OLDTABLE (if non-nil) or
2640 from `standard-syntax-table' otherwise."
2641 (let ((table (make-char-table 'syntax-table nil)))
2642 (set-char-table-parent table (or oldtable (standard-syntax-table)))
2643 table))
2644
2645 (defun syntax-after (pos)
2646 "Return the raw syntax of the char after POS.
2647 If POS is outside the buffer's accessible portion, return nil."
2648 (unless (or (< pos (point-min)) (>= pos (point-max)))
2649 (let ((st (if parse-sexp-lookup-properties
2650 (get-char-property pos 'syntax-table))))
2651 (if (consp st) st
2652 (aref (or st (syntax-table)) (char-after pos))))))
2653
2654 (defun syntax-class (syntax)
2655 "Return the syntax class part of the syntax descriptor SYNTAX.
2656 If SYNTAX is nil, return nil."
2657 (and syntax (logand (car syntax) 65535)))
2658 \f
2659 ;;;; Text clones
2660
2661 (defun text-clone-maintain (ol1 after beg end &optional len)
2662 "Propagate the changes made under the overlay OL1 to the other clones.
2663 This is used on the `modification-hooks' property of text clones."
2664 (when (and after (not undo-in-progress) (overlay-start ol1))
2665 (let ((margin (if (overlay-get ol1 'text-clone-spreadp) 1 0)))
2666 (setq beg (max beg (+ (overlay-start ol1) margin)))
2667 (setq end (min end (- (overlay-end ol1) margin)))
2668 (when (<= beg end)
2669 (save-excursion
2670 (when (overlay-get ol1 'text-clone-syntax)
2671 ;; Check content of the clone's text.
2672 (let ((cbeg (+ (overlay-start ol1) margin))
2673 (cend (- (overlay-end ol1) margin)))
2674 (goto-char cbeg)
2675 (save-match-data
2676 (if (not (re-search-forward
2677 (overlay-get ol1 'text-clone-syntax) cend t))
2678 ;; Mark the overlay for deletion.
2679 (overlay-put ol1 'text-clones nil)
2680 (when (< (match-end 0) cend)
2681 ;; Shrink the clone at its end.
2682 (setq end (min end (match-end 0)))
2683 (move-overlay ol1 (overlay-start ol1)
2684 (+ (match-end 0) margin)))
2685 (when (> (match-beginning 0) cbeg)
2686 ;; Shrink the clone at its beginning.
2687 (setq beg (max (match-beginning 0) beg))
2688 (move-overlay ol1 (- (match-beginning 0) margin)
2689 (overlay-end ol1)))))))
2690 ;; Now go ahead and update the clones.
2691 (let ((head (- beg (overlay-start ol1)))
2692 (tail (- (overlay-end ol1) end))
2693 (str (buffer-substring beg end))
2694 (nothing-left t)
2695 (inhibit-modification-hooks t))
2696 (dolist (ol2 (overlay-get ol1 'text-clones))
2697 (let ((oe (overlay-end ol2)))
2698 (unless (or (eq ol1 ol2) (null oe))
2699 (setq nothing-left nil)
2700 (let ((mod-beg (+ (overlay-start ol2) head)))
2701 ;;(overlay-put ol2 'modification-hooks nil)
2702 (goto-char (- (overlay-end ol2) tail))
2703 (unless (> mod-beg (point))
2704 (save-excursion (insert str))
2705 (delete-region mod-beg (point)))
2706 ;;(overlay-put ol2 'modification-hooks '(text-clone-maintain))
2707 ))))
2708 (if nothing-left (delete-overlay ol1))))))))
2709
2710 (defun text-clone-create (start end &optional spreadp syntax)
2711 "Create a text clone of START...END at point.
2712 Text clones are chunks of text that are automatically kept identical:
2713 changes done to one of the clones will be immediately propagated to the other.
2714
2715 The buffer's content at point is assumed to be already identical to
2716 the one between START and END.
2717 If SYNTAX is provided it's a regexp that describes the possible text of
2718 the clones; the clone will be shrunk or killed if necessary to ensure that
2719 its text matches the regexp.
2720 If SPREADP is non-nil it indicates that text inserted before/after the
2721 clone should be incorporated in the clone."
2722 ;; To deal with SPREADP we can either use an overlay with `nil t' along
2723 ;; with insert-(behind|in-front-of)-hooks or use a slightly larger overlay
2724 ;; (with a one-char margin at each end) with `t nil'.
2725 ;; We opted for a larger overlay because it behaves better in the case
2726 ;; where the clone is reduced to the empty string (we want the overlay to
2727 ;; stay when the clone's content is the empty string and we want to use
2728 ;; `evaporate' to make sure those overlays get deleted when needed).
2729 ;;
2730 (let* ((pt-end (+ (point) (- end start)))
2731 (start-margin (if (or (not spreadp) (bobp) (<= start (point-min)))
2732 0 1))
2733 (end-margin (if (or (not spreadp)
2734 (>= pt-end (point-max))
2735 (>= start (point-max)))
2736 0 1))
2737 (ol1 (make-overlay (- start start-margin) (+ end end-margin) nil t))
2738 (ol2 (make-overlay (- (point) start-margin) (+ pt-end end-margin) nil t))
2739 (dups (list ol1 ol2)))
2740 (overlay-put ol1 'modification-hooks '(text-clone-maintain))
2741 (when spreadp (overlay-put ol1 'text-clone-spreadp t))
2742 (when syntax (overlay-put ol1 'text-clone-syntax syntax))
2743 ;;(overlay-put ol1 'face 'underline)
2744 (overlay-put ol1 'evaporate t)
2745 (overlay-put ol1 'text-clones dups)
2746 ;;
2747 (overlay-put ol2 'modification-hooks '(text-clone-maintain))
2748 (when spreadp (overlay-put ol2 'text-clone-spreadp t))
2749 (when syntax (overlay-put ol2 'text-clone-syntax syntax))
2750 ;;(overlay-put ol2 'face 'underline)
2751 (overlay-put ol2 'evaporate t)
2752 (overlay-put ol2 'text-clones dups)))
2753 \f
2754 ;;;; Mail user agents.
2755
2756 ;; Here we include just enough for other packages to be able
2757 ;; to define them.
2758
2759 (defun define-mail-user-agent (symbol composefunc sendfunc
2760 &optional abortfunc hookvar)
2761 "Define a symbol to identify a mail-sending package for `mail-user-agent'.
2762
2763 SYMBOL can be any Lisp symbol. Its function definition and/or
2764 value as a variable do not matter for this usage; we use only certain
2765 properties on its property list, to encode the rest of the arguments.
2766
2767 COMPOSEFUNC is program callable function that composes an outgoing
2768 mail message buffer. This function should set up the basics of the
2769 buffer without requiring user interaction. It should populate the
2770 standard mail headers, leaving the `to:' and `subject:' headers blank
2771 by default.
2772
2773 COMPOSEFUNC should accept several optional arguments--the same
2774 arguments that `compose-mail' takes. See that function's documentation.
2775
2776 SENDFUNC is the command a user would run to send the message.
2777
2778 Optional ABORTFUNC is the command a user would run to abort the
2779 message. For mail packages that don't have a separate abort function,
2780 this can be `kill-buffer' (the equivalent of omitting this argument).
2781
2782 Optional HOOKVAR is a hook variable that gets run before the message
2783 is actually sent. Callers that use the `mail-user-agent' may
2784 install a hook function temporarily on this hook variable.
2785 If HOOKVAR is nil, `mail-send-hook' is used.
2786
2787 The properties used on SYMBOL are `composefunc', `sendfunc',
2788 `abortfunc', and `hookvar'."
2789 (put symbol 'composefunc composefunc)
2790 (put symbol 'sendfunc sendfunc)
2791 (put symbol 'abortfunc (or abortfunc 'kill-buffer))
2792 (put symbol 'hookvar (or hookvar 'mail-send-hook)))
2793 \f
2794 ;;;; Progress reporters.
2795
2796 ;; Progress reporter has the following structure:
2797 ;;
2798 ;; (NEXT-UPDATE-VALUE . [NEXT-UPDATE-TIME
2799 ;; MIN-VALUE
2800 ;; MAX-VALUE
2801 ;; MESSAGE
2802 ;; MIN-CHANGE
2803 ;; MIN-TIME])
2804 ;;
2805 ;; This weirdeness is for optimization reasons: we want
2806 ;; `progress-reporter-update' to be as fast as possible, so
2807 ;; `(car reporter)' is better than `(aref reporter 0)'.
2808 ;;
2809 ;; NEXT-UPDATE-TIME is a float. While `float-time' loses a couple
2810 ;; digits of precision, it doesn't really matter here. On the other
2811 ;; hand, it greatly simplifies the code.
2812
2813 (defsubst progress-reporter-update (reporter value)
2814 "Report progress of an operation in the echo area.
2815 However, if the change since last echo area update is too small
2816 or not enough time has passed, then do nothing (see
2817 `make-progress-reporter' for details).
2818
2819 First parameter, REPORTER, should be the result of a call to
2820 `make-progress-reporter'. Second, VALUE, determines the actual
2821 progress of operation; it must be between MIN-VALUE and MAX-VALUE
2822 as passed to `make-progress-reporter'.
2823
2824 This function is very inexpensive, you may not bother how often
2825 you call it."
2826 (when (>= value (car reporter))
2827 (progress-reporter-do-update reporter value)))
2828
2829 (defun make-progress-reporter (message min-value max-value
2830 &optional current-value
2831 min-change min-time)
2832 "Return progress reporter object to be used with `progress-reporter-update'.
2833
2834 MESSAGE is shown in the echo area. When at least 1% of operation
2835 is complete, the exact percentage will be appended to the
2836 MESSAGE. When you call `progress-reporter-done', word \"done\"
2837 is printed after the MESSAGE. You can change MESSAGE of an
2838 existing progress reporter with `progress-reporter-force-update'.
2839
2840 MIN-VALUE and MAX-VALUE designate starting (0% complete) and
2841 final (100% complete) states of operation. The latter should be
2842 larger; if this is not the case, then simply negate all values.
2843 Optional CURRENT-VALUE specifies the progress by the moment you
2844 call this function. You should omit it or set it to nil in most
2845 cases since it defaults to MIN-VALUE.
2846
2847 Optional MIN-CHANGE determines the minimal change in percents to
2848 report (default is 1%.) Optional MIN-TIME specifies the minimal
2849 time before echo area updates (default is 0.2 seconds.) If
2850 `float-time' function is not present, then time is not tracked
2851 at all. If OS is not capable of measuring fractions of seconds,
2852 then this parameter is effectively rounded up."
2853
2854 (unless min-time
2855 (setq min-time 0.2))
2856 (let ((reporter
2857 (cons min-value ;; Force a call to `message' now
2858 (vector (if (and (fboundp 'float-time)
2859 (>= min-time 0.02))
2860 (float-time) nil)
2861 min-value
2862 max-value
2863 message
2864 (if min-change (max (min min-change 50) 1) 1)
2865 min-time))))
2866 (progress-reporter-update reporter (or current-value min-value))
2867 reporter))
2868
2869 (defun progress-reporter-force-update (reporter value &optional new-message)
2870 "Report progress of an operation in the echo area unconditionally.
2871
2872 First two parameters are the same as for
2873 `progress-reporter-update'. Optional NEW-MESSAGE allows you to
2874 change the displayed message."
2875 (let ((parameters (cdr reporter)))
2876 (when new-message
2877 (aset parameters 3 new-message))
2878 (when (aref parameters 0)
2879 (aset parameters 0 (float-time)))
2880 (progress-reporter-do-update reporter value)))
2881
2882 (defun progress-reporter-do-update (reporter value)
2883 (let* ((parameters (cdr reporter))
2884 (min-value (aref parameters 1))
2885 (max-value (aref parameters 2))
2886 (one-percent (/ (- max-value min-value) 100.0))
2887 (percentage (if (= max-value min-value)
2888 0
2889 (truncate (/ (- value min-value) one-percent))))
2890 (update-time (aref parameters 0))
2891 (current-time (float-time))
2892 (enough-time-passed
2893 ;; See if enough time has passed since the last update.
2894 (or (not update-time)
2895 (when (>= current-time update-time)
2896 ;; Calculate time for the next update
2897 (aset parameters 0 (+ update-time (aref parameters 5)))))))
2898 ;;
2899 ;; Calculate NEXT-UPDATE-VALUE. If we are not going to print
2900 ;; message this time because not enough time has passed, then use
2901 ;; 1 instead of MIN-CHANGE. This makes delays between echo area
2902 ;; updates closer to MIN-TIME.
2903 (setcar reporter
2904 (min (+ min-value (* (+ percentage
2905 (if enough-time-passed
2906 (aref parameters 4) ;; MIN-CHANGE
2907 1))
2908 one-percent))
2909 max-value))
2910 (when (integerp value)
2911 (setcar reporter (ceiling (car reporter))))
2912 ;;
2913 ;; Only print message if enough time has passed
2914 (when enough-time-passed
2915 (if (> percentage 0)
2916 (message "%s%d%%" (aref parameters 3) percentage)
2917 (message "%s" (aref parameters 3))))))
2918
2919 (defun progress-reporter-done (reporter)
2920 "Print reporter's message followed by word \"done\" in echo area."
2921 (message "%sdone" (aref (cdr reporter) 3)))
2922
2923 (defmacro dotimes-with-progress-reporter (spec message &rest body)
2924 "Loop a certain number of times and report progress in the echo area.
2925 Evaluate BODY with VAR bound to successive integers running from
2926 0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get
2927 the return value (nil if RESULT is omitted).
2928
2929 At each iteration MESSAGE followed by progress percentage is
2930 printed in the echo area. After the loop is finished, MESSAGE
2931 followed by word \"done\" is printed. This macro is a
2932 convenience wrapper around `make-progress-reporter' and friends.
2933
2934 \(fn (VAR COUNT [RESULT]) MESSAGE BODY...)"
2935 (declare (indent 2) (debug ((symbolp form &optional form) form body)))
2936 (let ((temp (make-symbol "--dotimes-temp--"))
2937 (temp2 (make-symbol "--dotimes-temp2--"))
2938 (start 0)
2939 (end (nth 1 spec)))
2940 `(let ((,temp ,end)
2941 (,(car spec) ,start)
2942 (,temp2 (make-progress-reporter ,message ,start ,end)))
2943 (while (< ,(car spec) ,temp)
2944 ,@body
2945 (progress-reporter-update ,temp2
2946 (setq ,(car spec) (1+ ,(car spec)))))
2947 (progress-reporter-done ,temp2)
2948 nil ,@(cdr (cdr spec)))))
2949
2950 \f
2951 ;;;; Comparing version strings.
2952
2953 (defvar version-separator "."
2954 "*Specify the string used to separate the version elements.
2955
2956 Usually the separator is \".\", but it can be any other string.")
2957
2958
2959 (defvar version-regexp-alist
2960 '(("^[-_+ ]?a\\(lpha\\)?$" . -3)
2961 ("^[-_+]$" . -3) ; treat "1.2.3-20050920" and "1.2-3" as alpha releases
2962 ("^[-_+ ]cvs$" . -3) ; treat "1.2.3-CVS" as alpha release
2963 ("^[-_+ ]?b\\(eta\\)?$" . -2)
2964 ("^[-_+ ]?\\(pre\\|rc\\)$" . -1))
2965 "*Specify association between non-numeric version part and a priority.
2966
2967 This association is used to handle version string like \"1.0pre2\",
2968 \"0.9alpha1\", etc. It's used by `version-to-list' (which see) to convert the
2969 non-numeric part to an integer. For example:
2970
2971 String Version Integer List Version
2972 \"1.0pre2\" (1 0 -1 2)
2973 \"1.0PRE2\" (1 0 -1 2)
2974 \"22.8beta3\" (22 8 -2 3)
2975 \"22.8 Beta3\" (22 8 -2 3)
2976 \"0.9alpha1\" (0 9 -3 1)
2977 \"0.9AlphA1\" (0 9 -3 1)
2978 \"0.9 alpha\" (0 9 -3)
2979
2980 Each element has the following form:
2981
2982 (REGEXP . PRIORITY)
2983
2984 Where:
2985
2986 REGEXP regexp used to match non-numeric part of a version string.
2987 It should begin with a `^' anchor and end with a `$' to
2988 prevent false hits. Letter-case is ignored while matching
2989 REGEXP.
2990
2991 PRIORITY negative integer which indicate the non-numeric priority.")
2992
2993
2994 (defun version-to-list (ver)
2995 "Convert version string VER into an integer list.
2996
2997 The version syntax is given by the following EBNF:
2998
2999 VERSION ::= NUMBER ( SEPARATOR NUMBER )*.
3000
3001 NUMBER ::= (0|1|2|3|4|5|6|7|8|9)+.
3002
3003 SEPARATOR ::= `version-separator' (which see)
3004 | `version-regexp-alist' (which see).
3005
3006 The NUMBER part is optional if SEPARATOR is a match for an element
3007 in `version-regexp-alist'.
3008
3009 As an example of valid version syntax:
3010
3011 1.0pre2 1.0.7.5 22.8beta3 0.9alpha1 6.9.30Beta
3012
3013 As an example of invalid version syntax:
3014
3015 1.0prepre2 1.0..7.5 22.8X3 alpha3.2 .5
3016
3017 As an example of version convertion:
3018
3019 String Version Integer List Version
3020 \"1.0.7.5\" (1 0 7 5)
3021 \"1.0pre2\" (1 0 -1 2)
3022 \"1.0PRE2\" (1 0 -1 2)
3023 \"22.8beta3\" (22 8 -2 3)
3024 \"22.8Beta3\" (22 8 -2 3)
3025 \"0.9alpha1\" (0 9 -3 1)
3026 \"0.9AlphA1\" (0 9 -3 1)
3027 \"0.9alpha\" (0 9 -3)
3028
3029 See documentation for `version-separator' and `version-regexp-alist'."
3030 (or (and (stringp ver) (> (length ver) 0))
3031 (error "Invalid version string: '%s'" ver))
3032 ;; Change .x.y to 0.x.y
3033 (if (and (>= (length ver) (length version-separator))
3034 (string-equal (substring ver 0 (length version-separator))
3035 version-separator))
3036 (setq ver (concat "0" ver)))
3037 (save-match-data
3038 (let ((i 0)
3039 (case-fold-search t) ; ignore case in matching
3040 lst s al)
3041 (while (and (setq s (string-match "[0-9]+" ver i))
3042 (= s i))
3043 ;; handle numeric part
3044 (setq lst (cons (string-to-number (substring ver i (match-end 0)))
3045 lst)
3046 i (match-end 0))
3047 ;; handle non-numeric part
3048 (when (and (setq s (string-match "[^0-9]+" ver i))
3049 (= s i))
3050 (setq s (substring ver i (match-end 0))
3051 i (match-end 0))
3052 ;; handle alpha, beta, pre, etc. separator
3053 (unless (string= s version-separator)
3054 (setq al version-regexp-alist)
3055 (while (and al (not (string-match (caar al) s)))
3056 (setq al (cdr al)))
3057 (or al (error "Invalid version syntax: '%s'" ver))
3058 (setq lst (cons (cdar al) lst)))))
3059 (if (null lst)
3060 (error "Invalid version syntax: '%s'" ver)
3061 (nreverse lst)))))
3062
3063
3064 (defun version-list-< (l1 l2)
3065 "Return t if integer list L1 is lesser than L2.
3066
3067 Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0),
3068 etc. That is, the trailing zeroes are irrelevant. Also, integer
3069 list (1) is greater than (1 -1) which is greater than (1 -2)
3070 which is greater than (1 -3)."
3071 (while (and l1 l2 (= (car l1) (car l2)))
3072 (setq l1 (cdr l1)
3073 l2 (cdr l2)))
3074 (cond
3075 ;; l1 not null and l2 not null
3076 ((and l1 l2) (< (car l1) (car l2)))
3077 ;; l1 null and l2 null ==> l1 length = l2 length
3078 ((and (null l1) (null l2)) nil)
3079 ;; l1 not null and l2 null ==> l1 length > l2 length
3080 (l1 (< (version-list-not-zero l1) 0))
3081 ;; l1 null and l2 not null ==> l2 length > l1 length
3082 (t (< 0 (version-list-not-zero l2)))))
3083
3084
3085 (defun version-list-= (l1 l2)
3086 "Return t if integer list L1 is equal to L2.
3087
3088 Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0),
3089 etc. That is, the trailing zeroes are irrelevant. Also, integer
3090 list (1) is greater than (1 -1) which is greater than (1 -2)
3091 which is greater than (1 -3)."
3092 (while (and l1 l2 (= (car l1) (car l2)))
3093 (setq l1 (cdr l1)
3094 l2 (cdr l2)))
3095 (cond
3096 ;; l1 not null and l2 not null
3097 ((and l1 l2) nil)
3098 ;; l1 null and l2 null ==> l1 length = l2 length
3099 ((and (null l1) (null l2)))
3100 ;; l1 not null and l2 null ==> l1 length > l2 length
3101 (l1 (zerop (version-list-not-zero l1)))
3102 ;; l1 null and l2 not null ==> l2 length > l1 length
3103 (t (zerop (version-list-not-zero l2)))))
3104
3105
3106 (defun version-list-<= (l1 l2)
3107 "Return t if integer list L1 is lesser than or equal to L2.
3108
3109 Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0),
3110 etc. That is, the trailing zeroes are irrelevant. Also, integer
3111 list (1) is greater than (1 -1) which is greater than (1 -2)
3112 which is greater than (1 -3)."
3113 (while (and l1 l2 (= (car l1) (car l2)))
3114 (setq l1 (cdr l1)
3115 l2 (cdr l2)))
3116 (cond
3117 ;; l1 not null and l2 not null
3118 ((and l1 l2) (< (car l1) (car l2)))
3119 ;; l1 null and l2 null ==> l1 length = l2 length
3120 ((and (null l1) (null l2)))
3121 ;; l1 not null and l2 null ==> l1 length > l2 length
3122 (l1 (<= (version-list-not-zero l1) 0))
3123 ;; l1 null and l2 not null ==> l2 length > l1 length
3124 (t (<= 0 (version-list-not-zero l2)))))
3125
3126 (defun version-list-not-zero (lst)
3127 "Return the first non-zero element of integer list LST.
3128
3129 If all LST elements are zeroes or LST is nil, return zero."
3130 (while (and lst (zerop (car lst)))
3131 (setq lst (cdr lst)))
3132 (if lst
3133 (car lst)
3134 ;; there is no element different of zero
3135 0))
3136
3137
3138 (defun version< (v1 v2)
3139 "Return t if version V1 is lesser than V2.
3140
3141 Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
3142 etc. That is, the trailing \".0\"s are irrelevant. Also, version string \"1\"
3143 is greater than \"1pre\" which is greater than \"1beta\" which is greater than
3144 \"1alpha\"."
3145 (version-list-< (version-to-list v1) (version-to-list v2)))
3146
3147
3148 (defun version<= (v1 v2)
3149 "Return t if version V1 is lesser than or equal to V2.
3150
3151 Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
3152 etc. That is, the trailing \".0\"s are irrelevant. Also, version string \"1\"
3153 is greater than \"1pre\" which is greater than \"1beta\" which is greater than
3154 \"1alpha\"."
3155 (version-list-<= (version-to-list v1) (version-to-list v2)))
3156
3157 (defun version= (v1 v2)
3158 "Return t if version V1 is equal to V2.
3159
3160 Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
3161 etc. That is, the trailing \".0\"s are irrelevant. Also, version string \"1\"
3162 is greater than \"1pre\" which is greater than \"1beta\" which is greater than
3163 \"1alpha\"."
3164 (version-list-= (version-to-list v1) (version-to-list v2)))
3165
3166
3167
3168 ;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc
3169 ;;; subr.el ends here