;; 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:
(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()
(setplist new (copy-list (symbol-plist symbol))))
new))
+(defun set-symbol-value-in-buffer (sym val buffer)
+ "Set the value of SYM to VAL in BUFFER. Useful with buffer-local variables.
+If SYM has a buffer-local value in BUFFER, or will have one if set, this
+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
"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 string as special:
- \\& means substitute original matched text,
- \\N means substitute match for \(...\) number N,
- \\\\ means insert one \\."
+Otherwise treat `\\' in NEWTEXT as special:
+ `\\&' in NEWTEXT means substitute original matched text.
+ `\\N' means substitute what matched the Nth `\\(...\\)'.
+ If Nth parens didn't match, substitute nothing.
+ `\\\\' means insert one `\\'.
+ `\\u' means upcase the next character.
+ `\\l' means downcase the next character.
+ `\\U' means begin upcasing all following characters.
+ `\\L' means begin downcasing all following characters.
+ `\\E' means terminate the effect of any `\\U' or `\\L'."
(check-argument-type 'stringp str)
(check-argument-type 'stringp newtext)
- (let ((rtn-str "")
+ (if (> (length str) 50)
+ (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)))
+ (let ((start 0) newstr)
+ (while (string-match regexp str start)
+ (setq newstr (replace-match newtext t literal str)
+ start (+ (match-end 0) (- (length newstr) (length str)))
+ str newstr))
+ str)))
+
+(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)
- (special)
- match prev-start)
- (while (setq match (string-match regexp str start))
- (setq prev-start start
- start (match-end 0)
- rtn-str
- (concat
- rtn-str
- (substring str prev-start match)
- (cond (literal newtext)
- (t (mapconcat
- (lambda (c)
- (if special
- (progn
- (setq special nil)
- (cond ((eq c ?\\) "\\")
- ((eq c ?&)
- (substring str
- (match-beginning 0)
- (match-end 0)))
- ((and (>= c ?0) (<= c ?9))
- (if (> c (+ ?0 (length
- (match-data))))
- ;; Invalid match num
- (error "Invalid match num: %c" c)
- (setq c (- c ?0))
- (substring str
- (match-beginning c)
- (match-end c))))
- (t (char-to-string c))))
- (if (eq c ?\\) (progn (setq special t) nil)
- (char-to-string c))))
- newtext ""))))))
- (concat rtn-str (substring str start))))
-
-(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))))
+ 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.
(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
(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.
;; 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)))
\f
;;; Error functions
-(defun error (&rest args)
- "Signal an error, making error message by passing all args to `format'.
-This error is not continuable: you cannot continue execution after the
-error using the debugger `r' command. See also `cerror'."
- (while t
- (apply 'cerror args)))
+(defun error (datum &rest args)
+ "Signal a non-continuable error.
+DATUM should normally be an error symbol, i.e. a symbol defined using
+`define-error'. ARGS will be made into a list, and DATUM and ARGS passed
+as the two arguments to `signal', the most basic error handling function.
-(defun cerror (&rest args)
+This error is not continuable: you cannot continue execution after the
+error using the debugger `r' command. See also `cerror'.
+
+The correct semantics of ARGS varies from error to error, but for most
+errors that need to be generated in Lisp code, the first argument
+should be a string describing the *context* of the error (i.e. the
+exact operation being performed and what went wrong), and the remaining
+arguments or \"frobs\" (most often, there is one) specify the
+offending object(s) and/or provide additional details such as the exact
+error when a file error occurred, e.g.:
+
+-- the buffer in which an editing error occurred.
+-- an invalid value that was encountered. (In such cases, the string
+ should describe the purpose or \"semantics\" of the value [e.g. if the
+ value is an argument to a function, the name of the argument; if the value
+ is the value corresponding to a keyword, the name of the keyword; if the
+ value is supposed to be a list length, say this and say what the purpose
+ of the list is; etc.] as well as specifying why the value is invalid, if
+ that's not self-evident.)
+-- the file in which an error occurred. (In such cases, there should be a
+ second frob, probably a string, specifying the exact error that occurred.
+ This does not occur in the string that precedes the first frob, because
+ that frob describes the exact operation that was happening.
+
+For historical compatibility, DATUM can also be a string. In this case,
+DATUM and ARGS are passed together as the arguments to `format', and then
+an error is signalled using the error symbol `error' and formatted string.
+Although this usage of `error' is very common, it is deprecated because it
+totally defeats the purpose of having structured errors. There is now
+a rich set of defined errors you can use:
+
+error
+ syntax-error
+ invalid-read-syntax
+ list-formation-error
+ malformed-list
+ malformed-property-list
+ circular-list
+ circular-property-list
+ invalid-regexp
+ specifier-syntax-error
+
+
+ invalid-argument
+ wrong-type-argument
+ args-out-of-range
+ 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',
+`invalid-operation', and `invalid-change'. Note the semantic differences:
+
+-- `syntax-error' is for errors in complex structures: parsed strings, lists,
+ and the like.
+-- `invalid-argument' is for errors in a simple value. Typically, the entire
+ value, not just one part of it, is wrong.
+-- `invalid-state' means that some settings have been changed in such a way
+ that their current state is unallowable. More and more, code is being
+ written more carefully, and catches the error when the settings are being
+ changed, rather than afterwards. This leads us to the next error:
+-- `invalid-change' means that an attempt is being made to change some settings
+ into an invalid state. `invalid-change' is a type of `invalid-operation'.
+-- `invalid-operation' refers to all cases where code is trying to do something
+ that's disallowed. This includes file errors, buffer errors (e.g. running
+ off the end of a buffer), `invalid-change' as just mentioned, and
+ arithmetic errors.
+
+See also `cerror', `signal', and `signal-error'."
+ (while t (apply
+ 'cerror datum args)))
+
+(defun cerror (datum &rest args)
"Like `error' but signals a continuable error."
- (signal 'error (list (apply 'format args))))
+ (cond ((stringp datum)
+ (signal 'error (list (apply 'format datum args))))
+ ((defined-error-p datum)
+ (signal datum args))
+ (t
+ (error 'invalid-argument "datum not string or error symbol" datum))))
(defmacro check-argument-type (predicate argument)
"Check that ARGUMENT satisfies PREDICATE.
-If not, signal a continuable `wrong-type-argument' error until the
-returned value satisfies PREDICATE, and assign the returned value
-to ARGUMENT."
- `(if (not (,(eval predicate) ,argument))
- (setq ,argument
- (wrong-type-argument ,predicate ,argument))))
+This is a macro, and ARGUMENT is not evaluated. If ARGUMENT is an lvalue,
+this function signals a continuable `wrong-type-argument' error until the
+returned value satisfies PREDICATE, and assigns the returned value
+to ARGUMENT. Otherwise, this function signals a non-continuable
+`wrong-type-argument' error if the returned value does not satisfy PREDICATE."
+ (if (symbolp argument)
+ `(if (not (,(eval predicate) ,argument))
+ (setq ,argument
+ (wrong-type-argument ,predicate ,argument)))
+ `(if (not (,(eval predicate) ,argument))
+ (signal-error 'wrong-type-argument (list ,predicate ,argument)))))
(defun signal-error (error-symbol data)
"Signal a non-continuable error. Args are ERROR-SYMBOL, and associated DATA.
(or conds (signal-error 'error (list "Not an error symbol" error-sym)))
(put error-sym 'error-conditions (cons error-sym conds))))
+(defun defined-error-p (sym)
+ "Returns non-nil if SYM names a currently-defined error."
+ (and (symbolp sym) (not (null (get sym 'error-conditions)))))
+
;;;; 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))
projects / chise / xemacs-chise.git.1 / blobdiff