(batch-update-autoloads): Add missing close paren.
[bpt/emacs.git] / lisp / subr.el
CommitLineData
c88ab9ce 1;;; subr.el --- basic lisp subroutines for Emacs
630cc463 2
492878e4 3;;; Copyright (C) 1985, 1986, 1992 Free Software Foundation, Inc.
be9b65ac
DL
4
5;; This file is part of GNU Emacs.
6
7;; GNU Emacs is free software; you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
492878e4 9;; the Free Software Foundation; either version 2, or (at your option)
be9b65ac
DL
10;; any later version.
11
12;; GNU Emacs is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with GNU Emacs; see the file COPYING. If not, write to
19;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20
630cc463 21;;; Code:
be9b65ac 22
9a5336ae
JB
23\f
24;;;; Lisp language features.
25
26(defmacro lambda (&rest cdr)
27 "Return a lambda expression.
28A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
29self-quoting; the result of evaluating the lambda expression is the
30expression itself. The lambda expression may then be treated as a
31function, i. e. stored as the function value of a symbol, passed to
32funcall or mapcar, etcetera.
33ARGS should take the same form as an argument list for a `defun'.
34DOCSTRING should be a string, as described for `defun'. It may be omitted.
35INTERACTIVE should be a call to the function `interactive', which see.
36It may also be omitted.
37BODY should be a list of lisp expressions."
38 ;; Note that this definition should not use backquotes; subr.el should not
39 ;; depend on backquote.el.
40 (list 'function (cons 'lambda cdr)))
41
42;;(defmacro defun-inline (name args &rest body)
43;; "Create an \"inline defun\" (actually a macro).
44;;Use just like `defun'."
45;; (nconc (list 'defmacro name '(&rest args))
46;; (if (stringp (car body))
47;; (prog1 (list (car body))
48;; (setq body (or (cdr body) body))))
49;; (list (list 'cons (list 'quote
50;; (cons 'lambda (cons args body)))
51;; 'args))))
52
53\f
54;;;; Window tree functions.
55
492878e4 56(defun one-window-p (&optional nomini)
be9b65ac
DL
57 "Returns non-nil if there is only one window.
58Optional arg NOMINI non-nil means don't count the minibuffer
59even if it is active."
492878e4
JB
60 (let ((base-window (selected-window)))
61 (if (and nomini (eq base-window (minibuffer-window)))
62 (setq base-window (next-window base-window)))
63 (eq base-window
64 (next-window base-window (if nomini 'arg)))))
be9b65ac 65
0cc89026 66(defun walk-windows (proc &optional minibuf all-frames)
be9b65ac
DL
67 "Cycle through all visible windows, calling PROC for each one.
68PROC is called with a window as argument.
69Optional second arg MINIBUF t means count the minibuffer window
70even if not active. If MINIBUF is neither t nor nil it means
71not to count the minibuffer even if it is active.
f1f2d09a
RS
72
73Optional third arg ALL-FRAMES, if t, means include all frames.
74ALL-FRAMES nil or omitted means cycle within the selected frame,
75but include the minibuffer window (if MINIBUF says so) that that
76frame uses, even if it is on another frame.
77If ALL-FRAMES is neither nil nor t, stick strictly to the selected frame."
7a18f5c2
RS
78 ;; If we start from the minibuffer window, don't fail to come back to it.
79 (if (window-minibuffer-p (selected-window))
80 (setq minibuf t))
be9b65ac
DL
81 (let* ((walk-windows-start (selected-window))
82 (walk-windows-current walk-windows-start))
83 (while (progn
84 (setq walk-windows-current
0cc89026 85 (next-window walk-windows-current minibuf all-frames))
be9b65ac
DL
86 (funcall proc walk-windows-current)
87 (not (eq walk-windows-current walk-windows-start))))))
88
79e0df73
RS
89(defun minibuffer-window-active-p (window)
90 "Return t if WINDOW (a minibuffer window) is now active."
91 ;; nil nil means include WINDOW's frame
92 ;; and other frames using WINDOW as minibuffer,
93 ;; and include minibuffer if active.
94 (let ((prev (previous-window window nil nil)))
95 ;; If PREV equals WINDOW, WINDOW must be on a minibuffer-only frame
96 ;; and it's not currently being used. So return nil.
97 (and (not (eq window prev))
98 (let ((should-be-same (next-window prev nil nil)))
99 ;; If next-window doesn't reverse previous-window,
100 ;; WINDOW must be outside the cycle specified by nil nil.
101 (eq should-be-same window)))))
9a5336ae
JB
102\f
103;;;; Keymap support.
be9b65ac
DL
104
105(defun undefined ()
106 (interactive)
107 (ding))
108
109;Prevent the \{...} documentation construct
110;from mentioning keys that run this command.
111(put 'undefined 'suppress-keymap t)
112
113(defun suppress-keymap (map &optional nodigits)
114 "Make MAP override all normally self-inserting keys to be undefined.
115Normally, as an exception, digits and minus-sign are set to make prefix args,
116but optional second arg NODIGITS non-nil treats them like other chars."
80e7b471 117 (substitute-key-definition 'self-insert-command 'undefined map global-map)
be9b65ac
DL
118 (or nodigits
119 (let (loop)
120 (define-key map "-" 'negative-argument)
121 ;; Make plain numbers do numeric args.
122 (setq loop ?0)
123 (while (<= loop ?9)
124 (define-key map (char-to-string loop) 'digit-argument)
125 (setq loop (1+ loop))))))
126
be9b65ac
DL
127;Moved to keymap.c
128;(defun copy-keymap (keymap)
129; "Return a copy of KEYMAP"
130; (while (not (keymapp keymap))
131; (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
132; (if (vectorp keymap)
133; (copy-sequence keymap)
134; (copy-alist keymap)))
135
7f2c2edd 136(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
be9b65ac
DL
137 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
138In other words, OLDDEF is replaced with NEWDEF where ever it appears.
7f2c2edd
RS
139If optional fourth argument OLDMAP is specified, we redefine
140in KEYMAP as NEWDEF those chars which are defined as OLDDEF in OLDMAP."
141 (or prefix (setq prefix ""))
142 (let* ((scan (or oldmap keymap))
143 (vec1 (vector nil))
144 (prefix1 (vconcat prefix vec1)))
145 ;; Scan OLDMAP, finding each char or event-symbol that
146 ;; has any definition, and act on it with hack-key.
147 (while (consp scan)
148 (if (consp (car scan))
149 (let ((char (car (car scan)))
150 (defn (cdr (car scan))))
151 ;; The inside of this let duplicates exactly
152 ;; the inside of the following let that handles array elements.
153 (aset vec1 0 char)
154 (aset prefix1 (length prefix) char)
155 (let (inner-def)
156 ;; Skip past menu-prompt.
157 (while (stringp (car-safe defn))
158 (setq defn (cdr defn)))
159 (setq inner-def defn)
160 (while (and (symbolp inner-def)
161 (fboundp inner-def))
162 (setq inner-def (symbol-function inner-def)))
163 (if (eq defn olddef)
164 (define-key keymap prefix1 newdef)
165 (if (keymapp defn)
166 (substitute-key-definition olddef newdef keymap
167 inner-def
168 prefix1)))))
169 (if (arrayp (car scan))
170 (let* ((array (car scan))
171 (len (length array))
172 (i 0))
173 (while (< i len)
174 (let ((char i) (defn (aref array i)))
175 ;; The inside of this let duplicates exactly
176 ;; the inside of the previous let.
177 (aset vec1 0 char)
178 (aset prefix1 (length prefix) char)
179 (let (inner-def)
180 ;; Skip past menu-prompt.
181 (while (stringp (car-safe defn))
182 (setq defn (cdr defn)))
183 (setq inner-def defn)
184 (while (and (symbolp inner-def)
185 (fboundp inner-def))
186 (setq inner-def (symbol-function inner-def)))
187 (if (eq defn olddef)
188 (define-key keymap prefix1 newdef)
189 (if (keymapp defn)
190 (substitute-key-definition olddef newdef keymap
191 inner-def
192 prefix1)))))
193 (setq i (1+ i))))))
194 (setq scan (cdr scan)))))
9a5336ae 195
06ae9cf2 196(defun define-key-after (keymap key definition after)
4434d61b
RS
197 "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
198This is like `define-key' except that the binding for KEY is placed
199just after the binding for the event AFTER, instead of at the beginning
200of the map.
626f67f3
RS
201The order matters when the keymap is used as a menu.
202KEY must contain just one event type--it must be a string or vector
203of length 1."
4434d61b
RS
204 (or (keymapp keymap)
205 (signal 'wrong-type-argument (list 'keymapp keymap)))
ab375e6c 206 (if (> (length key) 1)
626f67f3 207 (error "multi-event key specified in `define-key-after'"))
113d28a8 208 (let ((tail keymap) done inserted
4434d61b
RS
209 (first (aref key 0)))
210 (while (and (not done) tail)
211 ;; Delete any earlier bindings for the same key.
212 (if (eq (car-safe (car (cdr tail))) first)
213 (setcdr tail (cdr (cdr tail))))
214 ;; When we reach AFTER's binding, insert the new binding after.
215 ;; If we reach an inherited keymap, insert just before that.
113d28a8 216 ;; If we reach the end of this keymap, insert at the end.
4434d61b 217 (if (or (eq (car-safe (car tail)) after)
113d28a8
RS
218 (eq (car (cdr tail)) 'keymap)
219 (null (cdr tail)))
4434d61b 220 (progn
113d28a8
RS
221 ;; Stop the scan only if we find a parent keymap.
222 ;; Keep going past the inserted element
223 ;; so we can delete any duplications that come later.
224 (if (eq (car (cdr tail)) 'keymap)
225 (setq done t))
226 ;; Don't insert more than once.
227 (or inserted
228 (setcdr tail (cons (cons (aref key 0) definition) (cdr tail))))
229 (setq inserted t)))
4434d61b
RS
230 (setq tail (cdr tail)))))
231
9a5336ae
JB
232(defun keyboard-translate (from to)
233 "Translate character FROM to TO at a low level.
234This function creates a `keyboard-translate-table' if necessary
235and then modifies one entry in it."
236 (or (arrayp keyboard-translate-table)
237 (setq keyboard-translate-table ""))
238 (if (or (> from (length keyboard-translate-table))
239 (> to (length keyboard-translate-table)))
240 (progn
241 (let* ((i (length keyboard-translate-table))
f4ebbdbe
RS
242 (table (concat keyboard-translate-table
243 (make-string (- 256 i) 0))))
9a5336ae
JB
244 (while (< i 256)
245 (aset table i i)
246 (setq i (1+ i)))
247 (setq keyboard-translate-table table))))
248 (aset keyboard-translate-table from to))
249
250\f
251;;;; The global keymap tree.
252
253;;; global-map, esc-map, and ctl-x-map have their values set up in
254;;; keymap.c; we just give them docstrings here.
255
256(defvar global-map nil
257 "Default global keymap mapping Emacs keyboard input into commands.
258The value is a keymap which is usually (but not necessarily) Emacs's
259global map.")
260
261(defvar esc-map nil
262 "Default keymap for ESC (meta) commands.
263The normal global definition of the character ESC indirects to this keymap.")
264
265(defvar ctl-x-map nil
266 "Default keymap for C-x commands.
267The normal global definition of the character C-x indirects to this keymap.")
268
269(defvar ctl-x-4-map (make-sparse-keymap)
270 "Keymap for subcommands of C-x 4")
059184dd 271(defalias 'ctl-x-4-prefix ctl-x-4-map)
9a5336ae
JB
272(define-key ctl-x-map "4" 'ctl-x-4-prefix)
273
274(defvar ctl-x-5-map (make-sparse-keymap)
275 "Keymap for frame commands.")
059184dd 276(defalias 'ctl-x-5-prefix ctl-x-5-map)
9a5336ae
JB
277(define-key ctl-x-map "5" 'ctl-x-5-prefix)
278
0f03054a 279\f
9a5336ae
JB
280;;;; Event manipulation functions.
281
114137b8
RS
282;; This code exists specifically to make sure that the
283;; resulting number does not appear in the .elc file.
284;; The number is negative on most machines, but not on all!
285(defconst listify-key-sequence-1
286 (lsh 1 7))
287(setq listify-key-sequence-1 (logior (lsh 1 23) listify-key-sequence-1))
288
cde6d7e3
RS
289(defun listify-key-sequence (key)
290 "Convert a key sequence to a list of events."
291 (if (vectorp key)
292 (append key nil)
293 (mapcar (function (lambda (c)
294 (if (> c 127)
114137b8 295 (logxor c listify-key-sequence-1)
cde6d7e3
RS
296 c)))
297 (append key nil))))
298
53e5a4e8
RS
299(defsubst eventp (obj)
300 "True if the argument is an event object."
301 (or (integerp obj)
302 (and (symbolp obj)
303 (get obj 'event-symbol-elements))
304 (and (consp obj)
305 (symbolp (car obj))
306 (get (car obj) 'event-symbol-elements))))
307
308(defun event-modifiers (event)
309 "Returns a list of symbols representing the modifier keys in event EVENT.
310The elements of the list may include `meta', `control',
32295976
RS
311`shift', `hyper', `super', `alt', `click', `double', `triple', `drag',
312and `down'."
53e5a4e8
RS
313 (let ((type event))
314 (if (listp type)
315 (setq type (car type)))
316 (if (symbolp type)
317 (cdr (get type 'event-symbol-elements))
318 (let ((list nil))
319 (or (zerop (logand type (lsh 1 23)))
320 (setq list (cons 'meta list)))
321 (or (and (zerop (logand type (lsh 1 22)))
322 (>= (logand type 127) 32))
323 (setq list (cons 'control list)))
324 (or (and (zerop (logand type (lsh 1 21)))
325 (= (logand type 255) (downcase (logand type 255))))
326 (setq list (cons 'shift list)))
327 (or (zerop (logand type (lsh 1 20)))
328 (setq list (cons 'hyper list)))
329 (or (zerop (logand type (lsh 1 19)))
330 (setq list (cons 'super list)))
331 (or (zerop (logand type (lsh 1 18)))
332 (setq list (cons 'alt list)))
333 list))))
334
d63de416
RS
335(defun event-basic-type (event)
336 "Returns the basic type of the given event (all modifiers removed).
337The value is an ASCII printing character (not upper case) or a symbol."
2b0f4ba5
JB
338 (if (consp event)
339 (setq event (car event)))
d63de416
RS
340 (if (symbolp event)
341 (car (get event 'event-symbol-elements))
342 (let ((base (logand event (1- (lsh 1 18)))))
343 (downcase (if (< base 32) (logior base 64) base)))))
344
0f03054a
RS
345(defsubst mouse-movement-p (object)
346 "Return non-nil if OBJECT is a mouse movement event."
347 (and (consp object)
348 (eq (car object) 'mouse-movement)))
349
350(defsubst event-start (event)
351 "Return the starting position of EVENT.
352If EVENT is a mouse press or a mouse click, this returns the location
353of the event.
354If EVENT is a drag, this returns the drag's starting position.
355The return value is of the form
356 (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
357The `posn-' functions access elements of such lists."
358 (nth 1 event))
359
360(defsubst event-end (event)
361 "Return the ending location of EVENT. EVENT should be a click or drag event.
362If EVENT is a click event, this function is the same as `event-start'.
363The return value is of the form
364 (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
365The `posn-' functions access elements of such lists."
69b95560 366 (nth (if (consp (nth 2 event)) 2 1) event))
0f03054a 367
32295976
RS
368(defsubst event-click-count (event)
369 "Return the multi-click count of EVENT, a click or drag event.
370The return value is a positive integer."
371 (if (integerp (nth 2 event)) (nth 2 event) 1))
372
0f03054a
RS
373(defsubst posn-window (position)
374 "Return the window in POSITION.
375POSITION should be a list of the form
376 (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
377as returned by the `event-start' and `event-end' functions."
378 (nth 0 position))
379
380(defsubst posn-point (position)
381 "Return the buffer location in POSITION.
382POSITION should be a list of the form
383 (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
384as returned by the `event-start' and `event-end' functions."
15db4e0e
JB
385 (if (consp (nth 1 position))
386 (car (nth 1 position))
387 (nth 1 position)))
0f03054a
RS
388
389(defsubst posn-col-row (position)
390 "Return the row and column in POSITION.
391POSITION should be a list of the form
392 (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
393as returned by the `event-start' and `event-end' functions."
394 (nth 2 position))
395
396(defsubst posn-timestamp (position)
397 "Return the timestamp of POSITION.
398POSITION should be a list of the form
399 (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
f415c00c 400as returned by the `event-start' and `event-end' functions."
0f03054a 401 (nth 3 position))
9a5336ae 402
0f03054a 403\f
9a5336ae
JB
404;;;; Obsolescent names for functions.
405
059184dd
ER
406(defalias 'dot 'point)
407(defalias 'dot-marker 'point-marker)
408(defalias 'dot-min 'point-min)
409(defalias 'dot-max 'point-max)
410(defalias 'window-dot 'window-point)
411(defalias 'set-window-dot 'set-window-point)
412(defalias 'read-input 'read-string)
413(defalias 'send-string 'process-send-string)
414(defalias 'send-region 'process-send-region)
415(defalias 'show-buffer 'set-window-buffer)
416(defalias 'buffer-flush-undo 'buffer-disable-undo)
417(defalias 'eval-current-buffer 'eval-buffer)
418(defalias 'compiled-function-p 'byte-code-function-p)
be9b65ac 419
9a5336ae
JB
420;; Some programs still use this as a function.
421(defun baud-rate ()
bcacc42c
RS
422 "Obsolete function returning the value of the `baud-rate' variable.
423Please convert your programs to use the variable `baud-rate' directly."
9a5336ae
JB
424 baud-rate)
425
426\f
427;;;; Alternate names for functions - these are not being phased out.
428
059184dd
ER
429(defalias 'string= 'string-equal)
430(defalias 'string< 'string-lessp)
431(defalias 'move-marker 'set-marker)
432(defalias 'eql 'eq)
433(defalias 'not 'null)
434(defalias 'rplaca 'setcar)
435(defalias 'rplacd 'setcdr)
eb8c3be9 436(defalias 'beep 'ding) ;preserve lingual purity
059184dd
ER
437(defalias 'indent-to-column 'indent-to)
438(defalias 'backward-delete-char 'delete-backward-char)
439(defalias 'search-forward-regexp (symbol-function 're-search-forward))
440(defalias 'search-backward-regexp (symbol-function 're-search-backward))
441(defalias 'int-to-string 'number-to-string)
37f6661a
JB
442
443;;; Should this be an obsolete name? If you decide it should, you get
444;;; to go through all the sources and change them.
059184dd 445(defalias 'string-to-int 'string-to-number)
be9b65ac 446\f
9a5336ae 447;;;; Hook manipulation functions.
be9b65ac 448
be9b65ac
DL
449(defun run-hooks (&rest hooklist)
450 "Takes hook names and runs each one in turn. Major mode functions use this.
451Each argument should be a symbol, a hook variable.
452These symbols are processed in the order specified.
453If a hook symbol has a non-nil value, that value may be a function
454or a list of functions to be called to run the hook.
455If the value is a function, it is called with no arguments.
456If it is a list, the elements are called, in order, with no arguments."
457 (while hooklist
458 (let ((sym (car hooklist)))
459 (and (boundp sym)
460 (symbol-value sym)
461 (let ((value (symbol-value sym)))
462 (if (and (listp value) (not (eq (car value) 'lambda)))
463 (mapcar 'funcall value)
464 (funcall value)))))
465 (setq hooklist (cdr hooklist))))
466
467;; Tell C code how to call this function.
468(defconst run-hooks 'run-hooks
469 "Variable by which C primitives find the function `run-hooks'.
470Don't change it.")
471
08159178 472(defun add-hook (hook function &optional append)
32295976
RS
473 "Add to the value of HOOK the function FUNCTION.
474FUNCTION is not added if already present.
475FUNCTION is added (if necessary) at the beginning of the hook list
476unless the optional argument APPEND is non-nil, in which case
477FUNCTION is added at the end.
478
479HOOK should be a symbol, and FUNCTION may be any valid function. If
480HOOK is void, it is first set to nil. If HOOK's value is a single
481function, it is changed to a list of functions."
be9b65ac 482 (or (boundp hook) (set hook nil))
32295976
RS
483 ;; If the hook value is a single function, turn it into a list.
484 (let ((old (symbol-value hook)))
485 (if (or (not (listp old)) (eq (car old) 'lambda))
486 (set hook (list old))))
be9b65ac 487 (or (if (consp function)
f48c1d8d 488 (member function (symbol-value hook))
be9b65ac 489 (memq function (symbol-value hook)))
08159178
ER
490 (set hook
491 (if append
492 (nconc (symbol-value hook) (list function))
493 (cons function (symbol-value hook))))))
9a5336ae 494
24980d16
RS
495(defun remove-hook (hook function)
496 "Remove from the value of HOOK the function FUNCTION.
497HOOK should be a symbol, and FUNCTION may be any valid function. If
498FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
827534ea 499list of hooks to run in HOOK, then nothing is done. See `add-hook'."
24980d16
RS
500 (if (or (not (boundp hook)) ;unbound symbol, or
501 (null (symbol-value hook)) ;value is nil, or
502 (null function)) ;function is nil, then
503 nil ;Do nothing.
504 (let ((hook-value (symbol-value hook)))
505 (if (consp hook-value)
506 (setq hook-value (delete function hook-value))
f48c1d8d 507 (if (equal hook-value function)
24980d16
RS
508 (setq hook-value nil)))
509 (set hook hook-value))))
be9b65ac 510\f
9a5336ae
JB
511;;;; Specifying things to do after certain files are loaded.
512
513(defun eval-after-load (file form)
514 "Arrange that, if FILE is ever loaded, FORM will be run at that time.
515This makes or adds to an entry on `after-load-alist'.
12c7071c 516It does nothing if FORM is already on the list for FILE.
9a5336ae
JB
517FILE should be the name of a library, with no directory name."
518 (or (assoc file after-load-alist)
519 (setq after-load-alist (cons (list file) after-load-alist)))
12c7071c
RS
520 (let ((elt (assoc file after-load-alist)))
521 (or (member form (cdr elt))
522 (nconc elt (list form))))
9a5336ae
JB
523 form)
524
525(defun eval-next-after-load (file)
526 "Read the following input sexp, and run it whenever FILE is loaded.
527This makes or adds to an entry on `after-load-alist'.
528FILE should be the name of a library, with no directory name."
529 (eval-after-load file (read)))
530
531\f
532;;;; Input and display facilities.
533
534(defun read-quoted-char (&optional prompt)
535 "Like `read-char', except that if the first character read is an octal
536digit, we read up to two more octal digits and return the character
537represented by the octal number consisting of those digits.
538Optional argument PROMPT specifies a string to use to prompt the user."
539 (let ((count 0) (code 0) char)
540 (while (< count 3)
541 (let ((inhibit-quit (zerop count))
542 (help-form nil))
543 (and prompt (message "%s-" prompt))
544 (setq char (read-char))
545 (if inhibit-quit (setq quit-flag nil)))
546 (cond ((null char))
547 ((and (<= ?0 char) (<= char ?7))
548 (setq code (+ (* code 8) (- char ?0))
549 count (1+ count))
550 (and prompt (message (setq prompt
551 (format "%s %c" prompt char)))))
552 ((> count 0)
553 (setq unread-command-events (list char) count 259))
554 (t (setq code char count 259))))
555 (logand 255 code)))
556
557(defun force-mode-line-update (&optional all)
558 "Force the mode-line of the current buffer to be redisplayed.
559With optional non-nil ALL then force then force redisplay of all mode-lines."
560 (if all (save-excursion (set-buffer (other-buffer))))
561 (set-buffer-modified-p (buffer-modified-p)))
562
be9b65ac
DL
563(defun momentary-string-display (string pos &optional exit-char message)
564 "Momentarily display STRING in the buffer at POS.
565Display remains until next character is typed.
566If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
567otherwise it is then available as input (as a command if nothing else).
568Display MESSAGE (optional fourth arg) in the echo area.
569If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
570 (or exit-char (setq exit-char ?\ ))
571 (let ((buffer-read-only nil)
572 (modified (buffer-modified-p))
573 (name buffer-file-name)
574 insert-end)
575 (unwind-protect
576 (progn
577 (save-excursion
578 (goto-char pos)
579 ;; defeat file locking... don't try this at home, kids!
580 (setq buffer-file-name nil)
581 (insert-before-markers string)
3eec84bf
RS
582 (setq insert-end (point))
583 ;; If the message end is off screen, recenter now.
584 (if (> (window-end) insert-end)
585 (recenter (/ (window-height) 2)))
586 ;; If that pushed message start off the screen,
587 ;; scroll to start it at the top of the screen.
588 (move-to-window-line 0)
589 (if (> (point) pos)
590 (progn
591 (goto-char pos)
592 (recenter 0))))
be9b65ac
DL
593 (message (or message "Type %s to continue editing.")
594 (single-key-description exit-char))
3547c855 595 (let ((char (read-event)))
be9b65ac 596 (or (eq char exit-char)
dbc4e1c1 597 (setq unread-command-events (list char)))))
be9b65ac
DL
598 (if insert-end
599 (save-excursion
600 (delete-region pos insert-end)))
601 (setq buffer-file-name name)
602 (set-buffer-modified-p modified))))
603
9a5336ae
JB
604\f
605;;;; Miscellanea.
606
607(defun ignore (&rest ignore)
608 "Do nothing.
609Accept any number of arguments, but ignore them."
610 nil)
611
612(defun error (&rest args)
613 "Signal an error, making error message by passing all args to `format'."
614 (while t
615 (signal 'error (list (apply 'format args)))))
616
617(defun user-original-login-name ()
618 "Return user's login name from original login.
619This tries to remain unaffected by `su', by looking in environment variables."
620 (or (getenv "LOGNAME") (getenv "USER") (user-login-name)))
621
be9b65ac
DL
622(defun start-process-shell-command (name buffer &rest args)
623 "Start a program in a subprocess. Return the process object for it.
624Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
625NAME is name for process. It is modified if necessary to make it unique.
626BUFFER is the buffer or (buffer-name) to associate with the process.
627 Process output goes at end of that buffer, unless you specify
628 an output stream or filter function to handle the output.
629 BUFFER may be also nil, meaning that this process is not associated
630 with any buffer
631Third arg is command name, the name of a shell command.
632Remaining arguments are the arguments for the command.
4f1d6310 633Wildcards and redirection are handled as usual in the shell."
be9b65ac
DL
634 (if (eq system-type 'vax-vms)
635 (apply 'start-process name buffer args)
636 (start-process name buffer shell-file-name "-c"
637 (concat "exec " (mapconcat 'identity args " ")))))
be9b65ac 638
9a5336ae
JB
639(defmacro save-match-data (&rest body)
640 "Execute the BODY forms, restoring the global value of the match data."
641 (let ((original (make-symbol "match-data")))
642 (list
643 'let (list (list original '(match-data)))
644 (list 'unwind-protect
645 (cons 'progn body)
646 (list 'store-match-data original)))))
ffd56f97 647
8af7df60
RS
648(defun shell-quote-argument (argument)
649 "Quote an argument for passing as argument to an inferior shell."
650 ;; Quote everything except POSIX filename characters.
651 ;; This should be safe enough even for really weird shells.
652 (let ((result "") (start 0) end)
653 (while (string-match "[^---0-9a-zA-Z_./]" argument start)
654 (setq end (match-beginning 0)
655 result (concat result (substring argument start end)
656 "\\" (substring argument end (1+ end)))
657 start (1+ end)))
658 (concat result (substring argument start))))
659
984f718a
RS
660(defun make-syntax-table ()
661 "Return a new syntax table.
662It inherits all letters and control characters from the standard
663syntax table; other characters are copied from the standard syntax table."
664 (let ((table (copy-syntax-table))
665 i)
666 (setq i 0)
667 (while (<= i 31)
668 (aset table i 13)
669 (setq i (1+ i)))
670 (setq i ?A)
671 (while (<= i ?Z)
672 (aset table i 13)
673 (setq i (1+ i)))
674 (setq i ?a)
675 (while (<= i ?z)
676 (aset table i 13)
677 (setq i (1+ i)))
678 (setq i 128)
679 (while (<= i 255)
680 (aset table i 13)
681 (setq i (1+ i)))
682 table))
683
9a5336ae
JB
684;; now in fns.c
685;(defun nth (n list)
686; "Returns the Nth element of LIST.
687;N counts from zero. If LIST is not that long, nil is returned."
688; (car (nthcdr n list)))
689;
690;(defun copy-alist (alist)
691; "Return a copy of ALIST.
692;This is a new alist which represents the same mapping
693;from objects to objects, but does not share the alist structure with ALIST.
694;The objects mapped (cars and cdrs of elements of the alist)
695;are shared, however."
696; (setq alist (copy-sequence alist))
697; (let ((tail alist))
698; (while tail
699; (if (consp (car tail))
700; (setcar tail (cons (car (car tail)) (cdr (car tail)))))
701; (setq tail (cdr tail))))
702; alist)
630cc463
ER
703
704;;; subr.el ends here
9a5336ae 705