X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fsubr.el;h=fa38653b174fddb8bde985423724b663f20a9eec;hb=4e344277e13cd8813592afc6b0bfb89474f0cbb0;hp=6a49cff64abe5980037cfd3d43aa4fa96abf3fe0;hpb=976b002b16336930724ae22476014583ad022e7d;p=chise%2Fxemacs-chise.git- diff --git a/lisp/subr.el b/lisp/subr.el index 6a49cff..fa38653 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -3,6 +3,7 @@ ;; 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 @@ -117,7 +118,9 @@ one. 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)) @@ -139,7 +142,11 @@ To make a hook variable buffer-local, always use 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. @@ -185,25 +192,114 @@ To make a hook variable buffer-local, always use (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. @@ -239,6 +335,22 @@ just before emacs is actually killed.") (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 @@ -294,10 +406,14 @@ Otherwise treat \\ in NEWTEXT string as special: If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (or pattern (setq pattern "[ \f\t\n\r\v]+")) - ;; The FSF version of this function takes care not to cons in case - ;; of infloop. Maybe we should synch? - (let (parts (start 0)) - (while (string-match pattern string start) + (let (parts (start 0) (len (length string))) + (if (string-match pattern string) + (setq parts (cons (substring string 0 (match-beginning 0)) parts) + start (match-end 0))) + (while (and (< start len) + (string-match pattern string (if (> start (match-beginning 0)) + start + (1+ start)))) (setq parts (cons (substring string start (match-beginning 0)) parts) start (match-end 0))) (nreverse (cons (substring string start) parts)))) @@ -319,7 +435,8 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." "Collect output to `standard-output' while evaluating FORMS and return it as a string." ;; by "William G. Dubuque" 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) @@ -330,7 +447,7 @@ it as a string." (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 @@ -373,16 +490,10 @@ See also `with-temp-file' and `with-output-to-string'." "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." @@ -565,9 +676,6 @@ This function accepts any number of arguments, but ignores them." (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) @@ -614,6 +722,12 @@ If FUNCTION is not interactive, nil will be returned." (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 @@ -628,13 +742,17 @@ If BUFFER is specified, the contents of that buffer are returned. 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