(G-GT-46512): Unify G-GT-46512 instead of A-GT-46512; unify G-UU+8936.
[chise/xemacs-chise.git] / lisp / subr.el
1 ;;; subr.el --- basic lisp subroutines for XEmacs
2
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.
7
8 ;; Maintainer: XEmacs Development Team
9 ;; Keywords: extensions, dumped
10
11 ;; This file is part of XEmacs.
12
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)
16 ;; any later version.
17
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.
22
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
26 ;; 02111-1307, USA.
27
28 ;;; Synched up with: FSF 19.34.  Some things synched up with later versions.
29
30 ;;; Commentary:
31
32 ;; This file is dumped with XEmacs.
33
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
38
39 ;;; Code:
40
41 \f
42 ;;;; Lisp language features.
43
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.
51
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)))
60
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))
65        nil
66      (defun ,@args)))
67
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))
72        nil
73      (define-function ,@args)))
74
75 \f
76 ;;;; Keymap support.
77 ;; XEmacs: removed to keymap.el
78
79 ;;;; The global keymap tree.
80
81 ;;; global-map, esc-map, and ctl-x-map have their values set up in
82 ;;; keymap.c; we just give them docstrings here.
83
84 ;;;; Event manipulation functions.
85
86 ;; XEmacs: This stuff is done in C Code.
87
88 ;;;; Obsolescent names for functions.
89 ;; XEmacs: not used.
90
91 ;; XEmacs:
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
96 called on SYM."
97   (local-variable-p sym buffer t))
98
99 \f
100 ;;;; Hook manipulation functions.
101
102 ;; (defconst run-hooks 'run-hooks ...)
103
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.
110
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
116 one.
117
118 This function does nothing if HOOK is already local in the current
119 buffer.
120
121 Do not use `make-local-variable' to make a hook variable buffer-local.
122
123 See also `add-local-hook' and `remove-local-hook'."
124   (if (local-variable-p hook (current-buffer)) ; XEmacs
125       nil
126     (or (boundp hook) (set hook nil))
127     (make-local-variable hook)
128     (set hook (list t))))
129
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.
136
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'.
142
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.
146
147 You can remove this hook yourself using `remove-hook'.
148
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))))
156   (if (or local
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)))
165           (set hook
166                (if append
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)))
174         (set-default hook
175                      (if append
176                          (append (default-value hook) (list function))
177                        (cons function (default-value hook)))))))
178
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'.
184
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
194       nil                               ;Do nothing.
195     (flet ((hook-remove
196             (function hook-value)
197             (flet ((hook-test
198                     (fn hel)
199                     (or (equal fn hel)
200                         (and (symbolp hel)
201                              (equal fn
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)
206                       (setq hook-value
207                             (delete* function (copy-sequence hook-value)
208                                      :test 'hook-test)))
209                 (if (equal hook-value function)
210                     (setq hook-value nil)))
211               hook-value)))
212       (if (or local
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)))))))
219
220 ;; XEmacs addition
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.
231
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.
235
236 You can remove this hook yourself using `remove-local-hook'.
237
238 See also `add-hook' and `make-local-hook'."
239   (make-local-hook hook)
240   (add-hook hook function append t))
241
242 ;; XEmacs addition
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'.
250
251 See also `add-local-hook' and `make-local-hook'."
252   (if (local-variable-p hook (current-buffer))
253       (remove-hook hook function t)))
254
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.
263
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.
267
268 You can remove this hook yourself using `remove-hook'.
269
270 See also `add-hook', `add-local-hook', and `add-local-one-shot-hook'."
271   (let ((sym (gensym)))
272     (fset sym `(lambda (&rest args)
273                  (unwind-protect
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)))
278
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.
287
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'.
293
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.
297
298 You can remove this hook yourself using `remove-local-hook'.
299
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))
303
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.
310
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)
318     (set list-var
319          (if append
320              (append (symbol-value list-var) (list element))
321            (cons element (symbol-value list-var))))))
322
323 ;; XEmacs additions
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.")
329
330 ;; in C in FSFmacs
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.")
334
335 ;; not obsolete.
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)
341 ;;   conscell)
342 ;; ...and analogously for RPLACD.
343 (define-function 'rplaca 'setcar)
344 (define-function 'rplacd 'setcdr)
345
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.
355       (and (boundp symbol)
356            (set new (symbol-value symbol)))
357       (and (fboundp symbol)
358            (fset new (symbol-function symbol)))
359       (setplist new (copy-list (symbol-plist symbol))))
360     new))
361
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.
366
367 NOTE: At some point, this will be moved into C and will be very fast."
368   (with-current-buffer buffer
369     (set sym val)))
370
371 ;;;; String functions.
372
373 ;; XEmacs
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))
392         (with-temp-buffer
393           (setq case-fold-search cfs)
394           (insert str)
395           (goto-char 1)
396           (while (re-search-forward regexp nil t)
397             (replace-match newtext t literal))
398           (buffer-string)))
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)))
403             str newstr))
404     str)))
405
406 (defconst split-string-default-separators "[ \f\t\n\r\v]+"
407   "The default value of separators for `split-string'.
408
409 A regexp matching strings of whitespace.  May be locale-dependent
410 \(as yet unimplemented).  Should not match non-breaking spaces.
411
412 Warning: binding this to a different value and using it as default is
413 likely to have undesired semantics.")
414
415 ;; specification for `split-string' agreed with rms 2003-04-23
416 ;; xemacs design <87vfx5vor0.fsf@tleepslib.sk.tsukuba.ac.jp>
417
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.
422
423 (defun split-string (string &optional separators omit-nulls)
424   "Splits STRING into substrings bounded by matches for SEPARATORS.
425
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,
429 which is returned.
430
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.
435
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.
440
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)'.
445
446 Modifies the match data when successful; use `save-match-data' if necessary."
447
448   (let ((keep-nulls (not (if separators omit-nulls t)))
449         (rexp (or separators split-string-default-separators))
450         (start 0)
451         notfirst
452         (list nil))
453     (while (and (string-match rexp string
454                               (if (and notfirst
455                                        (= start (match-beginning 0))
456                                        (< start (length string)))
457                                   (1+ start) start))
458                 (< start (length string)))
459       (setq notfirst t)
460       (if (or keep-nulls (< start (match-beginning 0)))
461           (setq list
462                 (cons (substring string start (match-beginning 0))
463                       list)))
464       (setq start (match-end 0)))
465     (if (or keep-nulls (< start (length string)))
466         (setq list
467               (cons (substring string start)
468                     list)))
469     (nreverse list)))
470
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"
481 ;                                             path-separator))))
482 ;  (split-string-by-char path (aref separator 0)))
483
484 (defmacro with-output-to-string (&rest forms)
485   "Collect output to `standard-output' while evaluating FORMS and return
486 it as a string."
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))
492      (erase-buffer)
493      (let ((standard-output (current-buffer)))
494        ,@forms)
495      (prog1
496          (buffer-string)
497        (erase-buffer))))
498
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
504     (set-buffer ,buffer)
505     ,@body))
506
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)
514            (,temp-buffer
515             (get-buffer-create (generate-new-buffer-name " *temp file*"))))
516        (unwind-protect
517            (prog1
518                (with-current-buffer ,temp-buffer
519                  ,@forms)
520              (with-current-buffer ,temp-buffer
521                (widen)
522                (write-region (point-min) (point-max) ,temp-file nil 0)))
523          (and (buffer-name ,temp-buffer)
524               (kill-buffer ,temp-buffer))))))
525
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")))
530     `(let ((,temp-buffer
531             (get-buffer-create (generate-new-buffer-name " *temp*"))))
532        (unwind-protect
533            (with-current-buffer ,temp-buffer
534              ,@forms)
535          (and (buffer-name ,temp-buffer)
536               (kill-buffer ,temp-buffer))))))
537
538 ;; BEGIN FSF 21.3 SYNCH
539 (defmacro with-local-quit (&rest body)
540   "Execute BODY with `inhibit-quit' temporarily bound to nil."
541   `(condition-case nil
542     (let ((inhibit-quit nil))
543       ,@body)
544     (quit (setq quit-flag t))))
545
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)
552
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."
557   (if delay-mode-hooks
558       ;; Delaying case.
559       (dolist (hook hooks)
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)))
565
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."
569   `(progn
570     (make-local-variable 'delay-mode-hooks)
571     (let ((delay-mode-hooks t))
572       ,@body)))
573 ;; END FSF 21.3 SYNCH
574
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."
580   `(with-temp-buffer
581      (insert ,str)
582      ,@body
583      (buffer-string)))
584
585 (defun insert-face (string face)
586   "Insert STRING and highlight with FACE.  Return the extent created."
587   (let ((p (point)) ext)
588     (insert string)
589     (setq ext (make-extent p (point)))
590     (set-extent-face ext face)
591     ext))
592
593 ;; not obsolete.
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)
598
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)
603
604 \f
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
609
610 \(a 1 b 2 c 3)
611
612 into
613
614 \((a . 1) (b . 2) (c . 3))
615
616 The original plist is not modified.  See also `destructive-plist-to-alist'."
617   (let (alist)
618     (while plist
619       (setq alist (cons (cons (car plist) (cadr plist)) alist))
620       (setq plist (cddr plist)))
621     (nreverse alist)))
622
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
626
627 \(a 1 b 2 c 3)
628
629 into
630
631 \((a . 1) (b . 2) (c . 3))
632
633 The original plist is destroyed in the process of constructing the alist.
634 See also `plist-to-alist'."
635   (let ((head plist)
636         next)
637     (while plist
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))
645       (setcdr plist next)
646       (setq plist next))
647     head))
648
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
652
653 \((a . 1) (b . 2) (c . 3))
654
655 into
656
657 \(a 1 b 2 c 3)
658
659 The original alist is not modified.  See also `destructive-alist-to-plist'."
660   (let (plist)
661     (while alist
662       (let ((el (car alist)))
663         (setq plist (cons (cdr el) (cons (car el) plist))))
664       (setq alist (cdr alist)))
665     (nreverse plist)))
666
667 ;; getf, remf in cl*.el.
668
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)))
673
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)))
678
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)))
683 \f
684 ;;; Error functions
685
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.
691
692 This error is not continuable: you cannot continue execution after the
693 error using the debugger `r' command.  See also `cerror'.
694
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.:
702
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.
715
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:
722
723 error
724   syntax-error
725     invalid-read-syntax
726     list-formation-error
727       malformed-list
728         malformed-property-list
729       circular-list
730         circular-property-list
731     invalid-regexp
732     specifier-syntax-error
733
734
735   invalid-argument
736     wrong-type-argument
737     args-out-of-range
738     wrong-number-of-arguments
739     invalid-function
740     no-catch
741     undefined-keystroke-sequence
742     specifier-argument-error
743
744   invalid-state
745     void-function
746     cyclic-function-indirection
747     void-variable
748     cyclic-variable-indirection
749     protected-field
750     invalid-byte-code
751
752   invalid-operation
753     invalid-change
754       setting-constant
755       specifier-change-error
756     editing-error
757       beginning-of-buffer
758       end-of-buffer
759       buffer-read-only
760     io-error
761       file-error
762         file-already-exists
763         file-locked
764         file-supersession
765       end-of-file
766       coding-system-error
767       image-conversion-error
768       tooltalk-error
769     arith-error
770       range-error
771       domain-error
772       singularity-error
773       overflow-error
774       underflow-error
775     dialog-box-error
776     search-failed
777     selection-conversion-error
778
779   unimplemented
780
781   internal-error
782
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:
786
787 -- `syntax-error' is for errors in complex structures: parsed strings, lists,
788    and the like.
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
800    arithmetic errors.
801
802 See also `cerror', `signal', and `signal-error'."
803   (while t (apply
804             'cerror datum args)))
805
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)
811          (signal datum args))
812         (t
813          (error 'invalid-argument "datum not string or error symbol" datum))))
814
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))
824            (setq ,argument
825                  (wrong-type-argument ,predicate ,argument)))
826     `(if (not (,(eval predicate) ,argument))
827          (signal-error 'wrong-type-argument (list ,predicate ,argument)))))
828
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'."
836   (while t
837     (signal error-symbol data)))
838
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').
844
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
850 yourself.]"
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))))
858
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)))))
862
863 ;;;; Miscellanea.
864
865 ;; This is now in C.
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)
870 ;    string))
871
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."
876   (cond ((null buffer)
877          (setq buffer (current-buffer)))
878         ((not (bufferp buffer))
879          (setq buffer (get-buffer buffer))))
880   (let (windows)
881     (walk-windows (lambda (window)
882                     (if (eq (window-buffer window) buffer)
883                         (push window windows)))
884                   minibuf frame)
885     windows))
886
887 (defun ignore (&rest ignore)
888   "Do nothing and return nil.
889 This function accepts any number of arguments, but ignores them."
890   (interactive)
891   nil)
892
893 (define-function 'eval-in-buffer 'with-current-buffer)
894 (make-obsolete 'eval-in-buffer 'with-current-buffer)
895
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...
898
899 (if (not (fboundp 'define-abbrev-table))
900     (progn
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)))))))
907
908 ;;; `functionp' has been moved into C.
909
910 ;;(defun functionp (object)
911 ;;  "Non-nil if OBJECT can be called as a function."
912 ;;  (or (and (symbolp object) (fboundp object))
913 ;;      (subrp object)
914 ;;      (compiled-function-p object)
915 ;;      (eq (car-safe object) 'lambda)))
916
917
918
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'
923  and the specs.
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))
928         ((subrp function)
929          (subr-interactive function))
930         ((eq (car-safe function) 'lambda)
931          (let ((spec (if (stringp (nth 2 function))
932                          (nth 3 function)
933                        (nth 2 function))))
934            (and (eq (car-safe spec) 'interactive)
935                 spec)))
936         (t
937          (error "Non-funcallable object: %s" function))))
938
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)))))
944
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
952 of the buffer.
953
954 If BUFFER is specified, the contents of that buffer are returned.
955
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)."
959   (cond
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))
967    (t
968     ;; Probably the old way.
969     (buffer-substring buffer old-end old-buffer))))
970
971 ;; This was not present before.  I think Jamie had some objections
972 ;; to this, so I'm leaving this undefined for now. --ben
973
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
980
981 ;; We provide this for FSFmacs compatibility, at least until we devise
982 ;; something better.
983
984 ;;;; Specifying things to do after certain files are loaded.
985
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))
998         (progn
999           (nconc elt (list form))
1000           ;; If the file has been loaded already, run FORM right away.
1001           (and (assoc file load-history)
1002                (eval form)))))
1003   form)
1004 (make-compatible 'eval-after-load "")
1005
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 "")
1012
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)
1024
1025 ;;; subr.el ends here