xemacs-beta: lisp/subr.el comparison

comparison lisp/subr.el @ 1333:1b0339b048ce

[xemacs-hg @ 2003-03-02 09:38:37 by ben] To: xemacs-patches@xemacs.org PROBLEMS: Include nt/PROBLEMS and update. Add note about incremental linking badness. cmdloop.el, custom.el, dumped-lisp.el, files.el, keydefs.el, keymap.el, lisp-mode.el, make-docfile.el, replace.el, simple.el, subr.el, view-less.el, wid-edit.el: Lots of syncing with FSF 21.2. Use if-fboundp in wid-edit.el. New file newcomment.el from FSF. internals/internals.texi: Fix typo. (Build-Time Dependencies): New node. PROBLEMS: Delete. config.inc.samp, xemacs.mak: Eliminate HAVE_VC6, use SUPPORT_EDIT_AND_CONTINUE in its place. No incremental linking unless SUPPORT_EDIT_AND_CONTINUE, since it can cause nasty crashes in pdump. Put warnings about this in config.inc.samp. Report the full compile flags used for src and lib-src in the Installation output. alloc.c, lisp.h, ralloc.c, regex.c: Use ALLOCA() in regex.c to avoid excessive stack allocation. Also fix subtle problem with REL_ALLOC() -- any call to malloc() (direct or indirect) may relocate rel-alloced data, causing buffer text to shift. After any such call, regex must update all its pointers to such data. Add a system, when ERROR_CHECK_MALLOC, whereby regex.c indicates all the places it is prepared to handle malloc()/realloc()/free(), and any calls anywhere in XEmacs outside of this will trigger an abort. alloc.c, dialog-msw.c, eval.c, event-stream.c, general-slots.h, insdel.c, lisp.h, menubar-msw.c, menubar-x.c: Change *run_hook*_trapping_problems to take a warning class, not a string. Factor out code to issue warnings, add flag to call_trapping_problems() to postpone warning issue, and make *run_hook*_trapping_problems issue their own warnings tailored to the hook, postponed in the case of safe_run_hook_trapping_problems() so that the appropriate message can be issued about resetting to nil only when not `quit'. Make record_unwind_protect_restoring_int() non-static. dumper.c: Issue notes about incremental linking problems under Windows. fileio.c: Mule-ize encrypt/decrypt-string code. text.h: Spacing changes.

author	ben
date	Sun, 02 Mar 2003 09:38:54 +0000
parents	3a01f3148bff
children	c9b6a2fec10d

comparison

equal deleted inserted replaced

-:6aa23bb3da6b
+:1b0339b048ce
 ;;; 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, 2001, 2002 Ben Wing.
+;; Copyright (C) 2000, 2001, 2002, 2003 Ben Wing.
 ;; Maintainer: XEmacs Development Team
 ;; Keywords: extensions, dumped
 ;; This file is part of XEmacs.
 ;; You should have received a copy of the GNU General Public License
 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 ;; 02111-1307, USA.
-;;; Synched up with: FSF 19.34.
+;;; Synched up with: FSF 19.34.  Some things synched up with later versions.
 ;;; Commentary:
 ;; This file is dumped with XEmacs.
 ;; There's not a whole lot in common now with the FSF version,
 ;; be wary when applying differences.  I've left in a number of lines
 ;; of commentary just to give diff(1) something to synch itself with to
 ;; provide useful context diffs. -sb
+;; BEGIN SYNCHED WITH FSF 21.2
 ;;; Code:
+(defvar custom-declare-variable-list nil
+"Record `defcustom' calls made before `custom.el' is loaded to handle them.
+Each element of this list holds the arguments to one call to `defcustom'.")
+;; Use this, rather than defcustom, in subr.el and other files loaded
+;; before custom.el.
+(defun custom-declare-variable-early (&rest arguments)
+(setq custom-declare-variable-list
+	(cons arguments custom-declare-variable-list)))
 ;;;; Lisp language features.
 (defmacro lambda (&rest cdr)
 "Return a lambda expression.
 INTERACTIVE should be a call to the function `interactive', which see.
 It may also be omitted.
 BODY should be a list of lisp expressions."
 `(function (lambda ,@cdr)))
+;; FSF 21.2 has various basic macros here.  We don't because they're either
+;; in cl*.el (which we dump and hence is always available) or built-in.
+;; More powerful versions in cl.el.
+;(defmacro push (newelt listname)
+;(defmacro pop (listname)
+;; Built-in.
+;(defmacro when (cond &rest body)
+;(defmacro unless (cond &rest body)
+;; More powerful versions in cl-macs.el.
+;(defmacro dolist (spec &rest body)
+;(defmacro dotimes (spec &rest body)
+;; In cl.el.  Ours are defun, but cl arranges for them to be inlined anyway.
+;(defsubst caar (x)
+;(defsubst cadr (x)
+;(defsubst cdar (x)
+;(defsubst cddr (x)
+;; Built-in.  Our `last' is more powerful in that it handles circularity.
+;(defun last (x &optional n)
+;(defun butlast (x &optional n)
+;(defun nbutlast (x &optional n)
+;; In cl-seq.el.
+;(defun remove (elt seq)
+;(defun remq (elt list)
 (defmacro defun-when-void (&rest args)
 "Define a function, just like `defun', unless it's already defined.
 Used for compatibility among different emacs variants."
 `(if (fboundp ',(car args))
 nil
 `(if (fboundp ,(car args))
 nil
 (define-function ,@args)))
+(defun assoc-default (key alist &optional test default)
+"Find object KEY in a pseudo-alist ALIST.
+ALIST is a list of conses or objects.  Each element (or the element's car,
+if it is a cons) is compared with KEY by evaluating (TEST (car elt) KEY).
+If that is non-nil, the element matches;
+then `assoc-default' returns the element's cdr, if it is a cons,
+or DEFAULT if the element is not a cons.
+If no element matches, the value is nil.
+If TEST is omitted or nil, `equal' is used."
+(let (found (tail alist) value)
+(while (and tail (not found))
+(let ((elt (car tail)))
+	(when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
+	  (setq found t value (if (consp elt) (cdr elt) default))))
+(setq tail (cdr tail)))
+value))
+(defun assoc-ignore-case (key alist)
+"Like `assoc', but ignores differences in case and text representation.
+KEY must be a string.  Upper-case and lower-case letters are treated as equal."
+(let (element)
+(while (and alist (not element))
+(if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil t))
+	  (setq element (car alist)))
+(setq alist (cdr alist)))
+element))
+(defun assoc-ignore-representation (key alist)
+"Like `assoc', but ignores differences in text representation.
+KEY must be a string."
+(let (element)
+(while (and alist (not element))
+(if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil))
+	  (setq element (car alist)))
+(setq alist (cdr alist)))
+element))
+(defun member-ignore-case (elt list)
+"Like `member', but ignores differences in case and text representation.
+ELT must be a string.  Upper-case and lower-case letters are treated as equal."
+(while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t))))
+(setq list (cdr list)))
+list)
 ;;;; Keymap support.
 ;; XEmacs: removed to keymap.el
 ;;;; The global keymap tree.
 ;;;; Event manipulation functions.
 ;; XEmacs: This stuff is done in C Code.
-;;;; Obsolescent names for functions.
+;;;; Obsolescent names for functions generally appear elsewhere, in
-;; XEmacs: not used.
+;;;; obsolete.el or in the files they are related do.  Many very old
+;;;; obsolete stuff has been removed entirely (e.g. anything with `dot' in
+;;;; place of `point').
+; alternate names (not obsolete)
+(if (not (fboundp 'mod)) (define-function 'mod '%))
+(define-function 'move-marker 'set-marker)
+(define-function 'beep 'ding)		; preserve lingual purity
+(define-function 'indent-to-column 'indent-to)
+(define-function 'backward-delete-char 'delete-backward-char)
+(define-function 'search-forward-regexp (symbol-function 're-search-forward))
+(define-function 'search-backward-regexp (symbol-function 're-search-backward))
+(define-function 'remove-directory 'delete-directory)
+(define-function 'set-match-data 'store-match-data)
+(define-function 'send-string-to-terminal 'external-debugging-output)
 ;; XEmacs:
 (defun local-variable-if-set-p (sym buffer)
 "Return t if SYM would be local to BUFFER after it is set.
 A nil value for BUFFER is *not* the same as (current-buffer), but
 ;; (defconst run-hooks 'run-hooks ...)
 (defun make-local-hook (hook)
 "Make the hook HOOK local to the current buffer.
+The return value is HOOK.
+You never need to call this function now that `add-hook' does it for you
+if its LOCAL argument is non-nil.
 When a hook is local, its local and global values
 work in concert: running the hook actually runs all the hook
 functions listed in *either* the local value *or* the global value
 of the hook variable.
 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))))
+(set hook (list t)))
+hook)
 (defun add-hook (hook function &optional append local)
 "Add to the value of HOOK the function FUNCTION.
 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.
+This makes the hook buffer-local if needed.
 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-hook'.
-See also `add-local-hook' and `add-one-shot-hook'."
+See also `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.
+(if local (unless (local-variable-if-set-p hook (current-buffer)) ; XEmacs
-(let ((old (symbol-value hook)))
+	      (make-local-hook hook))
-(if (or (not (listp old)) (eq (car old) 'lambda))
+;; Detect the case where make-local-variable was used on a hook
-	(set hook (list old))))
+;; and do what we used to do.
-(if (or local
+(unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
-	  ;; Detect the case where make-local-variable was used on a hook
+(setq local t)))
-	  ;; and do what we used to do.
+(let ((hook-value (if local (symbol-value hook) (default-value hook))))
-	  (and (local-variable-if-set-p hook (current-buffer)) ; XEmacs
+;; If the hook value is a single function, turn it into a list.
-	       (not (memq t (symbol-value hook)))))
+(when (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
-;; Alter the local value only.
+(setq hook-value (list hook-value)))
-(or (if (consp function)
+;; Do the actual addition if necessary
-	      (member function (symbol-value hook))
+(unless (member function hook-value)
-	    (memq function (symbol-value hook)))
+(setq hook-value
-	  (set hook
+	    (if append
-	       (if append
+		(append hook-value (list function))
-		   (append (symbol-value hook) (list function))
+	      (cons function hook-value))))
-		 (cons function (symbol-value hook)))))
+;; Set the actual variable
-;; Alter the global value (which is also the only value,
+(if local (set hook hook-value) (set-default hook hook-value))))
-;; if the hook doesn't have a local value).
-(or (if (consp function)
-	    (member function (default-value hook))
-	  (memq function (default-value hook)))
-	(set-default hook
-		     (if append
-			 (append (default-value hook) (list function))
-		       (cons function (default-value hook)))))))
 (defun remove-hook (hook function &optional local)
 "Remove from the value of HOOK the function FUNCTION.
 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'.
 The optional third 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.
+This makes the hook buffer-local if needed.
 To make a hook variable buffer-local, always use
 `make-local-hook', not `make-local-variable'."
-(if (or (not (boundp hook))		;unbound symbol, or
+(or (boundp hook) (set hook nil))
-	  (not (default-boundp 'hook))
+(or (default-boundp hook) (set-default hook nil))
-	  (null (symbol-value hook))	;value is nil, or
+(if local (unless (local-variable-if-set-p hook (current-buffer)) ; XEmacs
-	  (null function))		;function is nil, then
+	      (make-local-hook hook))
-nil				;Do nothing.
+;; Detect the case where make-local-variable was used on a hook
-(flet ((hook-remove
+;; and do what we used to do.
-	     (function hook-value)
+(unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
-	     (flet ((hook-test
+(setq local t)))
-		      (fn hel)
+(let ((hook-value (if local (symbol-value hook) (default-value hook))))
-		      (or (equal fn hel)
+;; Remove the function, for both the list and the non-list cases.
-			  (and (symbolp hel)
+;; XEmacs: add hook-test, for handling one-shot hooks.
-			       (equal fn
+(flet ((hook-test
-				      (get hel 'one-shot-hook-fun))))))
+	     (fn hel)
-	       (if (and (consp hook-value)
+	     (or (equal fn hel)
-		     (not (functionp hook-value)))
+		 (and (symbolp hel)
-		   (if (member* function hook-value :test 'hook-test)
+		      (equal fn
-		     (setq hook-value
+			     (get hel 'one-shot-hook-fun))))))
-			   (delete* function (copy-sequence hook-value)
+(if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
-				    :test 'hook-test)))
+	  (if (equal hook-value function) (setq hook-value nil))
-		 (if (equal hook-value function)
+	(setq hook-value (delete* function (copy-sequence hook-value)
-		   (setq hook-value nil)))
+				  :test 'hook-test)))
-	       hook-value)))
+;; If the function is on the global hook, we need to shadow it locally
-(if (or local
+;;(when (and local (member* function (default-value hook)
-	    ;; Detect the case where make-local-variable was used on a hook
+;;                          :test 'hook-test)
-	    ;; and do what we used to do.
+;;	       (not (member* (cons 'not function) hook-value
-	    (and (local-variable-p hook (current-buffer))
+;;                             :test 'hook-test)))
-		 (not (memq t (symbol-value hook)))))
+;;  (push (cons 'not function) hook-value))
-	  (set hook (hook-remove function (symbol-value hook)))
+;; Set the actual variable
-	(set-default hook (hook-remove function (default-value hook)))))))
+(if local (set hook hook-value) (set-default hook hook-value)))))
 ;; 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
+You don't need this any more.  It's equivalent to specifying the LOCAL
-automatically make buffer-local, if necessary), not its default value.
+argument to `add-hook'."
-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
+You don't need this any more.  It's equivalent to specifying the LOCAL
-value. (Nothing happens if the hook is not buffer-local.)
+argument to `remove-hook'."
-HOOK should be a symbol, and FUNCTION may be any valid function.  If
+(remove-hook hook function t))
-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).
 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'."
+See also `add-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
+You don't need this any more.  It's equivalent to specifying the LOCAL
-after it runs (whether to completion or to an error).
+argument to `add-one-shot-hook'."
-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 &optional append)
 "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'.
 (symbol-value list-var)
 (set list-var
 (if append
 (append (symbol-value list-var) (list element))
 (cons element (symbol-value list-var))))))
+;; END SYNCHED WITH FSF 21.2
 ;; XEmacs additions
 ;; called by Fkill_buffer()
 (defvar kill-buffer-hook nil
 "Function or functions to be called when a buffer is killed.
 NOTE: At some point, this will be moved into C and will be very fast."
 (with-current-buffer buffer
 (set sym val)))
-;;;; String functions.
+;; BEGIN SYNCHED WITH FSF 21.2
-;; XEmacs
-(defun string-equal-ignore-case (str1 str2)
+;; #### #### #### AAaargh!  Must be in C, because it is used insanely
-"Return t if two strings have identical contents, ignoring case differences.
+;; early in the bootstrap process.
-Case is not significant.  Text properties and extents are ignored.
+;(defun split-path (path)
-Symbols are also allowed; their print names are used instead.
+;  "Explode a search path into a list of strings.
+;The path components are separated with the characters specified
-See also `equalp'."
+;with `path-separator'."
-(if (symbolp str1)
+;  (while (or (not stringp path-separator)
-(setq str1 (symbol-name str1)))
+;	     (/= (length path-separator) 1))
-(if (symbolp str2)
+;    (setq path-separator (signal 'error (list "\
-(setq str2 (symbol-name str2)))
+;`path-separator' should be set to a single-character string"
-(eq t (compare-strings str1 nil nil str2 nil nil t)))
+;					      path-separator))))
+;  (split-string-by-char path (aref separator 0)))
-;; XEmacs
+(defmacro with-current-buffer (buffer &rest body)
+"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
+(set-buffer ,buffer)
+,@body))
+(defmacro with-temp-file (filename &rest forms)
+"Create a new buffer, evaluate FORMS there, and write the buffer to FILENAME.
+The value of the last form in FORMS is returned, like `progn'.
+See also `with-temp-buffer'."
+(let ((temp-file (make-symbol "temp-file"))
+	(temp-buffer (make-symbol "temp-buffer")))
+`(let ((,temp-file ,filename)
+	   (,temp-buffer
+	    (get-buffer-create (generate-new-buffer-name " *temp file*"))))
+(unwind-protect
+	   (prog1
+	       (with-current-buffer ,temp-buffer
+		 ,@forms)
+	     (with-current-buffer ,temp-buffer
+(widen)
+	       (write-region (point-min) (point-max) ,temp-file nil 0)))
+	 (and (buffer-name ,temp-buffer)
+	      (kill-buffer ,temp-buffer))))))
+;; FSF compatibility
+(defmacro with-temp-message (message &rest body)
+"Display MESSAGE temporarily while BODY is evaluated.
+The original message is restored to the echo area after BODY has finished.
+The value returned is the value of the last form in BODY.
+If MESSAGE is nil, the echo area and message log buffer are unchanged.
+Use a MESSAGE of \"\" to temporarily clear the echo area.
+Note that this function exists for FSF compatibility purposes.  A better way
+under XEmacs is to give the message a particular label (see `display-message');
+then, the old message is automatically restored when you clear your message
+with `clear-message'."
+;; FSF additional doc string from 21.2:
+;; MESSAGE is written to the message log buffer if `message-log-max' is non-nil.
+(let ((current-message (make-symbol "current-message"))
+	(temp-message (make-symbol "with-temp-message")))
+`(let ((,temp-message ,message)
+	   (,current-message))
+(unwind-protect
+	   (progn
+	     (when ,temp-message
+	       (setq ,current-message (current-message))
+	       (message "%s" ,temp-message))
+	     ,@body)
+	 (and ,temp-message ,current-message
+	      (message "%s" ,current-message))))))
+(defmacro with-temp-buffer (&rest forms)
+"Create a temporary buffer, and evaluate FORMS there like `progn'.
+See also `with-temp-file' and `with-output-to-string'."
+(let ((temp-buffer (make-symbol "temp-buffer")))
+`(let ((,temp-buffer
+	    (get-buffer-create (generate-new-buffer-name " *temp*"))))
+(unwind-protect
+	   (with-current-buffer ,temp-buffer
+	     ,@forms)
+	 (and (buffer-name ,temp-buffer)
+	      (kill-buffer ,temp-buffer))))))
+(defmacro with-output-to-string (&rest body)
+"Execute BODY, return the text it sent to `standard-output', as a string."
+`(let ((standard-output
+	  (get-buffer-create (generate-new-buffer-name " *string-output*"))))
+(let ((standard-output standard-output))
+,@body)
+(with-current-buffer standard-output
+(prog1
+	   (buffer-string)
+	 (kill-buffer nil)))))
+;; FSF 21.2.
+; (defmacro combine-after-change-calls (&rest body)
+;   "Execute BODY, but don't call the after-change functions till the end.
+; If BODY makes changes in the buffer, they are recorded
+; and the functions on `after-change-functions' are called several times
+; when BODY is finished.
+; The return value is the value of the last form in BODY.
+; If `before-change-functions' is non-nil, then calls to the after-change
+; functions can't be deferred, so in that case this macro has no effect.
+; Do not alter `after-change-functions' or `before-change-functions'
+; in BODY."
+;   `(unwind-protect
+;        (let ((combine-after-change-calls t))
+; 	 . ,body)
+;      (combine-after-change-execute)))
+(defmacro with-syntax-table (table &rest body)
+"Evaluate BODY with syntax table of current buffer set to a copy of TABLE.
+The syntax table of the current buffer is saved, BODY is evaluated, and the
+saved table is restored, even in case of an abnormal exit.
+Value is what BODY returns."
+(let ((old-table (make-symbol "table"))
+	(old-buffer (make-symbol "buffer")))
+`(let ((,old-table (syntax-table))
+	   (,old-buffer (current-buffer)))
+(unwind-protect
+	   (progn
+	     (set-syntax-table (copy-syntax-table ,table))
+	     ,@body)
+	 (save-current-buffer
+	   (set-buffer ,old-buffer)
+	   (set-syntax-table ,old-table))))))
+(put 'with-syntax-table 'lisp-indent-function 1)
+(put 'with-syntax-table 'edebug-form-spec '(form 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
+(insert ,str)
+,@body
+(buffer-string)))
+(defmacro save-match-data (&rest body)
+"Execute BODY forms, restoring the global value of the match data."
+(let ((original (make-symbol "match-data")))
+(list 'let (list (list original '(match-data)))
+	  (list 'unwind-protect
+		(cons 'progn body)
+		(list 'store-match-data original)))))
+(defun match-string (num &optional string)
+"Return string of text matched by last search.
+NUM specifies which parenthesized expression in the last regexp.
+Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
+Zero means the entire text matched by the whole regexp or whole string.
+STRING should be given if the last search was by `string-match' on STRING."
+(if (match-beginning num)
+(if string
+(substring string (match-beginning num) (match-end num))
+(buffer-substring (match-beginning num) (match-end num)))))
+(defun match-string-no-properties (num &optional string)
+"Return string of text matched by last search, without text properties.
+NUM specifies which parenthesized expression in the last regexp.
+Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
+Zero means the entire text matched by the whole regexp or whole string.
+STRING should be given if the last search was by `string-match' on STRING."
+(if (match-beginning num)
+(if string
+	  (let ((result
+		 (substring string (match-beginning num) (match-end num))))
+	    (set-text-properties 0 (length result) nil result)
+	    result)
+	(buffer-substring-no-properties (match-beginning num)
+					(match-end num)))))
+(defun split-string (string &optional separators)
+"Splits STRING into substrings where there are matches for SEPARATORS.
+Each match for SEPARATORS is a splitting point.
+The substrings between the splitting points are made into a list
+which is returned.
+If SEPARATORS is absent, it defaults to \"[ \\f\\t\\n\\r\\v]+\".
+If there is match for SEPARATORS at the beginning of STRING, we do not
+include a null substring for that.  Likewise, if there is a match
+at the end of STRING, we don't include a null substring for that.
+Modifies the match data; use `save-match-data' if necessary."
+(let ((rexp (or separators "[ \f\t\n\r\v]+"))
+	(start 0)
+	notfirst
+	(list nil))
+(while (and (string-match rexp string
+			      (if (and notfirst
+				       (= start (match-beginning 0))
+				       (< start (length string)))
+				  (1+ start) start))
+		(< (match-beginning 0) (length string)))
+(setq notfirst t)
+(or (eq (match-beginning 0) 0)
+	  (and (eq (match-beginning 0) (match-end 0))
+	       (eq (match-beginning 0) start))
+	  (setq list
+		(cons (substring string start (match-beginning 0))
+		      list)))
+(setq start (match-end 0)))
+(or (eq start (length string))
+	(setq list
+	      (cons (substring string start)
+		    list)))
+(nreverse list)))
+(defun subst-char-in-string (fromchar tochar string &optional inplace)
+"Replace FROMCHAR with TOCHAR in STRING each time it occurs.
+Unless optional argument INPLACE is non-nil, return a new string."
+(let ((i (length string))
+	(newstr (if inplace string (copy-sequence string))))
+(while (> i 0)
+(setq i (1- i))
+(if (eq (aref newstr i) fromchar)
+	  (aset newstr i tochar)))
+newstr))
+;; XEmacs addition:
 (defun replace-in-string (str regexp newtext &optional literal)
 "Replace all matches in STR for REGEXP with NEWTEXT string,
 and returns the new string.
 Optional LITERAL non-nil means do a literal replacement.
 Otherwise treat `\\' in NEWTEXT as special:
 	(setq newstr (replace-match newtext t literal str)
 	      start (+ (match-end 0) (- (length newstr) (length str)))
 	      str newstr))
 str)))
-(defun split-string (string &optional pattern)
+(defun replace-regexp-in-string (regexp rep string &optional
-"Return a list of substrings of STRING which are separated by PATTERN.
+					fixedcase literal subexp start)
-If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
+"Replace all matches for REGEXP with REP in STRING.
-(or pattern
-(setq pattern "[ \f\t\n\r\v]+"))
+Return a new string containing the replacements.
-(let (parts (start 0) (len (length string)))
-(if (string-match pattern string)
+Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the
-	(setq parts (cons (substring string 0 (match-beginning 0)) parts)
+arguments with the same names of function `replace-match'.  If START
-	      start (match-end 0)))
+is non-nil, start replacements at that index in STRING.
-(while (and (< start len)
-		(string-match pattern string (if (> start (match-beginning 0))
+REP is either a string used as the NEWTEXT arg of `replace-match' or a
-						 start
+function.  If it is a function it is applied to each match to generate
-					       (1+ start))))
+the replacement passed to `replace-match'; the match-data at this
-(setq parts (cons (substring string start (match-beginning 0)) parts)
+point are such that match 0 is the function's argument.
-	    start (match-end 0)))
-(nreverse (cons (substring string start) parts))))
+To replace only the first match (if any), make REGEXP match up to \\'
+and replace a sub-expression, e.g.
-;; #### #### #### AAaargh!  Must be in C, because it is used insanely
+(replace-regexp-in-string \"\\(foo\\).*\\'\" \"bar\" \" foo foo\" nil nil 1)
-;; early in the bootstrap process.
+=> \" bar foo\"
-;(defun split-path (path)
+"
-;  "Explode a search path into a list of strings.
-;The path components are separated with the characters specified
+;; To avoid excessive consing from multiple matches in long strings,
-;with `path-separator'."
+;; don't just call `replace-match' continually.  Walk down the
-;  (while (or (not stringp path-separator)
+;; string looking for matches of REGEXP and building up a (reversed)
-;	     (/= (length path-separator) 1))
+;; list MATCHES.  This comprises segments of STRING which weren't
-;    (setq path-separator (signal 'error (list "\
+;; matched interspersed with replacements for segments that were.
-;`path-separator' should be set to a single-character string"
+;; [For a `large' number of replacments it's more efficient to
-;					      path-separator))))
+;; operate in a temporary buffer; we can't tell from the function's
-;  (split-string-by-char path (aref separator 0)))
+;; args whether to choose the buffer-based implementation, though it
+;; might be reasonable to do so for long enough STRING.]
-(defmacro with-output-to-string (&rest body)
+(let ((l (length string))
-"Execute BODY, return the text it sent to `standard-output', as a string."
+	(start (or start 0))
-`(let ((standard-output
+	matches str mb me)
-	  (get-buffer-create (generate-new-buffer-name " *string-output*"))))
+(save-match-data
-(let ((standard-output standard-output))
+(while (and (< start l) (string-match regexp string start))
-,@body)
+	(setq mb (match-beginning 0)
-(with-current-buffer standard-output
+	      me (match-end 0))
-(prog1
+	;; If we matched the empty string, make sure we advance by one char
-	   (buffer-string)
+	(when (= me mb) (setq me (min l (1+ mb))))
-	 (kill-buffer nil)))))
+	;; Generate a replacement for the matched substring.
+	;; Operate only on the substring to minimize string consing.
-(defmacro with-current-buffer (buffer &rest body)
+	;; Set up match data for the substring for replacement;
-"Temporarily make BUFFER the current buffer and execute the forms in BODY.
+	;; presumably this is likely to be faster than munging the
-The value returned is the value of the last form in BODY.
+	;; match data directly in Lisp.
-See also `with-temp-buffer'."
+	(string-match regexp (setq str (substring string mb me)))
-`(save-current-buffer
+	(setq matches
-(set-buffer ,buffer)
+	      (cons (replace-match (if (stringp rep)
-,@body))
+				       rep
+				     (funcall rep (match-string 0 str)))
-(defmacro with-temp-file (filename &rest forms)
+				   fixedcase literal str subexp)
-"Create a new buffer, evaluate FORMS there, and write the buffer to FILENAME.
+		    (cons (substring string start mb) ; unmatched prefix
-The value of the last form in FORMS is returned, like `progn'.
+			  matches)))
-See also `with-temp-buffer'."
+	(setq start me))
-(let ((temp-file (make-symbol "temp-file"))
+;; Reconstruct a string from the pieces.
-	(temp-buffer (make-symbol "temp-buffer")))
+(setq matches (cons (substring string start l) matches)) ; leftover
-`(let ((,temp-file ,filename)
+(apply #'concat (nreverse matches)))))
-	   (,temp-buffer
-	    (get-buffer-create (generate-new-buffer-name " *temp file*"))))
+;; END SYNCHED WITH FSF 21.2
-(unwind-protect
-	   (prog1
-	       (with-current-buffer ,temp-buffer
+;;; Basic string functions
-		 ,@forms)
-	     (with-current-buffer ,temp-buffer
+;; XEmacs
-(widen)
+(defun string-equal-ignore-case (str1 str2)
-	       (write-region (point-min) (point-max) ,temp-file nil 0)))
+"Return t if two strings have identical contents, ignoring case differences.
-	 (and (buffer-name ,temp-buffer)
+Case is not significant.  Text properties and extents are ignored.
-	      (kill-buffer ,temp-buffer))))))
+Symbols are also allowed; their print names are used instead.
-(defmacro with-temp-message (message &rest body)
+See also `equalp'."
-"Display MESSAGE temporarily while BODY is evaluated.
+(if (symbolp str1)
-The original message is restored to the echo area after BODY has finished.
+(setq str1 (symbol-name str1)))
-The value returned is the value of the last form in BODY."
+(if (symbolp str2)
-(let ((current-message (make-symbol "current-message"))
+(setq str2 (symbol-name str2)))
-	(temp-message (make-symbol "with-temp-message")))
+(eq t (compare-strings str1 nil nil str2 nil nil t)))
-`(let ((,temp-message ,message)
-	   (,current-message))
-(unwind-protect
-	   (progn
-	     (when ,temp-message
-	       (setq ,current-message (current-message))
-	       (message "%s" ,temp-message))
-	     ,@body)
-	 (and ,temp-message ,current-message
-	      (message "%s" ,current-message))))))
-(defmacro with-temp-buffer (&rest forms)
-"Create a temporary buffer, and evaluate FORMS there like `progn'.
-See also `with-temp-file' and `with-output-to-string'."
-(let ((temp-buffer (make-symbol "temp-buffer")))
-`(let ((,temp-buffer
-	    (get-buffer-create (generate-new-buffer-name " *temp*"))))
-(unwind-protect
-	   (with-current-buffer ,temp-buffer
-	     ,@forms)
-	 (and (buffer-name ,temp-buffer)
-	      (kill-buffer ,temp-buffer))))))
-;; 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
-(insert ,str)
-,@body
-(buffer-string)))
 (defun insert-face (string face)
 "Insert STRING and highlight with FACE.  Return the extent created."
 (let ((p (point)) ext)
 (insert string)
 string))
 ;; From FSF 21.1; ELLIPSES is XEmacs addition.
 (defun truncate-string-to-width (str end-column &optional start-column padding
-				     ellipses)
+				 ellipses)
 "Truncate string STR to end at column END-COLUMN.
 The optional 3rd arg START-COLUMN, if non-nil, specifies
 the starting column; that means to return the characters occupying
 columns START-COLUMN ... END-COLUMN of STR.
 (buffer-substring buffer old-end old-buffer))
 (t
 ;; Probably the old way.
 (buffer-substring buffer old-end old-buffer))))
+;; BEGIN SYNC WITH FSF 21.2
 ;; 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.
 ;;; "foo", "foo.elc", "foo.el", and "/some/path/foo.elc" are all different
 (defun eval-after-load (file form)
 "Arrange that, if FILE is ever loaded, FORM will be run at that time.
 This makes or adds to an entry on `after-load-alist'.
 If FILE is already loaded, evaluate FORM right now.
 It does nothing if FORM is already on the list for FILE.
-FILE should be the name of a library, with no directory name."
+FILE must match exactly.  Normally FILE is the name of a library,
+with no directory or extension specified, since that is how `load'
+is normally called."
+;; Make sure `load-history' contains the files dumped with Emacs
+;; for the case that FILE is one of the files dumped with Emacs.
+(if-fboundp 'load-symbol-file-load-history
+(load-symbol-file-load-history))
 ;; Make sure there is an element for FILE.
 (or (assoc file after-load-alist)
 (setq after-load-alist (cons (list file) after-load-alist)))
 ;; Add FORM to the element if it isn't there.
 (let ((elt (assoc file after-load-alist)))
 This makes or adds to an entry on `after-load-alist'.
 FILE should be the name of a library, with no directory name."
 (eval-after-load file (read)))
 (make-compatible 'eval-next-after-load "")
-; alternate names (not obsolete)
+;; END SYNC WITH FSF 21.2
-(if (not (fboundp 'mod)) (define-function 'mod '%))
-(define-function 'move-marker 'set-marker)
-(define-function 'beep 'ding)		; preserve lingual purity
-(define-function 'indent-to-column 'indent-to)
-(define-function 'backward-delete-char 'delete-backward-char)
-(define-function 'search-forward-regexp (symbol-function 're-search-forward))
-(define-function 'search-backward-regexp (symbol-function 're-search-backward))
-(define-function 'remove-directory 'delete-directory)
-(define-function 'set-match-data 'store-match-data)
-(define-function 'send-string-to-terminal 'external-debugging-output)
 ;;; subr.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/subr.el @ 1333:1b0339b048ce