Mercurial > hg > xemacs-beta

comparison lisp/subr.el @ 404:2f8bb876ab1d r21-2-32

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-32
author cvs
date Mon, 13 Aug 2007 11:16:07 +0200
parents 74fd4e045ea6
children b8cc9ab3f761
comparison
equal deleted inserted replaced
403:9f011ab08d48 404:2f8bb876ab1d
1 ;;; subr.el --- basic lisp subroutines for XEmacs 1 ;;; subr.el --- basic lisp subroutines for XEmacs
2 2
3 ;; Copyright (C) 1985, 1986, 1992, 1994-5, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1985, 1986, 1992, 1994-5, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. 4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
5 ;; Copyright (C) 1995 Sun Microsystems. 5 ;; Copyright (C) 1995 Sun Microsystems.
6 ;; Copyright (C) 2000 Ben Wing.
6 7
7 ;; Maintainer: XEmacs Development Team 8 ;; Maintainer: XEmacs Development Team
8 ;; Keywords: extensions, dumped 9 ;; Keywords: extensions, dumped
9 10
10 ;; This file is part of XEmacs. 11 ;; This file is part of XEmacs.
115 one. 116 one.
116 117
117 This function does nothing if HOOK is already local in the current 118 This function does nothing if HOOK is already local in the current
118 buffer. 119 buffer.
119 120
120 Do not use `make-local-variable' to make a hook variable buffer-local." 121 Do not use `make-local-variable' to make a hook variable buffer-local.
122
123 See also `add-local-hook' and `remove-local-hook'."
121 (if (local-variable-p hook (current-buffer)) ; XEmacs 124 (if (local-variable-p hook (current-buffer)) ; XEmacs
122 nil 125 nil
123 (or (boundp hook) (set hook nil)) 126 (or (boundp hook) (set hook nil))
124 (make-local-variable hook) 127 (make-local-variable hook)
125 (set hook (list t)))) 128 (set hook (list t))))
137 To make a hook variable buffer-local, always use 140 To make a hook variable buffer-local, always use
138 `make-local-hook', not `make-local-variable'. 141 `make-local-hook', not `make-local-variable'.
139 142
140 HOOK should be a symbol, and FUNCTION may be any valid function. If 143 HOOK should be a symbol, and FUNCTION may be any valid function. If
141 HOOK is void, it is first set to nil. If HOOK's value is a single 144 HOOK is void, it is first set to nil. If HOOK's value is a single
142 function, it is changed to a list of functions." 145 function, it is changed to a list of functions.
146
147 You can remove this hook yourself using `remove-hook'.
148
149 See also `add-local-hook' and `add-one-shot-hook'."
143 (or (boundp hook) (set hook nil)) 150 (or (boundp hook) (set hook nil))
144 (or (default-boundp hook) (set-default hook nil)) 151 (or (default-boundp hook) (set-default hook nil))
145 ;; If the hook value is a single function, turn it into a list. 152 ;; If the hook value is a single function, turn it into a list.
146 (let ((old (symbol-value hook))) 153 (let ((old (symbol-value hook)))
147 (if (or (not (listp old)) (eq (car old) 'lambda)) 154 (if (or (not (listp old)) (eq (car old) 'lambda))
183 (if (or (not (boundp hook)) ;unbound symbol, or 190 (if (or (not (boundp hook)) ;unbound symbol, or
184 (not (default-boundp 'hook)) 191 (not (default-boundp 'hook))
185 (null (symbol-value hook)) ;value is nil, or 192 (null (symbol-value hook)) ;value is nil, or
186 (null function)) ;function is nil, then 193 (null function)) ;function is nil, then
187 nil ;Do nothing. 194 nil ;Do nothing.
188 (if (or local 195 (flet ((hook-remove
189 ;; Detect the case where make-local-variable was used on a hook 196 (function hook-value)
190 ;; and do what we used to do. 197 (flet ((hook-test
191 (and (local-variable-p hook (current-buffer)) 198 (fn hel)
192 (not (memq t (symbol-value hook))))) 199 (or (equal fn hel)
193 (let ((hook-value (symbol-value hook))) 200 (and (symbolp hel)
194 (if (and (consp hook-value) (not (functionp hook-value))) 201 (equal fn
195 (if (member function hook-value) 202 (get hel 'one-shot-hook-fun))))))
196 (setq hook-value (delete function (copy-sequence hook-value)))) 203 (if (and (consp hook-value)
197 (if (equal hook-value function) 204 (not (functionp hook-value)))
198 (setq hook-value nil))) 205 (if (member* function hook-value :test 'hook-test)
199 (set hook hook-value)) 206 (setq hook-value
200 (let ((hook-value (default-value hook))) 207 (delete* function (copy-sequence hook-value)
201 (if (and (consp hook-value) (not (functionp hook-value))) 208 :test 'hook-test)))
202 (if (member function hook-value) 209 (if (equal hook-value function)
203 (setq hook-value (delete function (copy-sequence hook-value)))) 210 (setq hook-value nil)))
204 (if (equal hook-value function) 211 hook-value)))
205 (setq hook-value nil))) 212 (if (or local
206 (set-default hook hook-value))))) 213 ;; Detect the case where make-local-variable was used on a hook
214 ;; and do what we used to do.
215 (and (local-variable-p hook (current-buffer))
216 (not (memq t (symbol-value hook)))))
217 (set hook (hook-remove function (symbol-value hook)))
218 (set-default hook (hook-remove function (default-value hook)))))))
219
220 ;; XEmacs addition
221 ;; #### we need a coherent scheme for indicating compatibility info,
222 ;; so that it can be programmatically retrieved.
223 (defun add-local-hook (hook function &optional append)
224 "Add to the local value of HOOK the function FUNCTION.
225 This modifies only the buffer-local value for the hook (which is
226 automatically make buffer-local, if necessary), not its default value.
227 FUNCTION is not added if already present.
228 FUNCTION is added (if necessary) at the beginning of the hook list
229 unless the optional argument APPEND is non-nil, in which case
230 FUNCTION is added at the end.
231
232 HOOK should be a symbol, and FUNCTION may be any valid function. If
233 HOOK is void, it is first set to nil. If HOOK's value is a single
234 function, it is changed to a list of functions.
235
236 You can remove this hook yourself using `remove-local-hook'.
237
238 See also `add-hook' and `make-local-hook'."
239 (make-local-hook hook)
240 (add-hook hook function append t))
241
242 ;; XEmacs addition
243 (defun remove-local-hook (hook function)
244 "Remove from the local value of HOOK the function FUNCTION.
245 This modifies only the buffer-local value for the hook, not its default
246 value. (Nothing happens if the hook is not buffer-local.)
247 HOOK should be a symbol, and FUNCTION may be any valid function. If
248 FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
249 list of hooks to run in HOOK, then nothing is done. See `add-hook'.
250
251 See also `add-local-hook' and `make-local-hook'."
252 (if (local-variable-p hook (current-buffer))
253 (remove-hook hook function t)))
254
255 (defun add-one-shot-hook (hook function &optional append local)
256 "Add to the value of HOOK the one-shot function FUNCTION.
257 FUNCTION will automatically be removed from the hook the first time
258 after it runs (whether to completion or to an error).
259 FUNCTION is not added if already present.
260 FUNCTION is added (if necessary) at the beginning of the hook list
261 unless the optional argument APPEND is non-nil, in which case
262 FUNCTION is added at the end.
263
264 HOOK should be a symbol, and FUNCTION may be any valid function. If
265 HOOK is void, it is first set to nil. If HOOK's value is a single
266 function, it is changed to a list of functions.
267
268 You can remove this hook yourself using `remove-hook'.
269
270 See also `add-hook', `add-local-hook', and `add-local-one-shot-hook'."
271 (let ((sym (gensym)))
272 (fset sym `(lambda (&rest args)
273 (unwind-protect
274 (apply ',function args)
275 (remove-hook ',hook ',sym ',local))))
276 (put sym 'one-shot-hook-fun function)
277 (add-hook hook sym append local)))
278
279 (defun add-local-one-shot-hook (hook function &optional append)
280 "Add to the local value of HOOK the one-shot function FUNCTION.
281 FUNCTION will automatically be removed from the hook the first time
282 after it runs (whether to completion or to an error).
283 FUNCTION is not added if already present.
284 FUNCTION is added (if necessary) at the beginning of the hook list
285 unless the optional argument APPEND is non-nil, in which case
286 FUNCTION is added at the end.
287
288 The optional fourth argument, LOCAL, if non-nil, says to modify
289 the hook's buffer-local value rather than its default value.
290 This makes no difference if the hook is not buffer-local.
291 To make a hook variable buffer-local, always use
292 `make-local-hook', not `make-local-variable'.
293
294 HOOK should be a symbol, and FUNCTION may be any valid function. If
295 HOOK is void, it is first set to nil. If HOOK's value is a single
296 function, it is changed to a list of functions.
297
298 You can remove this hook yourself using `remove-local-hook'.
299
300 See also `add-hook', `add-local-hook', and `add-local-one-shot-hook'."
301 (make-local-hook hook)
302 (add-one-shot-hook hook function append t))
207 303
208 (defun add-to-list (list-var element) 304 (defun add-to-list (list-var element)
209 "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet. 305 "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
210 The test for presence of ELEMENT is done with `equal'. 306 The test for presence of ELEMENT is done with `equal'.
211 If you want to use `add-to-list' on a variable that is not defined 307 If you want to use `add-to-list' on a variable that is not defined
343 439
344 (defmacro with-output-to-string (&rest forms) 440 (defmacro with-output-to-string (&rest forms)
345 "Collect output to `standard-output' while evaluating FORMS and return 441 "Collect output to `standard-output' while evaluating FORMS and return
346 it as a string." 442 it as a string."
347 ;; by "William G. Dubuque" <wgd@zurich.ai.mit.edu> w/ mods from Stig 443 ;; by "William G. Dubuque" <wgd@zurich.ai.mit.edu> w/ mods from Stig
348 `(with-current-buffer (get-buffer-create " *string-output*") 444 `(with-current-buffer (get-buffer-create
445 (generate-new-buffer-name " *string-output*"))
349 (setq buffer-read-only nil) 446 (setq buffer-read-only nil)
350 (buffer-disable-undo (current-buffer)) 447 (buffer-disable-undo (current-buffer))
351 (erase-buffer) 448 (erase-buffer)
352 (let ((standard-output (current-buffer))) 449 (let ((standard-output (current-buffer)))
353 ,@forms) 450 ,@forms)
397 ;; Moved from mule-coding.el. 494 ;; Moved from mule-coding.el.
398 (defmacro with-string-as-buffer-contents (str &rest body) 495 (defmacro with-string-as-buffer-contents (str &rest body)
399 "With the contents of the current buffer being STR, run BODY. 496 "With the contents of the current buffer being STR, run BODY.
400 Returns the new contents of the buffer, as modified by BODY. 497 Returns the new contents of the buffer, as modified by BODY.
401 The original current buffer is restored afterwards." 498 The original current buffer is restored afterwards."
402 `(let ((tempbuf (get-buffer-create " *string-as-buffer-contents*"))) 499 `(with-temp-buffer
403 (with-current-buffer tempbuf 500 (insert ,str)
404 (unwind-protect 501 ,@body
405 (progn 502 (buffer-string)))
406 (buffer-disable-undo (current-buffer))
407 (erase-buffer)
408 (insert ,str)
409 ,@body
410 (buffer-string))
411 (erase-buffer tempbuf)))))
412 503
413 (defun insert-face (string face) 504 (defun insert-face (string face)
414 "Insert STRING and highlight with FACE. Return the extent created." 505 "Insert STRING and highlight with FACE. Return the extent created."
415 (let ((p (point)) ext) 506 (let ((p (point)) ext)
416 (insert string) 507 (insert string)