;; Copyright (C) 1985, 1986, 1992, 1994-5, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
;; Copyright (C) 1995 Sun Microsystems.
+;; Copyright (C) 2000 Ben Wing.
;; Maintainer: XEmacs Development Team
;; Keywords: extensions, dumped
This function does nothing if HOOK is already local in the current
buffer.
-Do not use `make-local-variable' to make a hook variable buffer-local."
+Do not use `make-local-variable' to make a hook variable buffer-local.
+
+See also `add-local-hook' and `remove-local-hook'."
(if (local-variable-p hook (current-buffer)) ; XEmacs
nil
(or (boundp hook) (set hook nil))
HOOK should be a symbol, and FUNCTION may be any valid function. If
HOOK is void, it is first set to nil. If HOOK's value is a single
-function, it is changed to a list of functions."
+function, it is changed to a list of functions.
+
+You can remove this hook yourself using `remove-hook'.
+
+See also `add-local-hook' and `add-one-shot-hook'."
(or (boundp hook) (set hook nil))
(or (default-boundp hook) (set-default hook nil))
;; If the hook value is a single function, turn it into a list.
(null (symbol-value hook)) ;value is nil, or
(null function)) ;function is nil, then
nil ;Do nothing.
- (if (or local
- ;; Detect the case where make-local-variable was used on a hook
- ;; and do what we used to do.
- (and (local-variable-p hook (current-buffer))
- (not (memq t (symbol-value hook)))))
- (let ((hook-value (symbol-value hook)))
- (if (and (consp hook-value) (not (functionp hook-value)))
- (if (member function hook-value)
- (setq hook-value (delete function (copy-sequence hook-value))))
- (if (equal hook-value function)
- (setq hook-value nil)))
- (set hook hook-value))
- (let ((hook-value (default-value hook)))
- (if (and (consp hook-value) (not (functionp hook-value)))
- (if (member function hook-value)
- (setq hook-value (delete function (copy-sequence hook-value))))
- (if (equal hook-value function)
- (setq hook-value nil)))
- (set-default hook hook-value)))))
+ (flet ((hook-remove
+ (function hook-value)
+ (flet ((hook-test
+ (fn hel)
+ (or (equal fn hel)
+ (and (symbolp hel)
+ (equal fn
+ (get hel 'one-shot-hook-fun))))))
+ (if (and (consp hook-value)
+ (not (functionp hook-value)))
+ (if (member* function hook-value :test 'hook-test)
+ (setq hook-value
+ (delete* function (copy-sequence hook-value)
+ :test 'hook-test)))
+ (if (equal hook-value function)
+ (setq hook-value nil)))
+ hook-value)))
+ (if (or local
+ ;; Detect the case where make-local-variable was used on a hook
+ ;; and do what we used to do.
+ (and (local-variable-p hook (current-buffer))
+ (not (memq t (symbol-value hook)))))
+ (set hook (hook-remove function (symbol-value hook)))
+ (set-default hook (hook-remove function (default-value hook)))))))
+
+;; XEmacs addition
+;; #### we need a coherent scheme for indicating compatibility info,
+;; so that it can be programmatically retrieved.
+(defun add-local-hook (hook function &optional append)
+ "Add to the local value of HOOK the function FUNCTION.
+This modifies only the buffer-local value for the hook (which is
+automatically make buffer-local, if necessary), not its default value.
+FUNCTION is not added if already present.
+FUNCTION is added (if necessary) at the beginning of the hook list
+unless the optional argument APPEND is non-nil, in which case
+FUNCTION is added at the end.
+
+HOOK should be a symbol, and FUNCTION may be any valid function. If
+HOOK is void, it is first set to nil. If HOOK's value is a single
+function, it is changed to a list of functions.
+
+You can remove this hook yourself using `remove-local-hook'.
+
+See also `add-hook' and `make-local-hook'."
+ (make-local-hook hook)
+ (add-hook hook function append t))
+
+;; XEmacs addition
+(defun remove-local-hook (hook function)
+ "Remove from the local value of HOOK the function FUNCTION.
+This modifies only the buffer-local value for the hook, not its default
+value. (Nothing happens if the hook is not buffer-local.)
+HOOK should be a symbol, and FUNCTION may be any valid function. If
+FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
+list of hooks to run in HOOK, then nothing is done. See `add-hook'.
+
+See also `add-local-hook' and `make-local-hook'."
+ (if (local-variable-p hook (current-buffer))
+ (remove-hook hook function t)))
+
+(defun add-one-shot-hook (hook function &optional append local)
+ "Add to the value of HOOK the one-shot function FUNCTION.
+FUNCTION will automatically be removed from the hook the first time
+after it runs (whether to completion or to an error).
+FUNCTION is not added if already present.
+FUNCTION is added (if necessary) at the beginning of the hook list
+unless the optional argument APPEND is non-nil, in which case
+FUNCTION is added at the end.
+
+HOOK should be a symbol, and FUNCTION may be any valid function. If
+HOOK is void, it is first set to nil. If HOOK's value is a single
+function, it is changed to a list of functions.
+
+You can remove this hook yourself using `remove-hook'.
+
+See also `add-hook', `add-local-hook', and `add-local-one-shot-hook'."
+ (let ((sym (gensym)))
+ (fset sym `(lambda (&rest args)
+ (unwind-protect
+ (apply ',function args)
+ (remove-hook ',hook ',sym ',local))))
+ (put sym 'one-shot-hook-fun function)
+ (add-hook hook sym append local)))
+
+(defun add-local-one-shot-hook (hook function &optional append)
+ "Add to the local value of HOOK the one-shot function FUNCTION.
+FUNCTION will automatically be removed from the hook the first time
+after it runs (whether to completion or to an error).
+FUNCTION is not added if already present.
+FUNCTION is added (if necessary) at the beginning of the hook list
+unless the optional argument APPEND is non-nil, in which case
+FUNCTION is added at the end.
+
+The optional fourth argument, LOCAL, if non-nil, says to modify
+the hook's buffer-local value rather than its default value.
+This makes no difference if the hook is not buffer-local.
+To make a hook variable buffer-local, always use
+`make-local-hook', not `make-local-variable'.
+
+HOOK should be a symbol, and FUNCTION may be any valid function. If
+HOOK is void, it is first set to nil. If HOOK's value is a single
+function, it is changed to a list of functions.
+
+You can remove this hook yourself using `remove-local-hook'.
+
+See also `add-hook', `add-local-hook', and `add-local-one-shot-hook'."
+ (make-local-hook hook)
+ (add-one-shot-hook hook function append t))
(defun add-to-list (list-var element)
"Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
(define-function 'rplaca 'setcar)
(define-function 'rplacd 'setcdr)
+(defun copy-symbol (symbol &optional copy-properties)
+ "Return a new uninterned symbol with the same name as SYMBOL.
+If COPY-PROPERTIES is non-nil, the new symbol will have a copy of
+SYMBOL's value, function, and property lists."
+ (let ((new (make-symbol (symbol-name symbol))))
+ (when copy-properties
+ ;; This will not copy SYMBOL's chain of forwarding objects, but
+ ;; I think that's OK. Callers should not expect such magic to
+ ;; keep working in the copy in the first place.
+ (and (boundp symbol)
+ (set new (symbol-value symbol)))
+ (and (fboundp symbol)
+ (fset new (symbol-function symbol)))
+ (setplist new (copy-list (symbol-plist symbol))))
+ new))
+
;;;; String functions.
;; XEmacs
"Collect output to `standard-output' while evaluating FORMS and return
it as a string."
;; by "William G. Dubuque" <wgd@zurich.ai.mit.edu> w/ mods from Stig
- `(with-current-buffer (get-buffer-create " *string-output*")
+ `(with-current-buffer (get-buffer-create
+ (generate-new-buffer-name " *string-output*"))
(setq buffer-read-only nil)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(erase-buffer))))
(defmacro with-current-buffer (buffer &rest body)
- "Execute the forms in BODY with BUFFER as the current buffer.
+ "Temporarily make BUFFER the current buffer and execute the forms in BODY.
The value returned is the value of the last form in BODY.
See also `with-temp-buffer'."
`(save-current-buffer
"With the contents of the current buffer being STR, run BODY.
Returns the new contents of the buffer, as modified by BODY.
The original current buffer is restored afterwards."
- `(let ((tempbuf (get-buffer-create " *string-as-buffer-contents*")))
- (with-current-buffer tempbuf
- (unwind-protect
- (progn
- (buffer-disable-undo (current-buffer))
- (erase-buffer)
- (insert ,str)
- ,@body
- (buffer-string))
- (erase-buffer tempbuf)))))
+ `(with-temp-buffer
+ (insert ,str)
+ ,@body
+ (buffer-string)))
(defun insert-face (string face)
"Insert STRING and highlight with FACE. Return the extent created."
(interactive)
nil)
-(define-function 'mapc-internal 'mapc)
-(make-obsolete 'mapc-internal 'mapc)
-
(define-function 'eval-in-buffer 'with-current-buffer)
(make-obsolete 'eval-in-buffer 'with-current-buffer)
(t
(error "Non-funcallable object: %s" function))))
+(defun function-allows-args (function n)
+ "Return whether FUNCTION can be called with N arguments."
+ (and (<= (function-min-args function) n)
+ (or (null (function-max-args function))
+ (<= n (function-max-args function)))))
+
;; This function used to be an alias to `buffer-substring', except
;; that FSF Emacs 20.4 added a BUFFER argument in an incompatible way.
;; The new FSF's semantics makes more sense, but we try to support
The arguments OLD-END and OLD-BUFFER are supported for backward
compatibility with pre-21.2 XEmacsen times when arguments to this
function were (buffer-string &optional START END BUFFER)."
- (if (or (null buffer)
- (bufferp buffer)
- (stringp buffer))
- ;; The new way
- (buffer-substring nil nil buffer)
- ;; The old way
- (buffer-substring buffer old-end old-buffer)))
+ (cond
+ ((or (stringp buffer) (bufferp buffer))
+ ;; Most definitely the new way.
+ (buffer-substring nil nil buffer))
+ ((or (stringp old-buffer) (bufferp old-buffer)
+ (natnump buffer) (natnump old-end))
+ ;; Definitely the old way.
+ (buffer-substring buffer old-end old-buffer))
+ (t
+ ;; Probably the old way.
+ (buffer-substring buffer old-end old-buffer))))
;; This was not present before. I think Jamie had some objections
;; to this, so I'm leaving this undefined for now. --ben
projects / chise / xemacs-chise.git.1 / blobdiff