X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fsubr.el;h=593703026fa43f7d99ddef927811abc81029d05b;hb=e41b671ad8ef8f9d0464058e49a3a1ff9a5e4d4d;hp=fd65346a58e6ece24aba0c17369c2734450e407d;hpb=59eec5f21669e81977b5b1fe9bf717cab49cf7fb;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/subr.el b/lisp/subr.el index fd65346..5937030 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -25,7 +25,7 @@ ;; 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: @@ -301,16 +301,24 @@ 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) +(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'. +If ELEMENT is added, it is added at the beginning of the list, +unless the optional argument APPEND is non-nil, in which case +ELEMENT is added at the end. + If you want to use `add-to-list' on a variable that is not defined until a certain package is loaded, you should put the call to `add-to-list' into a hook function that will be run only after loading the package. `eval-after-load' provides one way to do this. In some cases other hooks, such as major mode hooks, can do the job." - (or (member element (symbol-value list-var)) - (set list-var (cons element (symbol-value list-var))))) + (if (member element (symbol-value list-var)) + (symbol-value list-var) + (set list-var + (if append + (append (symbol-value list-var) (list element)) + (cons element (symbol-value list-var)))))) ;; XEmacs additions ;; called by Fkill_buffer() @@ -359,7 +367,7 @@ function allows you to set the local value. NOTE: At some point, this will be moved into C and will be very fast." (with-current-buffer buffer (set sym val))) - + ;;;; String functions. ;; XEmacs @@ -380,12 +388,14 @@ Otherwise treat `\\' in NEWTEXT as special: (check-argument-type 'stringp str) (check-argument-type 'stringp newtext) (if (> (length str) 50) - (with-temp-buffer - (insert str) - (goto-char 1) + (let ((cfs case-fold-search)) + (with-temp-buffer + (setq case-fold-search cfs) + (insert str) + (goto-char 1) (while (re-search-forward regexp nil t) (replace-match newtext t literal)) - (buffer-string)) + (buffer-string))) (let ((start 0) newstr) (while (string-match regexp str start) (setq newstr (replace-match newtext t literal str) @@ -393,22 +403,70 @@ Otherwise treat `\\' in NEWTEXT as special: str newstr)) str))) -(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))) - (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)))) +(defconst split-string-default-separators "[ \f\t\n\r\v]+" + "The default value of separators for `split-string'. + +A regexp matching strings of whitespace. May be locale-dependent +\(as yet unimplemented). Should not match non-breaking spaces. + +Warning: binding this to a different value and using it as default is +likely to have undesired semantics.") + +;; specification for `split-string' agreed with rms 2003-04-23 +;; xemacs design <87vfx5vor0.fsf@tleepslib.sk.tsukuba.ac.jp> + +;; The specification says that if both SEPARATORS and OMIT-NULLS are +;; defaulted, OMIT-NULLS should be treated as t. Simplifying the logical +;; expression leads to the equivalent implementation that if SEPARATORS +;; is defaulted, OMIT-NULLS is treated as t. + +(defun split-string (string &optional separators omit-nulls) + "Splits STRING into substrings bounded by matches for SEPARATORS. + +The beginning and end of STRING, and each match for SEPARATORS, are +splitting points. The substrings matching SEPARATORS are removed, and +the substrings between the splitting points are collected as a list, +which is returned. + +If SEPARATORS is non-nil, it should be a regular expression matching text +which separates, but is not part of, the substrings. If nil it defaults to +`split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and +OMIT-NULLS is forced to t. + +If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so +that for the default value of SEPARATORS leading and trailing whitespace +are effectively trimmed). If nil, all zero-length substrings are retained, +which correctly parses CSV format, for example. + +Note that the effect of `(split-string STRING)' is the same as +`(split-string STRING split-string-default-separators t)'). In the rare +case that you wish to retain zero-length substrings when splitting on +whitespace, use `(split-string STRING split-string-default-separators nil)'. + +Modifies the match data when successful; use `save-match-data' if necessary." + + (let ((keep-nulls (not (if separators omit-nulls t))) + (rexp (or separators split-string-default-separators)) + (start 0) + notfirst + (list nil)) + (while (and (string-match rexp string + (if (and notfirst + (= start (match-beginning 0)) + (< start (length string))) + (1+ start) start)) + (< start (length string))) + (setq notfirst t) + (if (or keep-nulls (< start (match-beginning 0))) + (setq list + (cons (substring string start (match-beginning 0)) + list))) + (setq start (match-end 0))) + (if (or keep-nulls (< start (length string))) + (setq list + (cons (substring string start) + list))) + (nreverse list))) ;; #### #### #### AAaargh! Must be in C, because it is used insanely ;; early in the bootstrap process. @@ -446,13 +504,13 @@ See also `with-temp-buffer'." (set-buffer ,buffer) ,@body)) -(defmacro with-temp-file (file &rest forms) - "Create a new buffer, evaluate FORMS there, and write the buffer to FILE. +(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 ,file) + `(let ((,temp-file ,filename) (,temp-buffer (get-buffer-create (generate-new-buffer-name " *temp file*")))) (unwind-protect @@ -477,6 +535,43 @@ See also `with-temp-file' and `with-output-to-string'." (and (buffer-name ,temp-buffer) (kill-buffer ,temp-buffer)))))) +;; BEGIN FSF 21.3 SYNCH +(defmacro with-local-quit (&rest body) + "Execute BODY with `inhibit-quit' temporarily bound to nil." + `(condition-case nil + (let ((inhibit-quit nil)) + ,@body) + (quit (setq quit-flag t)))) + +(defvar delay-mode-hooks nil + "If non-nil, `run-mode-hooks' should delay running the hooks.") +(defvar delayed-mode-hooks nil + "List of delayed mode hooks waiting to be run.") +(make-variable-buffer-local 'delayed-mode-hooks) +(put 'delay-mode-hooks 'permanent-local t) + +(defun run-mode-hooks (&rest hooks) + "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS. +Execution is delayed if `delay-mode-hooks' is non-nil. +Major mode functions should use this." + (if delay-mode-hooks + ;; Delaying case. + (dolist (hook hooks) + (push hook delayed-mode-hooks)) + ;; Normal case, just run the hook as before plus any delayed hooks. + (setq hooks (nconc (nreverse delayed-mode-hooks) hooks)) + (setq delayed-mode-hooks nil) + (apply 'run-hooks hooks))) + +(defmacro delay-mode-hooks (&rest body) + "Execute BODY, but delay any `run-mode-hooks'. +Only affects hooks run in the current buffer." + `(progn + (make-local-variable 'delay-mode-hooks) + (let ((delay-mode-hooks t)) + ,@body))) +;; END FSF 21.3 SYNCH + ;; 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. @@ -571,20 +666,20 @@ The original alist is not modified. See also `destructive-alist-to-plist'." ;; getf, remf in cl*.el. -(defmacro putf (plist prop val) - "Add property PROP to plist PLIST with value VAL. -Analogous to (setq PLIST (plist-put PLIST PROP VAL))." - `(setq ,plist (plist-put ,plist ,prop ,val))) +(defmacro putf (plist property value) + "Add property PROPERTY to plist PLIST with value VALUE. +Analogous to (setq PLIST (plist-put PLIST PROPERTY VALUE))." + `(setq ,plist (plist-put ,plist ,property ,value))) -(defmacro laxputf (lax-plist prop val) - "Add property PROP to lax plist LAX-PLIST with value VAL. -Analogous to (setq LAX-PLIST (lax-plist-put LAX-PLIST PROP VAL))." - `(setq ,lax-plist (lax-plist-put ,lax-plist ,prop ,val))) +(defmacro laxputf (lax-plist property value) + "Add property PROPERTY to lax plist LAX-PLIST with value VALUE. +Analogous to (setq LAX-PLIST (lax-plist-put LAX-PLIST PROPERTY VALUE))." + `(setq ,lax-plist (lax-plist-put ,lax-plist ,property ,value))) -(defmacro laxremf (lax-plist prop) - "Remove property PROP from lax plist LAX-PLIST. -Analogous to (setq LAX-PLIST (lax-plist-remprop LAX-PLIST PROP))." - `(setq ,lax-plist (lax-plist-remprop ,lax-plist ,prop))) +(defmacro laxremf (lax-plist property) + "Remove property PROPERTY from lax plist LAX-PLIST. +Analogous to (setq LAX-PLIST (lax-plist-remprop LAX-PLIST PROPERTY))." + `(setq ,lax-plist (lax-plist-remprop ,lax-plist ,property))) ;;; Error functions @@ -633,6 +728,9 @@ error malformed-property-list circular-list circular-property-list + invalid-regexp + specifier-syntax-error + invalid-argument wrong-type-argument @@ -640,28 +738,47 @@ error wrong-number-of-arguments invalid-function no-catch + undefined-keystroke-sequence + specifier-argument-error invalid-state void-function cyclic-function-indirection void-variable cyclic-variable-indirection + protected-field + invalid-byte-code invalid-operation invalid-change setting-constant + specifier-change-error editing-error beginning-of-buffer end-of-buffer buffer-read-only io-error + file-error + file-already-exists + file-locked + file-supersession end-of-file + coding-system-error + image-conversion-error + tooltalk-error arith-error range-error domain-error singularity-error overflow-error underflow-error + dialog-box-error + search-failed + selection-conversion-error + + unimplemented + + internal-error The five most common errors you will probably use or base your new errors off of are `syntax-error', `invalid-argument', `invalid-state', @@ -746,9 +863,9 @@ yourself.]" ;;;; Miscellanea. ;; This is now in C. -;(defun buffer-substring-no-properties (beg end) -; "Return the text from BEG to END, without text properties, as a string." -; (let ((string (buffer-substring beg end))) +;(defun buffer-substring-no-properties (start end) +; "Return the text from START to END, without text properties, as a string." +; (let ((string (buffer-substring start end))) ; (set-text-properties 0 (length string) nil string) ; string))