1 ;;; subr.el --- basic lisp subroutines for Emacs
3 ;;; Copyright (C) 1985, 1986, 1992, 1994 Free Software Foundation, Inc.
5 ;; This file is part of GNU Emacs.
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
9 ;; the Free Software Foundation; either version 2, or (at your option)
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.
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.
24 ;;;; Lisp language features.
26 (defmacro lambda
(&rest cdr
)
27 "Return a lambda expression.
28 A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
29 self-quoting; the result of evaluating the lambda expression is the
30 expression itself. The lambda expression may then be treated as a
31 function, i. e. stored as the function value of a symbol, passed to
32 funcall or mapcar, etcetera.
33 ARGS should take the same form as an argument list for a `defun'.
34 DOCSTRING should be a string, as described for `defun'. It may be omitted.
35 INTERACTIVE should be a call to the function `interactive', which see.
36 It may also be omitted.
37 BODY 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
)))
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)))
54 ;;;; Window tree functions.
56 (defun one-window-p (&optional nomini all-frames
)
57 "Returns non-nil if the selected window is the only window (in its frame).
58 Optional arg NOMINI non-nil means don't count the minibuffer
61 The optional arg ALL-FRAMES t means count windows on all frames.
62 If it is `visible', count windows on all visible frames.
63 ALL-FRAMES nil or omitted means count only the selected frame,
64 plus the minibuffer it uses (which may be on another frame).
65 If ALL-FRAMES is neither nil nor t, count only the selected frame."
66 (let ((base-window (selected-window)))
67 (if (and nomini
(eq base-window
(minibuffer-window)))
68 (setq base-window
(next-window base-window
)))
70 (next-window base-window
(if nomini
'arg
) all-frames
))))
72 (defun walk-windows (proc &optional minibuf all-frames
)
73 "Cycle through all visible windows, calling PROC for each one.
74 PROC is called with a window as argument.
75 Optional second arg MINIBUF t means count the minibuffer window
76 even if not active. If MINIBUF is neither t nor nil it means
77 not to count the minibuffer even if it is active.
79 Optional third arg ALL-FRAMES, if t, means include all frames.
80 ALL-FRAMES nil or omitted means cycle within the selected frame,
81 but include the minibuffer window (if MINIBUF says so) that that
82 frame uses, even if it is on another frame.
83 If ALL-FRAMES is neither nil nor t, stick strictly to the selected frame."
84 ;; If we start from the minibuffer window, don't fail to come back to it.
85 (if (window-minibuffer-p (selected-window))
87 (let* ((walk-windows-start (selected-window))
88 (walk-windows-current walk-windows-start
))
90 (setq walk-windows-current
91 (next-window walk-windows-current minibuf all-frames
))
92 (funcall proc walk-windows-current
)
93 (not (eq walk-windows-current walk-windows-start
))))))
95 (defun minibuffer-window-active-p (window)
96 "Return t if WINDOW (a minibuffer window) is now active."
97 ;; nil nil means include WINDOW's frame
98 ;; and other frames using WINDOW as minibuffer,
99 ;; and include minibuffer if active.
100 (let ((prev (previous-window window nil nil
)))
101 ;; If PREV equals WINDOW, WINDOW must be on a minibuffer-only frame
102 ;; and it's not currently being used. So return nil.
103 (and (not (eq window prev
))
104 (let ((should-be-same (next-window prev nil nil
)))
105 ;; If next-window doesn't reverse previous-window,
106 ;; WINDOW must be outside the cycle specified by nil nil.
107 (eq should-be-same window
)))))
115 ;Prevent the \{...} documentation construct
116 ;from mentioning keys that run this command.
117 (put 'undefined
'suppress-keymap t
)
119 (defun suppress-keymap (map &optional nodigits
)
120 "Make MAP override all normally self-inserting keys to be undefined.
121 Normally, as an exception, digits and minus-sign are set to make prefix args,
122 but optional second arg NODIGITS non-nil treats them like other chars."
123 (substitute-key-definition 'self-insert-command
'undefined map global-map
)
126 (define-key map
"-" 'negative-argument
)
127 ;; Make plain numbers do numeric args.
130 (define-key map
(char-to-string loop
) 'digit-argument
)
131 (setq loop
(1+ loop
))))))
134 ;(defun copy-keymap (keymap)
135 ; "Return a copy of KEYMAP"
136 ; (while (not (keymapp keymap))
137 ; (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
138 ; (if (vectorp keymap)
139 ; (copy-sequence keymap)
140 ; (copy-alist keymap)))
142 (defvar key-substitution-in-progress nil
143 "Used internally by substitute-key-definition.")
145 (defun substitute-key-definition (olddef newdef keymap
&optional oldmap prefix
)
146 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
147 In other words, OLDDEF is replaced with NEWDEF where ever it appears.
148 If optional fourth argument OLDMAP is specified, we redefine
149 in KEYMAP as NEWDEF those chars which are defined as OLDDEF in OLDMAP."
150 (or prefix
(setq prefix
""))
151 (let* ((scan (or oldmap keymap
))
153 (prefix1 (vconcat prefix vec1
))
154 (key-substitution-in-progress
155 (cons scan key-substitution-in-progress
)))
156 ;; Scan OLDMAP, finding each char or event-symbol that
157 ;; has any definition, and act on it with hack-key.
159 (if (consp (car scan
))
160 (let ((char (car (car scan
)))
161 (defn (cdr (car scan
))))
162 ;; The inside of this let duplicates exactly
163 ;; the inside of the following let that handles array elements.
165 (aset prefix1
(length prefix
) char
)
166 (let (inner-def skipped
)
167 ;; Skip past menu-prompt.
168 (while (stringp (car-safe defn
))
169 (setq skipped
(cons (car defn
) skipped
))
170 (setq defn
(cdr defn
)))
171 ;; Skip past cached key-equivalence data for menu items.
172 (and (consp defn
) (consp (car defn
))
173 (setq defn
(cdr defn
)))
174 (setq inner-def defn
)
175 ;; Look past a symbol that names a keymap.
176 (while (and (symbolp inner-def
)
178 (setq inner-def
(symbol-function inner-def
)))
180 (define-key keymap prefix1
(nconc (nreverse skipped
) newdef
))
181 ;; Avoid recursively rescanning a keymap being scanned.
182 (if (and (keymapp defn
)
184 key-substitution-in-progress
)))
185 ;; If this one isn't being scanned already,
187 (substitute-key-definition olddef newdef keymap
190 (if (arrayp (car scan
))
191 (let* ((array (car scan
))
195 (let ((char i
) (defn (aref array i
)))
196 ;; The inside of this let duplicates exactly
197 ;; the inside of the previous let.
199 (aset prefix1
(length prefix
) char
)
200 (let (inner-def skipped
)
201 ;; Skip past menu-prompt.
202 (while (stringp (car-safe defn
))
203 (setq skipped
(cons (car defn
) skipped
))
204 (setq defn
(cdr defn
)))
205 (and (consp defn
) (consp (car defn
))
206 (setq defn
(cdr defn
)))
207 (setq inner-def defn
)
208 (while (and (symbolp inner-def
)
210 (setq inner-def
(symbol-function inner-def
)))
212 (define-key keymap prefix1
213 (nconc (nreverse skipped
) newdef
))
214 (if (and (keymapp defn
)
216 key-substitution-in-progress
)))
217 (substitute-key-definition olddef newdef keymap
221 (setq scan
(cdr scan
)))))
223 (defun define-key-after (keymap key definition after
)
224 "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding.
225 This is like `define-key' except that the binding for KEY is placed
226 just after the binding for the event AFTER, instead of at the beginning
228 The order matters when the keymap is used as a menu.
229 KEY must contain just one event type--that is to say, it must be
230 a string or vector of length 1."
232 (signal 'wrong-type-argument
(list 'keymapp keymap
)))
233 (if (> (length key
) 1)
234 (error "multi-event key specified in `define-key-after'"))
235 (let ((tail keymap
) done inserted
236 (first (aref key
0)))
237 (while (and (not done
) tail
)
238 ;; Delete any earlier bindings for the same key.
239 (if (eq (car-safe (car (cdr tail
))) first
)
240 (setcdr tail
(cdr (cdr tail
))))
241 ;; When we reach AFTER's binding, insert the new binding after.
242 ;; If we reach an inherited keymap, insert just before that.
243 ;; If we reach the end of this keymap, insert at the end.
244 (if (or (eq (car-safe (car tail
)) after
)
245 (eq (car (cdr tail
)) 'keymap
)
248 ;; Stop the scan only if we find a parent keymap.
249 ;; Keep going past the inserted element
250 ;; so we can delete any duplications that come later.
251 (if (eq (car (cdr tail
)) 'keymap
)
253 ;; Don't insert more than once.
255 (setcdr tail
(cons (cons (aref key
0) definition
) (cdr tail
))))
257 (setq tail
(cdr tail
)))))
259 (defun keyboard-translate (from to
)
260 "Translate character FROM to TO at a low level.
261 This function creates a `keyboard-translate-table' if necessary
262 and then modifies one entry in it."
263 (or (arrayp keyboard-translate-table
)
264 (setq keyboard-translate-table
""))
265 (if (or (> from
(length keyboard-translate-table
))
266 (> to
(length keyboard-translate-table
)))
268 (let* ((i (length keyboard-translate-table
))
269 (table (concat keyboard-translate-table
270 (make-string (- 256 i
) 0))))
274 (setq keyboard-translate-table table
))))
275 (aset keyboard-translate-table from to
))
278 ;;;; The global keymap tree.
280 ;;; global-map, esc-map, and ctl-x-map have their values set up in
281 ;;; keymap.c; we just give them docstrings here.
283 (defvar global-map nil
284 "Default global keymap mapping Emacs keyboard input into commands.
285 The value is a keymap which is usually (but not necessarily) Emacs's
289 "Default keymap for ESC (meta) commands.
290 The normal global definition of the character ESC indirects to this keymap.")
292 (defvar ctl-x-map nil
293 "Default keymap for C-x commands.
294 The normal global definition of the character C-x indirects to this keymap.")
296 (defvar ctl-x-4-map
(make-sparse-keymap)
297 "Keymap for subcommands of C-x 4")
298 (defalias 'ctl-x-4-prefix ctl-x-4-map
)
299 (define-key ctl-x-map
"4" 'ctl-x-4-prefix
)
301 (defvar ctl-x-5-map
(make-sparse-keymap)
302 "Keymap for frame commands.")
303 (defalias 'ctl-x-5-prefix ctl-x-5-map
)
304 (define-key ctl-x-map
"5" 'ctl-x-5-prefix
)
307 ;;;; Event manipulation functions.
309 ;; This code exists specifically to make sure that the
310 ;; resulting number does not appear in the .elc file.
311 ;; The number is negative on most machines, but not on all!
312 (defconst listify-key-sequence-1
314 (setq listify-key-sequence-1
(logior (lsh 1 23) listify-key-sequence-1
))
316 (defun listify-key-sequence (key)
317 "Convert a key sequence to a list of events."
320 (mapcar (function (lambda (c)
322 (logxor c listify-key-sequence-1
)
326 (defsubst eventp
(obj)
327 "True if the argument is an event object."
330 (get obj
'event-symbol-elements
))
333 (get (car obj
) 'event-symbol-elements
))))
335 (defun event-modifiers (event)
336 "Returns a list of symbols representing the modifier keys in event EVENT.
337 The elements of the list may include `meta', `control',
338 `shift', `hyper', `super', `alt', `click', `double', `triple', `drag',
342 (setq type
(car type
)))
344 (cdr (get type
'event-symbol-elements
))
346 (or (zerop (logand type
(lsh 1 23)))
347 (setq list
(cons 'meta list
)))
348 (or (and (zerop (logand type
(lsh 1 22)))
349 (>= (logand type
127) 32))
350 (setq list
(cons 'control list
)))
351 (or (and (zerop (logand type
(lsh 1 21)))
352 (= (logand type
255) (downcase (logand type
255))))
353 (setq list
(cons 'shift list
)))
354 (or (zerop (logand type
(lsh 1 20)))
355 (setq list
(cons 'hyper list
)))
356 (or (zerop (logand type
(lsh 1 19)))
357 (setq list
(cons 'super list
)))
358 (or (zerop (logand type
(lsh 1 18)))
359 (setq list
(cons 'alt list
)))
362 (defun event-basic-type (event)
363 "Returns the basic type of the given event (all modifiers removed).
364 The value is an ASCII printing character (not upper case) or a symbol."
366 (setq event
(car event
)))
368 (car (get event
'event-symbol-elements
))
369 (let ((base (logand event
(1- (lsh 1 18)))))
370 (downcase (if (< base
32) (logior base
64) base
)))))
372 (defsubst mouse-movement-p
(object)
373 "Return non-nil if OBJECT is a mouse movement event."
375 (eq (car object
) 'mouse-movement
)))
377 (defsubst event-start
(event)
378 "Return the starting position of EVENT.
379 If EVENT is a mouse press or a mouse click, this returns the location
381 If EVENT is a drag, this returns the drag's starting position.
382 The return value is of the form
383 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
384 The `posn-' functions access elements of such lists."
387 (defsubst event-end
(event)
388 "Return the ending location of EVENT. EVENT should be a click or drag event.
389 If EVENT is a click event, this function is the same as `event-start'.
390 The return value is of the form
391 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
392 The `posn-' functions access elements of such lists."
393 (nth (if (consp (nth 2 event
)) 2 1) event
))
395 (defsubst event-click-count
(event)
396 "Return the multi-click count of EVENT, a click or drag event.
397 The return value is a positive integer."
398 (if (integerp (nth 2 event
)) (nth 2 event
) 1))
400 (defsubst posn-window
(position)
401 "Return the window in POSITION.
402 POSITION should be a list of the form
403 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
404 as returned by the `event-start' and `event-end' functions."
407 (defsubst posn-point
(position)
408 "Return the buffer location in POSITION.
409 POSITION should be a list of the form
410 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
411 as returned by the `event-start' and `event-end' functions."
412 (if (consp (nth 1 position
))
413 (car (nth 1 position
))
416 (defsubst posn-x-y
(position)
417 "Return the x and y coordinates in POSITION.
418 POSITION should be a list of the form
419 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
420 as returned by the `event-start' and `event-end' functions."
423 (defun posn-col-row (position)
424 "Return the column and row in POSITION, measured in characters.
425 POSITION should be a list of the form
426 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
427 as returned by the `event-start' and `event-end' functions.
428 For a scroll-bar event, the result column is 0, and the row
429 corresponds to the vertical position of the click in the scroll bar."
430 (let ((pair (nth 2 position
))
431 (window (posn-window position
)))
432 (if (eq (if (consp (nth 1 position
))
433 (car (nth 1 position
))
435 'vertical-scroll-bar
)
436 (cons 0 (scroll-bar-scale pair
(1- (window-height window
))))
437 (if (eq (if (consp (nth 1 position
))
438 (car (nth 1 position
))
440 'horizontal-scroll-bar
)
441 (cons (scroll-bar-scale pair
(window-width window
)) 0)
442 (let* ((frame (if (framep window
) window
(window-frame window
)))
443 (x (/ (car pair
) (frame-char-width frame
)))
444 (y (/ (cdr pair
) (frame-char-height frame
))))
447 (defsubst posn-timestamp
(position)
448 "Return the timestamp of POSITION.
449 POSITION should be a list of the form
450 (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
451 as returned by the `event-start' and `event-end' functions."
455 ;;;; Obsolescent names for functions.
457 (defalias 'dot
'point
)
458 (defalias 'dot-marker
'point-marker
)
459 (defalias 'dot-min
'point-min
)
460 (defalias 'dot-max
'point-max
)
461 (defalias 'window-dot
'window-point
)
462 (defalias 'set-window-dot
'set-window-point
)
463 (defalias 'read-input
'read-string
)
464 (defalias 'send-string
'process-send-string
)
465 (defalias 'send-region
'process-send-region
)
466 (defalias 'show-buffer
'set-window-buffer
)
467 (defalias 'buffer-flush-undo
'buffer-disable-undo
)
468 (defalias 'eval-current-buffer
'eval-buffer
)
469 (defalias 'compiled-function-p
'byte-code-function-p
)
471 ;; Some programs still use this as a function.
473 "Obsolete function returning the value of the `baud-rate' variable.
474 Please convert your programs to use the variable `baud-rate' directly."
478 ;;;; Alternate names for functions - these are not being phased out.
480 (defalias 'string
= 'string-equal
)
481 (defalias 'string
< 'string-lessp
)
482 (defalias 'move-marker
'set-marker
)
484 (defalias 'not
'null
)
485 (defalias 'rplaca
'setcar
)
486 (defalias 'rplacd
'setcdr
)
487 (defalias 'beep
'ding
) ;preserve lingual purity
488 (defalias 'indent-to-column
'indent-to
)
489 (defalias 'backward-delete-char
'delete-backward-char
)
490 (defalias 'search-forward-regexp
(symbol-function 're-search-forward
))
491 (defalias 'search-backward-regexp
(symbol-function 're-search-backward
))
492 (defalias 'int-to-string
'number-to-string
)
493 (defalias 'set-match-data
'store-match-data
)
495 ;;; Should this be an obsolete name? If you decide it should, you get
496 ;;; to go through all the sources and change them.
497 (defalias 'string-to-int
'string-to-number
)
499 ;;;; Hook manipulation functions.
501 (defun run-hooks (&rest hooklist
)
502 "Takes hook names and runs each one in turn. Major mode functions use this.
503 Each argument should be a symbol, a hook variable.
504 These symbols are processed in the order specified.
505 If a hook symbol has a non-nil value, that value may be a function
506 or a list of functions to be called to run the hook.
507 If the value is a function, it is called with no arguments.
508 If it is a list, the elements are called, in order, with no arguments.
510 To make a hook variable buffer-local, use `make-local-hook', not
511 `make-local-variable'."
513 (let ((sym (car hooklist
)))
516 (let ((value (symbol-value sym
)))
517 (if (and (listp value
) (not (eq (car value
) 'lambda
)))
519 (if (eq (car value
) t
)
520 ;; t indicates this hook has a local binding;
521 ;; it means to run the global binding too.
522 (let ((functions (default-value sym
)))
524 (funcall (car functions
))
525 (setq functions
(cdr functions
))))
526 (funcall (car value
)))
527 (setq value
(cdr value
)))
529 (setq hooklist
(cdr hooklist
))))
531 (defun run-hook-with-args (hook &rest args
)
532 "Run HOOK with the specified arguments ARGS.
533 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
534 value, that value may be a function or a list of functions to be
535 called to run the hook. If the value is a function, it is called with
536 the given arguments and its return value is returned. If it is a list
537 of functions, those functions are called, in order,
538 with the given arguments ARGS.
539 It is best not to depend on the value return by `run-hook-with-args',
542 To make a hook variable buffer-local, use `make-local-hook', not
543 `make-local-variable'."
546 (let ((value (symbol-value hook
)))
547 (if (and (listp value
) (not (eq (car value
) 'lambda
)))
549 (if (eq (car value
) t
)
550 ;; t indicates this hook has a local binding;
551 ;; it means to run the global binding too.
552 (let ((functions (default-value hook
)))
554 (apply (car functions
) args
)
555 (setq functions
(cdr functions
))))
556 (apply (car value
) args
))
557 (setq value
(cdr value
)))
558 (apply value args
)))))
560 (defun run-hook-with-args-until-success (hook &rest args
)
561 "Run HOOK with the specified arguments ARGS.
562 HOOK should be a symbol, a hook variable. Its value should
563 be a list of functions. We call those functions, one by one,
564 passing arguments ARGS to each of them, until one of them
565 returns a non-nil value. Then we return that value.
566 If all the functions return nil, we return nil.
568 To make a hook variable buffer-local, use `make-local-hook', not
569 `make-local-variable'."
572 (let ((value (symbol-value hook
))
574 (while (and value
(not success
))
575 (if (eq (car value
) t
)
576 ;; t indicates this hook has a local binding;
577 ;; it means to run the global binding too.
578 (let ((functions (default-value hook
)))
579 (while (and functions
(not success
))
580 (setq success
(apply (car functions
) args
))
581 (setq functions
(cdr functions
))))
582 (setq success
(apply (car value
) args
)))
583 (setq value
(cdr value
)))
586 (defun run-hook-with-args-until-failure (hook &rest args
)
587 "Run HOOK with the specified arguments ARGS.
588 HOOK should be a symbol, a hook variable. Its value should
589 be a list of functions. We call those functions, one by one,
590 passing arguments ARGS to each of them, until one of them
591 returns nil. Then we return nil.
592 If all the functions return non-nil, we return non-nil.
594 To make a hook variable buffer-local, use `make-local-hook', not
595 `make-local-variable'."
598 (let ((value (symbol-value hook
))
600 (while (and value success
)
601 (if (eq (car value
) t
)
602 ;; t indicates this hook has a local binding;
603 ;; it means to run the global binding too.
604 (let ((functions (default-value hook
)))
605 (while (and functions success
)
606 (setq success
(apply (car functions
) args
))
607 (setq functions
(cdr functions
))))
608 (setq success
(apply (car value
) args
)))
609 (setq value
(cdr value
)))
612 ;; Tell C code how to call this function.
613 (defconst run-hooks
'run-hooks
614 "Variable by which C primitives find the function `run-hooks'.
617 (defun make-local-hook (hook)
618 "Make the hook HOOK local to the current buffer.
619 When a hook is local, its local and global values
620 work in concert: running the hook actually runs all the hook
621 functions listed in *either* the local value *or* the global value
622 of the hook variable.
624 This function does nothing if HOOK is already local in the current buffer.
626 Do not use `make-local-variable' to make a hook variable buffer-local."
627 (if (local-variable-p hook
)
629 (or (boundp hook
) (set hook nil
))
630 (make-local-variable hook
)
631 (set hook
(list t
))))
633 (defun add-hook (hook function
&optional append local
)
634 "Add to the value of HOOK the function FUNCTION.
635 FUNCTION is not added if already present.
636 FUNCTION is added (if necessary) at the beginning of the hook list
637 unless the optional argument APPEND is non-nil, in which case
638 FUNCTION is added at the end.
640 The optional fourth argument, LOCAL, if non-nil, says to modify
641 the hook's buffer-local value rather than its default value.
642 This makes no difference if the hook is not buffer-local.
643 To make a hook variable buffer-local, always use
644 `make-local-hook', not `make-local-variable'.
646 HOOK should be a symbol, and FUNCTION may be any valid function. If
647 HOOK is void, it is first set to nil. If HOOK's value is a single
648 function, it is changed to a list of functions."
649 (or (boundp hook
) (set hook nil
))
650 (or (default-boundp hook
) (set-default hook nil
))
651 ;; If the hook value is a single function, turn it into a list.
652 (let ((old (symbol-value hook
)))
653 (if (or (not (listp old
)) (eq (car old
) 'lambda
))
654 (set hook
(list old
))))
656 ;; Alter the local value only.
657 (or (if (consp function
)
658 (member function
(symbol-value hook
))
659 (memq function
(symbol-value hook
)))
662 (append (symbol-value hook
) (list function
))
663 (cons function
(symbol-value hook
)))))
664 ;; Alter the global value (which is also the only value,
665 ;; if the hook doesn't have a local value).
666 (or (if (consp function
)
667 (member function
(default-value hook
))
668 (memq function
(default-value hook
)))
671 (append (default-value hook
) (list function
))
672 (cons function
(default-value hook
)))))))
674 (defun remove-hook (hook function
&optional local
)
675 "Remove from the value of HOOK the function FUNCTION.
676 HOOK should be a symbol, and FUNCTION may be any valid function. If
677 FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
678 list of hooks to run in HOOK, then nothing is done. See `add-hook'.
680 The optional third argument, LOCAL, if non-nil, says to modify
681 the hook's buffer-local value rather than its default value.
682 This makes no difference if the hook is not buffer-local.
683 To make a hook variable buffer-local, always use
684 `make-local-hook', not `make-local-variable'."
685 (if (or (not (boundp hook
)) ;unbound symbol, or
686 (not (default-boundp 'hook
))
687 (null (symbol-value hook
)) ;value is nil, or
688 (null function
)) ;function is nil, then
691 (let ((hook-value (symbol-value hook
)))
692 (if (consp hook-value
)
693 (if (member function hook-value
)
694 (setq hook-value
(delete function
(copy-sequence hook-value
))))
695 (if (equal hook-value function
)
696 (setq hook-value nil
)))
697 (set hook hook-value
))
698 (let ((hook-value (default-value hook
)))
699 (if (consp hook-value
)
700 (if (member function hook-value
)
701 (setq hook-value
(delete function
(copy-sequence hook-value
))))
702 (if (equal hook-value function
)
703 (setq hook-value nil
)))
704 (set-default hook hook-value
)))))
706 ;;;; Specifying things to do after certain files are loaded.
708 (defun eval-after-load (file form
)
709 "Arrange that, if FILE is ever loaded, FORM will be run at that time.
710 This makes or adds to an entry on `after-load-alist'.
711 It does nothing if FORM is already on the list for FILE.
712 FILE should be the name of a library, with no directory name."
713 (or (assoc file after-load-alist
)
714 (setq after-load-alist
(cons (list file
) after-load-alist
)))
715 (let ((elt (assoc file after-load-alist
)))
716 (or (member form
(cdr elt
))
717 (nconc elt
(list form
))))
720 (defun eval-next-after-load (file)
721 "Read the following input sexp, and run it whenever FILE is loaded.
722 This makes or adds to an entry on `after-load-alist'.
723 FILE should be the name of a library, with no directory name."
724 (eval-after-load file
(read)))
727 ;;;; Input and display facilities.
729 (defun read-quoted-char (&optional prompt
)
730 "Like `read-char', except that if the first character read is an octal
731 digit, we read up to two more octal digits and return the character
732 represented by the octal number consisting of those digits.
733 Optional argument PROMPT specifies a string to use to prompt the user."
734 (let ((count 0) (code 0) char
)
736 (let ((inhibit-quit (zerop count
))
738 (and prompt
(message "%s-" prompt
))
739 (setq char
(read-char))
740 (if inhibit-quit
(setq quit-flag nil
)))
742 ((and (<= ?
0 char
) (<= char ?
7))
743 (setq code
(+ (* code
8) (- char ?
0))
745 (and prompt
(message (setq prompt
746 (format "%s %c" prompt char
)))))
748 (setq unread-command-events
(list char
) count
259))
749 (t (setq code char count
259))))
750 ;; Turn a meta-character into a character with the 0200 bit set.
751 (logior (if (/= (logand code
(lsh 1 23)) 0) 128 0)
754 (defun force-mode-line-update (&optional all
)
755 "Force the mode-line of the current buffer to be redisplayed.
756 With optional non-nil ALL, force redisplay of all mode-lines."
757 (if all
(save-excursion (set-buffer (other-buffer))))
758 (set-buffer-modified-p (buffer-modified-p)))
760 (defun momentary-string-display (string pos
&optional exit-char message
)
761 "Momentarily display STRING in the buffer at POS.
762 Display remains until next character is typed.
763 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
764 otherwise it is then available as input (as a command if nothing else).
765 Display MESSAGE (optional fourth arg) in the echo area.
766 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
767 (or exit-char
(setq exit-char ?\
))
768 (let ((buffer-read-only nil
)
769 ;; Don't modify the undo list at all.
771 (modified (buffer-modified-p))
772 (name buffer-file-name
)
778 ;; defeat file locking... don't try this at home, kids!
779 (setq buffer-file-name nil
)
780 (insert-before-markers string
)
781 (setq insert-end
(point))
782 ;; If the message end is off screen, recenter now.
783 (if (> (window-end) insert-end
)
784 (recenter (/ (window-height) 2)))
785 ;; If that pushed message start off the screen,
786 ;; scroll to start it at the top of the screen.
787 (move-to-window-line 0)
792 (message (or message
"Type %s to continue editing.")
793 (single-key-description exit-char
))
794 (let ((char (read-event)))
795 (or (eq char exit-char
)
796 (setq unread-command-events
(list char
)))))
799 (delete-region pos insert-end
)))
800 (setq buffer-file-name name
)
801 (set-buffer-modified-p modified
))))
806 (defun ignore (&rest ignore
)
807 "Do nothing and return nil.
808 This function accepts any number of arguments, but ignores them."
812 (defun error (&rest args
)
813 "Signal an error, making error message by passing all args to `format'."
815 (signal 'error
(list (apply 'format args
)))))
817 (defalias 'user-original-login-name
'user-login-name
)
819 (defun start-process-shell-command (name buffer
&rest args
)
820 "Start a program in a subprocess. Return the process object for it.
821 Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
822 NAME is name for process. It is modified if necessary to make it unique.
823 BUFFER is the buffer or (buffer-name) to associate with the process.
824 Process output goes at end of that buffer, unless you specify
825 an output stream or filter function to handle the output.
826 BUFFER may be also nil, meaning that this process is not associated
828 Third arg is command name, the name of a shell command.
829 Remaining arguments are the arguments for the command.
830 Wildcards and redirection are handled as usual in the shell."
831 (if (eq system-type
'vax-vms
)
832 (apply 'start-process name buffer args
)
833 (start-process name buffer shell-file-name
"-c"
834 (concat "exec " (mapconcat 'identity args
" ")))))
836 (defmacro save-match-data
(&rest body
)
837 "Execute the BODY forms, restoring the global value of the match data."
838 (let ((original (make-symbol "match-data")))
840 'let
(list (list original
'(match-data)))
841 (list 'unwind-protect
843 (list 'store-match-data original
)))))
845 (defun shell-quote-argument (argument)
846 "Quote an argument for passing as argument to an inferior shell."
847 ;; Quote everything except POSIX filename characters.
848 ;; This should be safe enough even for really weird shells.
849 (let ((result "") (start 0) end
)
850 (while (string-match "[^-0-9a-zA-Z_./]" argument start
)
851 (setq end
(match-beginning 0)
852 result
(concat result
(substring argument start end
)
853 "\\" (substring argument end
(1+ end
)))
855 (concat result
(substring argument start
))))
857 (defun make-syntax-table (&optional oldtable
)
858 "Return a new syntax table.
859 It inherits all letters and control characters from the standard
860 syntax table; other characters are copied from the standard syntax table."
862 (copy-syntax-table oldtable
)
863 (let ((table (copy-syntax-table))
885 ; "Returns the Nth element of LIST.
886 ;N counts from zero. If LIST is not that long, nil is returned."
887 ; (car (nthcdr n list)))
889 ;(defun copy-alist (alist)
890 ; "Return a copy of ALIST.
891 ;This is a new alist which represents the same mapping
892 ;from objects to objects, but does not share the alist structure with ALIST.
893 ;The objects mapped (cars and cdrs of elements of the alist)
894 ;are shared, however."
895 ; (setq alist (copy-sequence alist))
896 ; (let ((tail alist))
898 ; (if (consp (car tail))
899 ; (setcar tail (cons (car (car tail)) (cdr (car tail)))))
900 ; (setq tail (cdr tail))))
903 ;;; subr.el ends here