1 ;;; subr.el --- basic lisp subroutines for XEmacs
3 ;; Copyright (C) 1985, 1986, 1992, 1994-5, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
5 ;; Copyright (C) 1995 Sun Microsystems.
6 ;; Copyright (C) 2000 Ben Wing.
8 ;; Maintainer: XEmacs Development Team
9 ;; Keywords: extensions, dumped
11 ;; This file is part of XEmacs.
13 ;; XEmacs is free software; you can redistribute it and/or modify it
14 ;; under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
18 ;; XEmacs is distributed in the hope that it will be useful, but
19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 ;; General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with XEmacs; see the file COPYING. If not, write to the Free
25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
28 ;;; Synched up with: FSF 19.34. Some things synched up with later versions.
32 ;; This file is dumped with XEmacs.
34 ;; There's not a whole lot in common now with the FSF version,
35 ;; be wary when applying differences. I've left in a number of lines
36 ;; of commentary just to give diff(1) something to synch itself with to
37 ;; provide useful context diffs. -sb
42 ;;;; Lisp language features.
44 (defmacro lambda (&rest cdr)
45 "Return a lambda expression.
46 A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
47 self-quoting; the result of evaluating the lambda expression is the
48 expression itself. The lambda expression may then be treated as a
49 function, i.e., stored as the function value of a symbol, passed to
50 funcall or mapcar, etc.
52 ARGS should take the same form as an argument list for a `defun'.
53 DOCSTRING is an optional documentation string.
54 If present, it should describe how to call the function.
55 But documentation strings are usually not useful in nameless functions.
56 INTERACTIVE should be a call to the function `interactive', which see.
57 It may also be omitted.
58 BODY should be a list of lisp expressions."
59 `(function (lambda ,@cdr)))
61 (defmacro defun-when-void (&rest args)
62 "Define a function, just like `defun', unless it's already defined.
63 Used for compatibility among different emacs variants."
64 `(if (fboundp ',(car args))
68 (defmacro define-function-when-void (&rest args)
69 "Define a function, just like `define-function', unless it's already defined.
70 Used for compatibility among different emacs variants."
71 `(if (fboundp ,(car args))
73 (define-function ,@args)))
77 ;; XEmacs: removed to keymap.el
79 ;;;; The global keymap tree.
81 ;;; global-map, esc-map, and ctl-x-map have their values set up in
82 ;;; keymap.c; we just give them docstrings here.
84 ;;;; Event manipulation functions.
86 ;; XEmacs: This stuff is done in C Code.
88 ;;;; Obsolescent names for functions.
92 (defun local-variable-if-set-p (sym buffer)
93 "Return t if SYM would be local to BUFFER after it is set.
94 A nil value for BUFFER is *not* the same as (current-buffer), but
95 can be used to determine whether `make-variable-buffer-local' has been
97 (local-variable-p sym buffer t))
100 ;;;; Hook manipulation functions.
102 ;; (defconst run-hooks 'run-hooks ...)
104 (defun make-local-hook (hook)
105 "Make the hook HOOK local to the current buffer.
106 When a hook is local, its local and global values
107 work in concert: running the hook actually runs all the hook
108 functions listed in *either* the local value *or* the global value
109 of the hook variable.
111 This function works by making `t' a member of the buffer-local value,
112 which acts as a flag to run the hook functions in the default value as
113 well. This works for all normal hooks, but does not work for most
114 non-normal hooks yet. We will be changing the callers of non-normal
115 hooks so that they can handle localness; this has to be done one by
118 This function does nothing if HOOK is already local in the current
121 Do not use `make-local-variable' to make a hook variable buffer-local.
123 See also `add-local-hook' and `remove-local-hook'."
124 (if (local-variable-p hook (current-buffer)) ; XEmacs
126 (or (boundp hook) (set hook nil))
127 (make-local-variable hook)
128 (set hook (list t))))
130 (defun add-hook (hook function &optional append local)
131 "Add to the value of HOOK the function FUNCTION.
132 FUNCTION is not added if already present.
133 FUNCTION is added (if necessary) at the beginning of the hook list
134 unless the optional argument APPEND is non-nil, in which case
135 FUNCTION is added at the end.
137 The optional fourth argument, LOCAL, if non-nil, says to modify
138 the hook's buffer-local value rather than its default value.
139 This makes no difference if the hook is not buffer-local.
140 To make a hook variable buffer-local, always use
141 `make-local-hook', not `make-local-variable'.
143 HOOK should be a symbol, and FUNCTION may be any valid function. If
144 HOOK is void, it is first set to nil. If HOOK's value is a single
145 function, it is changed to a list of functions.
147 You can remove this hook yourself using `remove-hook'.
149 See also `add-local-hook' and `add-one-shot-hook'."
150 (or (boundp hook) (set hook nil))
151 (or (default-boundp hook) (set-default hook nil))
152 ;; If the hook value is a single function, turn it into a list.
153 (let ((old (symbol-value hook)))
154 (if (or (not (listp old)) (eq (car old) 'lambda))
155 (set hook (list old))))
157 ;; Detect the case where make-local-variable was used on a hook
158 ;; and do what we used to do.
159 (and (local-variable-if-set-p hook (current-buffer)) ; XEmacs
160 (not (memq t (symbol-value hook)))))
161 ;; Alter the local value only.
162 (or (if (consp function)
163 (member function (symbol-value hook))
164 (memq function (symbol-value hook)))
167 (append (symbol-value hook) (list function))
168 (cons function (symbol-value hook)))))
169 ;; Alter the global value (which is also the only value,
170 ;; if the hook doesn't have a local value).
171 (or (if (consp function)
172 (member function (default-value hook))
173 (memq function (default-value hook)))
176 (append (default-value hook) (list function))
177 (cons function (default-value hook)))))))
179 (defun remove-hook (hook function &optional local)
180 "Remove from the value of HOOK the function FUNCTION.
181 HOOK should be a symbol, and FUNCTION may be any valid function. If
182 FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
183 list of hooks to run in HOOK, then nothing is done. See `add-hook'.
185 The optional third argument, LOCAL, if non-nil, says to modify
186 the hook's buffer-local value rather than its default value.
187 This makes no difference if the hook is not buffer-local.
188 To make a hook variable buffer-local, always use
189 `make-local-hook', not `make-local-variable'."
190 (if (or (not (boundp hook)) ;unbound symbol, or
191 (not (default-boundp 'hook))
192 (null (symbol-value hook)) ;value is nil, or
193 (null function)) ;function is nil, then
196 (function hook-value)
202 (get hel 'one-shot-hook-fun))))))
203 (if (and (consp hook-value)
204 (not (functionp hook-value)))
205 (if (member* function hook-value :test 'hook-test)
207 (delete* function (copy-sequence hook-value)
209 (if (equal hook-value function)
210 (setq hook-value nil)))
213 ;; Detect the case where make-local-variable was used on a hook
214 ;; and do what we used to do.
215 (and (local-variable-p hook (current-buffer))
216 (not (memq t (symbol-value hook)))))
217 (set hook (hook-remove function (symbol-value hook)))
218 (set-default hook (hook-remove function (default-value hook)))))))
221 ;; #### we need a coherent scheme for indicating compatibility info,
222 ;; so that it can be programmatically retrieved.
223 (defun add-local-hook (hook function &optional append)
224 "Add to the local value of HOOK the function FUNCTION.
225 This modifies only the buffer-local value for the hook (which is
226 automatically make buffer-local, if necessary), not its default value.
227 FUNCTION is not added if already present.
228 FUNCTION is added (if necessary) at the beginning of the hook list
229 unless the optional argument APPEND is non-nil, in which case
230 FUNCTION is added at the end.
232 HOOK should be a symbol, and FUNCTION may be any valid function. If
233 HOOK is void, it is first set to nil. If HOOK's value is a single
234 function, it is changed to a list of functions.
236 You can remove this hook yourself using `remove-local-hook'.
238 See also `add-hook' and `make-local-hook'."
239 (make-local-hook hook)
240 (add-hook hook function append t))
243 (defun remove-local-hook (hook function)
244 "Remove from the local value of HOOK the function FUNCTION.
245 This modifies only the buffer-local value for the hook, not its default
246 value. (Nothing happens if the hook is not buffer-local.)
247 HOOK should be a symbol, and FUNCTION may be any valid function. If
248 FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
249 list of hooks to run in HOOK, then nothing is done. See `add-hook'.
251 See also `add-local-hook' and `make-local-hook'."
252 (if (local-variable-p hook (current-buffer))
253 (remove-hook hook function t)))
255 (defun add-one-shot-hook (hook function &optional append local)
256 "Add to the value of HOOK the one-shot function FUNCTION.
257 FUNCTION will automatically be removed from the hook the first time
258 after it runs (whether to completion or to an error).
259 FUNCTION is not added if already present.
260 FUNCTION is added (if necessary) at the beginning of the hook list
261 unless the optional argument APPEND is non-nil, in which case
262 FUNCTION is added at the end.
264 HOOK should be a symbol, and FUNCTION may be any valid function. If
265 HOOK is void, it is first set to nil. If HOOK's value is a single
266 function, it is changed to a list of functions.
268 You can remove this hook yourself using `remove-hook'.
270 See also `add-hook', `add-local-hook', and `add-local-one-shot-hook'."
271 (let ((sym (gensym)))
272 (fset sym `(lambda (&rest args)
274 (apply ',function args)
275 (remove-hook ',hook ',sym ',local))))
276 (put sym 'one-shot-hook-fun function)
277 (add-hook hook sym append local)))
279 (defun add-local-one-shot-hook (hook function &optional append)
280 "Add to the local value of HOOK the one-shot function FUNCTION.
281 FUNCTION will automatically be removed from the hook the first time
282 after it runs (whether to completion or to an error).
283 FUNCTION is not added if already present.
284 FUNCTION is added (if necessary) at the beginning of the hook list
285 unless the optional argument APPEND is non-nil, in which case
286 FUNCTION is added at the end.
288 The optional fourth argument, LOCAL, if non-nil, says to modify
289 the hook's buffer-local value rather than its default value.
290 This makes no difference if the hook is not buffer-local.
291 To make a hook variable buffer-local, always use
292 `make-local-hook', not `make-local-variable'.
294 HOOK should be a symbol, and FUNCTION may be any valid function. If
295 HOOK is void, it is first set to nil. If HOOK's value is a single
296 function, it is changed to a list of functions.
298 You can remove this hook yourself using `remove-local-hook'.
300 See also `add-hook', `add-local-hook', and `add-local-one-shot-hook'."
301 (make-local-hook hook)
302 (add-one-shot-hook hook function append t))
304 (defun add-to-list (list-var element &optional append)
305 "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
306 The test for presence of ELEMENT is done with `equal'.
307 If ELEMENT is added, it is added at the beginning of the list,
308 unless the optional argument APPEND is non-nil, in which case
309 ELEMENT is added at the end.
311 If you want to use `add-to-list' on a variable that is not defined
312 until a certain package is loaded, you should put the call to `add-to-list'
313 into a hook function that will be run only after loading the package.
314 `eval-after-load' provides one way to do this. In some cases
315 other hooks, such as major mode hooks, can do the job."
316 (if (member element (symbol-value list-var))
317 (symbol-value list-var)
320 (append (symbol-value list-var) (list element))
321 (cons element (symbol-value list-var))))))
324 ;; called by Fkill_buffer()
325 (defvar kill-buffer-hook nil
326 "Function or functions to be called when a buffer is killed.
327 The value of this variable may be buffer-local.
328 The buffer about to be killed is current when this hook is run.")
331 (defvar kill-emacs-hook nil
332 "Function or functions to be called when `kill-emacs' is called,
333 just before emacs is actually killed.")
336 ;; #### These are a bad idea, because the CL RPLACA and RPLACD
337 ;; return the cons cell, not the new CAR/CDR. -hniksic
338 ;; The proper definition would be:
339 ;; (defun rplaca (conscell newcar)
340 ;; (setcar conscell newcar)
342 ;; ...and analogously for RPLACD.
343 (define-function 'rplaca 'setcar)
344 (define-function 'rplacd 'setcdr)
346 (defun copy-symbol (symbol &optional copy-properties)
347 "Return a new uninterned symbol with the same name as SYMBOL.
348 If COPY-PROPERTIES is non-nil, the new symbol will have a copy of
349 SYMBOL's value, function, and property lists."
350 (let ((new (make-symbol (symbol-name symbol))))
351 (when copy-properties
352 ;; This will not copy SYMBOL's chain of forwarding objects, but
353 ;; I think that's OK. Callers should not expect such magic to
354 ;; keep working in the copy in the first place.
356 (set new (symbol-value symbol)))
357 (and (fboundp symbol)
358 (fset new (symbol-function symbol)))
359 (setplist new (copy-list (symbol-plist symbol))))
362 (defun set-symbol-value-in-buffer (sym val buffer)
363 "Set the value of SYM to VAL in BUFFER. Useful with buffer-local variables.
364 If SYM has a buffer-local value in BUFFER, or will have one if set, this
365 function allows you to set the local value.
367 NOTE: At some point, this will be moved into C and will be very fast."
368 (with-current-buffer buffer
371 ;;;; String functions.
374 (defun replace-in-string (str regexp newtext &optional literal)
375 "Replace all matches in STR for REGEXP with NEWTEXT string,
376 and returns the new string.
377 Optional LITERAL non-nil means do a literal replacement.
378 Otherwise treat `\\' in NEWTEXT as special:
379 `\\&' in NEWTEXT means substitute original matched text.
380 `\\N' means substitute what matched the Nth `\\(...\\)'.
381 If Nth parens didn't match, substitute nothing.
382 `\\\\' means insert one `\\'.
383 `\\u' means upcase the next character.
384 `\\l' means downcase the next character.
385 `\\U' means begin upcasing all following characters.
386 `\\L' means begin downcasing all following characters.
387 `\\E' means terminate the effect of any `\\U' or `\\L'."
388 (check-argument-type 'stringp str)
389 (check-argument-type 'stringp newtext)
390 (if (> (length str) 50)
391 (let ((cfs case-fold-search))
393 (setq case-fold-search cfs)
396 (while (re-search-forward regexp nil t)
397 (replace-match newtext t literal))
399 (let ((start 0) newstr)
400 (while (string-match regexp str start)
401 (setq newstr (replace-match newtext t literal str)
402 start (+ (match-end 0) (- (length newstr) (length str)))
406 (defconst split-string-default-separators "[ \f\t\n\r\v]+"
407 "The default value of separators for `split-string'.
409 A regexp matching strings of whitespace. May be locale-dependent
410 \(as yet unimplemented). Should not match non-breaking spaces.
412 Warning: binding this to a different value and using it as default is
413 likely to have undesired semantics.")
415 ;; specification for `split-string' agreed with rms 2003-04-23
416 ;; xemacs design <87vfx5vor0.fsf@tleepslib.sk.tsukuba.ac.jp>
418 ;; The specification says that if both SEPARATORS and OMIT-NULLS are
419 ;; defaulted, OMIT-NULLS should be treated as t. Simplifying the logical
420 ;; expression leads to the equivalent implementation that if SEPARATORS
421 ;; is defaulted, OMIT-NULLS is treated as t.
423 (defun split-string (string &optional separators omit-nulls)
424 "Splits STRING into substrings bounded by matches for SEPARATORS.
426 The beginning and end of STRING, and each match for SEPARATORS, are
427 splitting points. The substrings matching SEPARATORS are removed, and
428 the substrings between the splitting points are collected as a list,
431 If SEPARATORS is non-nil, it should be a regular expression matching text
432 which separates, but is not part of, the substrings. If nil it defaults to
433 `split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and
434 OMIT-NULLS is forced to t.
436 If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
437 that for the default value of SEPARATORS leading and trailing whitespace
438 are effectively trimmed). If nil, all zero-length substrings are retained,
439 which correctly parses CSV format, for example.
441 Note that the effect of `(split-string STRING)' is the same as
442 `(split-string STRING split-string-default-separators t)'). In the rare
443 case that you wish to retain zero-length substrings when splitting on
444 whitespace, use `(split-string STRING split-string-default-separators nil)'.
446 Modifies the match data when successful; use `save-match-data' if necessary."
448 (let ((keep-nulls (not (if separators omit-nulls t)))
449 (rexp (or separators split-string-default-separators))
453 (while (and (string-match rexp string
455 (= start (match-beginning 0))
456 (< start (length string)))
458 (< start (length string)))
460 (if (or keep-nulls (< start (match-beginning 0)))
462 (cons (substring string start (match-beginning 0))
464 (setq start (match-end 0)))
465 (if (or keep-nulls (< start (length string)))
467 (cons (substring string start)
471 ;; #### #### #### AAaargh! Must be in C, because it is used insanely
472 ;; early in the bootstrap process.
473 ;(defun split-path (path)
474 ; "Explode a search path into a list of strings.
475 ;The path components are separated with the characters specified
476 ;with `path-separator'."
477 ; (while (or (not stringp path-separator)
478 ; (/= (length path-separator) 1))
479 ; (setq path-separator (signal 'error (list "\
480 ;`path-separator' should be set to a single-character string"
482 ; (split-string-by-char path (aref separator 0)))
484 (defmacro with-output-to-string (&rest forms)
485 "Collect output to `standard-output' while evaluating FORMS and return
487 ;; by "William G. Dubuque" <wgd@zurich.ai.mit.edu> w/ mods from Stig
488 `(with-current-buffer (get-buffer-create
489 (generate-new-buffer-name " *string-output*"))
490 (setq buffer-read-only nil)
491 (buffer-disable-undo (current-buffer))
493 (let ((standard-output (current-buffer)))
499 (defmacro with-current-buffer (buffer &rest body)
500 "Temporarily make BUFFER the current buffer and execute the forms in BODY.
501 The value returned is the value of the last form in BODY.
502 See also `with-temp-buffer'."
503 `(save-current-buffer
507 (defmacro with-temp-file (filename &rest forms)
508 "Create a new buffer, evaluate FORMS there, and write the buffer to FILENAME.
509 The value of the last form in FORMS is returned, like `progn'.
510 See also `with-temp-buffer'."
511 (let ((temp-file (make-symbol "temp-file"))
512 (temp-buffer (make-symbol "temp-buffer")))
513 `(let ((,temp-file ,filename)
515 (get-buffer-create (generate-new-buffer-name " *temp file*"))))
518 (with-current-buffer ,temp-buffer
520 (with-current-buffer ,temp-buffer
522 (write-region (point-min) (point-max) ,temp-file nil 0)))
523 (and (buffer-name ,temp-buffer)
524 (kill-buffer ,temp-buffer))))))
526 (defmacro with-temp-buffer (&rest forms)
527 "Create a temporary buffer, and evaluate FORMS there like `progn'.
528 See also `with-temp-file' and `with-output-to-string'."
529 (let ((temp-buffer (make-symbol "temp-buffer")))
531 (get-buffer-create (generate-new-buffer-name " *temp*"))))
533 (with-current-buffer ,temp-buffer
535 (and (buffer-name ,temp-buffer)
536 (kill-buffer ,temp-buffer))))))
538 ;; BEGIN FSF 21.3 SYNCH
539 (defmacro with-local-quit (&rest body)
540 "Execute BODY with `inhibit-quit' temporarily bound to nil."
542 (let ((inhibit-quit nil))
544 (quit (setq quit-flag t))))
546 (defvar delay-mode-hooks nil
547 "If non-nil, `run-mode-hooks' should delay running the hooks.")
548 (defvar delayed-mode-hooks nil
549 "List of delayed mode hooks waiting to be run.")
550 (make-variable-buffer-local 'delayed-mode-hooks)
551 (put 'delay-mode-hooks 'permanent-local t)
553 (defun run-mode-hooks (&rest hooks)
554 "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS.
555 Execution is delayed if `delay-mode-hooks' is non-nil.
556 Major mode functions should use this."
560 (push hook delayed-mode-hooks))
561 ;; Normal case, just run the hook as before plus any delayed hooks.
562 (setq hooks (nconc (nreverse delayed-mode-hooks) hooks))
563 (setq delayed-mode-hooks nil)
564 (apply 'run-hooks hooks)))
566 (defmacro delay-mode-hooks (&rest body)
567 "Execute BODY, but delay any `run-mode-hooks'.
568 Only affects hooks run in the current buffer."
570 (make-local-variable 'delay-mode-hooks)
571 (let ((delay-mode-hooks t))
573 ;; END FSF 21.3 SYNCH
575 ;; Moved from mule-coding.el.
576 (defmacro with-string-as-buffer-contents (str &rest body)
577 "With the contents of the current buffer being STR, run BODY.
578 Returns the new contents of the buffer, as modified by BODY.
579 The original current buffer is restored afterwards."
585 (defun insert-face (string face)
586 "Insert STRING and highlight with FACE. Return the extent created."
587 (let ((p (point)) ext)
589 (setq ext (make-extent p (point)))
590 (set-extent-face ext face)
594 (define-function 'string= 'string-equal)
595 (define-function 'string< 'string-lessp)
596 (define-function 'int-to-string 'number-to-string)
597 (define-function 'string-to-int 'string-to-number)
599 ;; These two names are a bit awkward, as they conflict with the normal
600 ;; foo-to-bar naming scheme, but CLtL2 has them, so they stay.
601 (define-function 'char-int 'char-to-int)
602 (define-function 'int-char 'int-to-char)
605 ;; alist/plist functions
606 (defun plist-to-alist (plist)
607 "Convert property list PLIST into the equivalent association-list form.
608 The alist is returned. This converts from
614 \((a . 1) (b . 2) (c . 3))
616 The original plist is not modified. See also `destructive-plist-to-alist'."
619 (setq alist (cons (cons (car plist) (cadr plist)) alist))
620 (setq plist (cddr plist)))
623 (defun destructive-plist-to-alist (plist)
624 "Convert property list PLIST into the equivalent association-list form.
625 The alist is returned. This converts from
631 \((a . 1) (b . 2) (c . 3))
633 The original plist is destroyed in the process of constructing the alist.
634 See also `plist-to-alist'."
638 ;; remember the next plist pair.
639 (setq next (cddr plist))
640 ;; make the cons holding the property value into the alist element.
641 (setcdr (cdr plist) (cadr plist))
642 (setcar (cdr plist) (car plist))
643 ;; reattach into alist form.
644 (setcar plist (cdr plist))
649 (defun alist-to-plist (alist)
650 "Convert association list ALIST into the equivalent property-list form.
651 The plist is returned. This converts from
653 \((a . 1) (b . 2) (c . 3))
659 The original alist is not modified. See also `destructive-alist-to-plist'."
662 (let ((el (car alist)))
663 (setq plist (cons (cdr el) (cons (car el) plist))))
664 (setq alist (cdr alist)))
667 ;; getf, remf in cl*.el.
669 (defmacro putf (plist property value)
670 "Add property PROPERTY to plist PLIST with value VALUE.
671 Analogous to (setq PLIST (plist-put PLIST PROPERTY VALUE))."
672 `(setq ,plist (plist-put ,plist ,property ,value)))
674 (defmacro laxputf (lax-plist property value)
675 "Add property PROPERTY to lax plist LAX-PLIST with value VALUE.
676 Analogous to (setq LAX-PLIST (lax-plist-put LAX-PLIST PROPERTY VALUE))."
677 `(setq ,lax-plist (lax-plist-put ,lax-plist ,property ,value)))
679 (defmacro laxremf (lax-plist property)
680 "Remove property PROPERTY from lax plist LAX-PLIST.
681 Analogous to (setq LAX-PLIST (lax-plist-remprop LAX-PLIST PROPERTY))."
682 `(setq ,lax-plist (lax-plist-remprop ,lax-plist ,property)))
686 (defun error (datum &rest args)
687 "Signal a non-continuable error.
688 DATUM should normally be an error symbol, i.e. a symbol defined using
689 `define-error'. ARGS will be made into a list, and DATUM and ARGS passed
690 as the two arguments to `signal', the most basic error handling function.
692 This error is not continuable: you cannot continue execution after the
693 error using the debugger `r' command. See also `cerror'.
695 The correct semantics of ARGS varies from error to error, but for most
696 errors that need to be generated in Lisp code, the first argument
697 should be a string describing the *context* of the error (i.e. the
698 exact operation being performed and what went wrong), and the remaining
699 arguments or \"frobs\" (most often, there is one) specify the
700 offending object(s) and/or provide additional details such as the exact
701 error when a file error occurred, e.g.:
703 -- the buffer in which an editing error occurred.
704 -- an invalid value that was encountered. (In such cases, the string
705 should describe the purpose or \"semantics\" of the value [e.g. if the
706 value is an argument to a function, the name of the argument; if the value
707 is the value corresponding to a keyword, the name of the keyword; if the
708 value is supposed to be a list length, say this and say what the purpose
709 of the list is; etc.] as well as specifying why the value is invalid, if
710 that's not self-evident.)
711 -- the file in which an error occurred. (In such cases, there should be a
712 second frob, probably a string, specifying the exact error that occurred.
713 This does not occur in the string that precedes the first frob, because
714 that frob describes the exact operation that was happening.
716 For historical compatibility, DATUM can also be a string. In this case,
717 DATUM and ARGS are passed together as the arguments to `format', and then
718 an error is signalled using the error symbol `error' and formatted string.
719 Although this usage of `error' is very common, it is deprecated because it
720 totally defeats the purpose of having structured errors. There is now
721 a rich set of defined errors you can use:
728 malformed-property-list
730 circular-property-list
732 specifier-syntax-error
738 wrong-number-of-arguments
741 undefined-keystroke-sequence
742 specifier-argument-error
746 cyclic-function-indirection
748 cyclic-variable-indirection
755 specifier-change-error
767 image-conversion-error
777 selection-conversion-error
783 The five most common errors you will probably use or base your new
784 errors off of are `syntax-error', `invalid-argument', `invalid-state',
785 `invalid-operation', and `invalid-change'. Note the semantic differences:
787 -- `syntax-error' is for errors in complex structures: parsed strings, lists,
789 -- `invalid-argument' is for errors in a simple value. Typically, the entire
790 value, not just one part of it, is wrong.
791 -- `invalid-state' means that some settings have been changed in such a way
792 that their current state is unallowable. More and more, code is being
793 written more carefully, and catches the error when the settings are being
794 changed, rather than afterwards. This leads us to the next error:
795 -- `invalid-change' means that an attempt is being made to change some settings
796 into an invalid state. `invalid-change' is a type of `invalid-operation'.
797 -- `invalid-operation' refers to all cases where code is trying to do something
798 that's disallowed. This includes file errors, buffer errors (e.g. running
799 off the end of a buffer), `invalid-change' as just mentioned, and
802 See also `cerror', `signal', and `signal-error'."
804 'cerror datum args)))
806 (defun cerror (datum &rest args)
807 "Like `error' but signals a continuable error."
808 (cond ((stringp datum)
809 (signal 'error (list (apply 'format datum args))))
810 ((defined-error-p datum)
813 (error 'invalid-argument "datum not string or error symbol" datum))))
815 (defmacro check-argument-type (predicate argument)
816 "Check that ARGUMENT satisfies PREDICATE.
817 This is a macro, and ARGUMENT is not evaluated. If ARGUMENT is an lvalue,
818 this function signals a continuable `wrong-type-argument' error until the
819 returned value satisfies PREDICATE, and assigns the returned value
820 to ARGUMENT. Otherwise, this function signals a non-continuable
821 `wrong-type-argument' error if the returned value does not satisfy PREDICATE."
822 (if (symbolp argument)
823 `(if (not (,(eval predicate) ,argument))
825 (wrong-type-argument ,predicate ,argument)))
826 `(if (not (,(eval predicate) ,argument))
827 (signal-error 'wrong-type-argument (list ,predicate ,argument)))))
829 (defun signal-error (error-symbol data)
830 "Signal a non-continuable error. Args are ERROR-SYMBOL, and associated DATA.
831 An error symbol is a symbol defined using `define-error'.
832 DATA should be a list. Its elements are printed as part of the error message.
833 If the signal is handled, DATA is made available to the handler.
834 See also `signal', and the functions to handle errors: `condition-case'
835 and `call-with-condition-handler'."
837 (signal error-symbol data)))
839 (defun define-error (error-sym doc-string &optional inherits-from)
840 "Define a new error, denoted by ERROR-SYM.
841 DOC-STRING is an informative message explaining the error, and will be
842 printed out when an unhandled error occurs.
843 ERROR-SYM is a sub-error of INHERITS-FROM (which defaults to `error').
845 \[`define-error' internally works by putting on ERROR-SYM an `error-message'
846 property whose value is DOC-STRING, and an `error-conditions' property
847 that is a list of ERROR-SYM followed by each of its super-errors, up
848 to and including `error'. You will sometimes see code that sets this up
849 directly rather than calling `define-error', but you should *not* do this
851 (check-argument-type 'symbolp error-sym)
852 (check-argument-type 'stringp doc-string)
853 (put error-sym 'error-message doc-string)
854 (or inherits-from (setq inherits-from 'error))
855 (let ((conds (get inherits-from 'error-conditions)))
856 (or conds (signal-error 'error (list "Not an error symbol" error-sym)))
857 (put error-sym 'error-conditions (cons error-sym conds))))
859 (defun defined-error-p (sym)
860 "Returns non-nil if SYM names a currently-defined error."
861 (and (symbolp sym) (not (null (get sym 'error-conditions)))))
866 ;(defun buffer-substring-no-properties (start end)
867 ; "Return the text from START to END, without text properties, as a string."
868 ; (let ((string (buffer-substring start end)))
869 ; (set-text-properties 0 (length string) nil string)
872 (defun get-buffer-window-list (&optional buffer minibuf frame)
873 "Return windows currently displaying BUFFER, or nil if none.
874 BUFFER defaults to the current buffer.
875 See `walk-windows' for the meaning of MINIBUF and FRAME."
877 (setq buffer (current-buffer)))
878 ((not (bufferp buffer))
879 (setq buffer (get-buffer buffer))))
881 (walk-windows (lambda (window)
882 (if (eq (window-buffer window) buffer)
883 (push window windows)))
887 (defun ignore (&rest ignore)
888 "Do nothing and return nil.
889 This function accepts any number of arguments, but ignores them."
893 (define-function 'eval-in-buffer 'with-current-buffer)
894 (make-obsolete 'eval-in-buffer 'with-current-buffer)
896 ;;; The real defn is in abbrev.el but some early callers
897 ;;; (eg lisp-mode-abbrev-table) want this before abbrev.el is loaded...
899 (if (not (fboundp 'define-abbrev-table))
901 (setq abbrev-table-name-list '())
902 (fset 'define-abbrev-table (function (lambda (name defs)
903 ;; These are fixed-up when abbrev.el loads.
904 (setq abbrev-table-name-list
905 (cons (cons name defs)
906 abbrev-table-name-list)))))))
908 ;;; `functionp' has been moved into C.
910 ;;(defun functionp (object)
911 ;; "Non-nil if OBJECT can be called as a function."
912 ;; (or (and (symbolp object) (fboundp object))
914 ;; (compiled-function-p object)
915 ;; (eq (car-safe object) 'lambda)))
919 (defun function-interactive (function)
920 "Return the interactive specification of FUNCTION.
921 FUNCTION can be any funcallable object.
922 The specification will be returned as the list of the symbol `interactive'
924 If FUNCTION is not interactive, nil will be returned."
925 (setq function (indirect-function function))
926 (cond ((compiled-function-p function)
927 (compiled-function-interactive function))
929 (subr-interactive function))
930 ((eq (car-safe function) 'lambda)
931 (let ((spec (if (stringp (nth 2 function))
934 (and (eq (car-safe spec) 'interactive)
937 (error "Non-funcallable object: %s" function))))
939 (defun function-allows-args (function n)
940 "Return whether FUNCTION can be called with N arguments."
941 (and (<= (function-min-args function) n)
942 (or (null (function-max-args function))
943 (<= n (function-max-args function)))))
945 ;; This function used to be an alias to `buffer-substring', except
946 ;; that FSF Emacs 20.4 added a BUFFER argument in an incompatible way.
947 ;; The new FSF's semantics makes more sense, but we try to support
948 ;; both for backward compatibility.
949 (defun buffer-string (&optional buffer old-end old-buffer)
950 "Return the contents of the current buffer as a string.
951 If narrowing is in effect, this function returns only the visible part
954 If BUFFER is specified, the contents of that buffer are returned.
956 The arguments OLD-END and OLD-BUFFER are supported for backward
957 compatibility with pre-21.2 XEmacsen times when arguments to this
958 function were (buffer-string &optional START END BUFFER)."
960 ((or (stringp buffer) (bufferp buffer))
961 ;; Most definitely the new way.
962 (buffer-substring nil nil buffer))
963 ((or (stringp old-buffer) (bufferp old-buffer)
964 (natnump buffer) (natnump old-end))
965 ;; Definitely the old way.
966 (buffer-substring buffer old-end old-buffer))
968 ;; Probably the old way.
969 (buffer-substring buffer old-end old-buffer))))
971 ;; This was not present before. I think Jamie had some objections
972 ;; to this, so I'm leaving this undefined for now. --ben
974 ;;; The objection is this: there is more than one way to load the same file.
975 ;;; "foo", "foo.elc", "foo.el", and "/some/path/foo.elc" are all different
976 ;;; ways to load the exact same code. `eval-after-load' is too stupid to
977 ;;; deal with this sort of thing. If this sort of feature is desired, then
978 ;;; it should work off of a hook on `provide'. Features are unique and
979 ;;; the arguments to (load) are not. --Stig
981 ;; We provide this for FSFmacs compatibility, at least until we devise
984 ;;;; Specifying things to do after certain files are loaded.
986 (defun eval-after-load (file form)
987 "Arrange that, if FILE is ever loaded, FORM will be run at that time.
988 This makes or adds to an entry on `after-load-alist'.
989 If FILE is already loaded, evaluate FORM right now.
990 It does nothing if FORM is already on the list for FILE.
991 FILE should be the name of a library, with no directory name."
992 ;; Make sure there is an element for FILE.
993 (or (assoc file after-load-alist)
994 (setq after-load-alist (cons (list file) after-load-alist)))
995 ;; Add FORM to the element if it isn't there.
996 (let ((elt (assoc file after-load-alist)))
997 (or (member form (cdr elt))
999 (nconc elt (list form))
1000 ;; If the file has been loaded already, run FORM right away.
1001 (and (assoc file load-history)
1004 (make-compatible 'eval-after-load "")
1006 (defun eval-next-after-load (file)
1007 "Read the following input sexp, and run it whenever FILE is loaded.
1008 This makes or adds to an entry on `after-load-alist'.
1009 FILE should be the name of a library, with no directory name."
1010 (eval-after-load file (read)))
1011 (make-compatible 'eval-next-after-load "")
1013 ; alternate names (not obsolete)
1014 (if (not (fboundp 'mod)) (define-function 'mod '%))
1015 (define-function 'move-marker 'set-marker)
1016 (define-function 'beep 'ding) ; preserve lingual purity
1017 (define-function 'indent-to-column 'indent-to)
1018 (define-function 'backward-delete-char 'delete-backward-char)
1019 (define-function 'search-forward-regexp (symbol-function 're-search-forward))
1020 (define-function 'search-backward-regexp (symbol-function 're-search-backward))
1021 (define-function 'remove-directory 'delete-directory)
1022 (define-function 'set-match-data 'store-match-data)
1023 (define-function 'send-string-to-terminal 'external-debugging-output)
1025 ;;; subr.el ends here