xemacs-beta: lisp/subr.el comparison

comparison lisp/subr.el @ 412:697ef44129c6 r21-2-14

Import from CVS: tag r21-2-14

author	cvs
date	Mon, 13 Aug 2007 11:20:41 +0200
parents	b8cc9ab3f761
children	da8ed4261e83

comparison

equal deleted inserted replaced

-:12e008d41344
+:697ef44129c6
 ;;; subr.el --- basic lisp subroutines for XEmacs
 ;; 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 file is part of XEmacs.
 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))
 (make-local-variable hook)
 (set hook (list t))))
 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.
+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.
 (let ((old (symbol-value hook)))
 (if (or (not (listp old)) (eq (car old) 'lambda))
 (if (or (not (boundp hook))		;unbound symbol, or
 	  (not (default-boundp 'hook))
 	  (null (symbol-value hook))	;value is nil, or
 	  (null function))		;function is nil, then
 nil				;Do nothing.
-(flet ((hook-remove
+(if (or local
-	    (function hook-value)
+	    ;; Detect the case where make-local-variable was used on a hook
-	    (flet ((hook-test
+	    ;; and do what we used to do.
-		    (fn hel)
+	    (and (local-variable-p hook (current-buffer))
-		    (or (equal fn hel)
+		 (not (memq t (symbol-value hook)))))
-			(and (symbolp hel)
+	(let ((hook-value (symbol-value hook)))
-			     (equal fn
+	  (if (and (consp hook-value) (not (functionp hook-value)))
-				    (get hel 'one-shot-hook-fun))))))
+	      (if (member function hook-value)
-	      (if (and (consp hook-value)
+		  (setq hook-value (delete function (copy-sequence hook-value))))
-		       (not (functionp hook-value)))
+	    (if (equal hook-value function)
-		  (if (member* function hook-value :test 'hook-test)
+		(setq hook-value nil)))
-		      (setq hook-value
+	  (set hook hook-value))
-			    (delete* function (copy-sequence hook-value)
+(let ((hook-value (default-value hook)))
-				     :test 'hook-test)))
+	(if (and (consp hook-value) (not (functionp hook-value)))
-		(if (equal hook-value function)
+	    (if (member function hook-value)
-		    (setq hook-value nil)))
+		(setq hook-value (delete function (copy-sequence hook-value))))
-	      hook-value)))
+	  (if (equal hook-value function)
-(if (or local
+	      (setq hook-value nil)))
-	      ;; Detect the case where make-local-variable was used on a hook
+	(set-default hook hook-value)))))
-	      ;; 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.
 The test for presence of ELEMENT is done with `equal'.
 If you want to use `add-to-list' on a variable that is not defined
 ;;   (setcar conscell newcar)
 ;;   conscell)
 ;; ...and analogously for RPLACD.
 (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
 (defun replace-in-string (str regexp newtext &optional literal)
 (defun split-string (string &optional pattern)
 "Return a list of substrings of STRING which are separated by PATTERN.
 If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
 (or pattern
 (setq pattern "[ \f\t\n\r\v]+"))
-(let (parts (start 0) (len (length string)))
+;; The FSF version of this function takes care not to cons in case
-(if (string-match pattern string)
+;; of infloop.  Maybe we should synch?
-	(setq parts (cons (substring string 0 (match-beginning 0)) parts)
+(let (parts (start 0))
-	      start (match-end 0)))
+(while (string-match pattern string start)
-(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))))
 ;; #### #### #### AAaargh!  Must be in C, because it is used insanely
 (defmacro with-output-to-string (&rest forms)
 "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
+`(with-current-buffer (get-buffer-create " *string-output*")
-			 (generate-new-buffer-name " *string-output*"))
 (setq buffer-read-only nil)
 (buffer-disable-undo (current-buffer))
 (erase-buffer)
 (let ((standard-output (current-buffer)))
 ,@forms)
 (prog1
 	 (buffer-string)
 (erase-buffer))))
 (defmacro with-current-buffer (buffer &rest body)
-"Temporarily make BUFFER the current buffer and execute the forms in BODY.
+"Execute the forms in BODY with BUFFER as the current buffer.
 The value returned is the value of the last form in BODY.
 See also `with-temp-buffer'."
 `(save-current-buffer
 (set-buffer ,buffer)
 ,@body))
 ;; Moved from mule-coding.el.
 (defmacro with-string-as-buffer-contents (str &rest body)
 "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."
-`(with-temp-buffer
+`(let ((tempbuf (get-buffer-create " *string-as-buffer-contents*")))
-(insert ,str)
+(with-current-buffer tempbuf
-,@body
+(unwind-protect
-(buffer-string)))
+	   (progn
+	     (buffer-disable-undo (current-buffer))
+	     (erase-buffer)
+	     (insert ,str)
+	     ,@body
+	     (buffer-string))
+	 (erase-buffer tempbuf)))))
 (defun insert-face (string face)
 "Insert STRING and highlight with FACE.  Return the extent created."
 (let ((p (point)) ext)
 (insert string)
 (defun ignore (&rest ignore)
 "Do nothing and return nil.
 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)
 ;;; The real defn is in abbrev.el but some early callers
 	   (and (eq (car-safe spec) 'interactive)
 		spec)))
 	(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
 ;; both for backward compatibility.
 (defun buffer-string (&optional buffer old-end old-buffer)
 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)."
-(cond
+(if (or (null buffer)
-((or (stringp buffer) (bufferp buffer))
+	  (bufferp buffer)
-;; Most definitely the new way.
+	  (stringp buffer))
-(buffer-substring nil nil buffer))
+;; The new way
-((or (stringp old-buffer) (bufferp old-buffer)
+(buffer-substring nil nil buffer)
-	(natnump buffer) (natnump old-end))
+;; The old way
-;; Definitely the old way.
+(buffer-substring buffer old-end old-buffer)))
-(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
 ;;; The objection is this: there is more than one way to load the same file.

Mercurial > hg > xemacs-beta

comparison lisp/subr.el @ 412:697ef44129c6 r21-2-14