diff options
| author | Richard M. Stallman | 2005-10-22 15:01:08 +0000 |
|---|---|---|
| committer | Richard M. Stallman | 2005-10-22 15:01:08 +0000 |
| commit | c4f484f2796623300cb64a2ce23d1b90a688e4e6 (patch) | |
| tree | bc38c5f6e0b0be41dc1bd74046f0a2ff09645cc9 | |
| parent | 5798342c35897393d48f06eae807417fd71e3424 (diff) | |
| download | emacs-c4f484f2796623300cb64a2ce23d1b90a688e4e6.tar.gz emacs-c4f484f2796623300cb64a2ce23d1b90a688e4e6.zip | |
Much rearrangement of functions and division into pages. No code changes.
| -rw-r--r-- | lisp/subr.el | 1124 |
1 files changed, 580 insertions, 544 deletions
diff --git a/lisp/subr.el b/lisp/subr.el index 32ee6f987b7..2348c1e3c5d 100644 --- a/lisp/subr.el +++ b/lisp/subr.el | |||
| @@ -37,7 +37,7 @@ Each element of this list holds the arguments to one call to `defcustom'.") | |||
| 37 | (cons arguments custom-declare-variable-list))) | 37 | (cons arguments custom-declare-variable-list))) |
| 38 | 38 | ||
| 39 | 39 | ||
| 40 | ;;;; Lisp language features. | 40 | ;;;; Basic Lisp macros. |
| 41 | 41 | ||
| 42 | (defalias 'not 'null) | 42 | (defalias 'not 'null) |
| 43 | 43 | ||
| @@ -144,6 +144,59 @@ the return value (nil if RESULT is omitted). | |||
| 144 | Treated as a declaration when used at the right place in a | 144 | Treated as a declaration when used at the right place in a |
| 145 | `defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)" | 145 | `defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)" |
| 146 | nil) | 146 | nil) |
| 147 | |||
| 148 | ;;;; Basic Lisp functions. | ||
| 149 | |||
| 150 | (defun ignore (&rest ignore) | ||
| 151 | "Do nothing and return nil. | ||
| 152 | This function accepts any number of arguments, but ignores them." | ||
| 153 | (interactive) | ||
| 154 | nil) | ||
| 155 | |||
| 156 | (defun error (&rest args) | ||
| 157 | "Signal an error, making error message by passing all args to `format'. | ||
| 158 | In Emacs, the convention is that error messages start with a capital | ||
| 159 | letter but *do not* end with a period. Please follow this convention | ||
| 160 | for the sake of consistency." | ||
| 161 | (while t | ||
| 162 | (signal 'error (list (apply 'format args))))) | ||
| 163 | |||
| 164 | ;; We put this here instead of in frame.el so that it's defined even on | ||
| 165 | ;; systems where frame.el isn't loaded. | ||
| 166 | (defun frame-configuration-p (object) | ||
| 167 | "Return non-nil if OBJECT seems to be a frame configuration. | ||
| 168 | Any list whose car is `frame-configuration' is assumed to be a frame | ||
| 169 | configuration." | ||
| 170 | (and (consp object) | ||
| 171 | (eq (car object) 'frame-configuration))) | ||
| 172 | |||
| 173 | (defun functionp (object) | ||
| 174 | "Non-nil if OBJECT is any kind of function or a special form. | ||
| 175 | Also non-nil if OBJECT is a symbol and its function definition is | ||
| 176 | \(recursively) a function or special form. This does not include | ||
| 177 | macros." | ||
| 178 | (or (and (symbolp object) (fboundp object) | ||
| 179 | (condition-case nil | ||
| 180 | (setq object (indirect-function object)) | ||
| 181 | (error nil)) | ||
| 182 | (eq (car-safe object) 'autoload) | ||
| 183 | (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object))))))) | ||
| 184 | (subrp object) (byte-code-function-p object) | ||
| 185 | (eq (car-safe object) 'lambda))) | ||
| 186 | |||
| 187 | ;; This should probably be written in C (i.e., without using `walk-windows'). | ||
| 188 | (defun get-buffer-window-list (buffer &optional minibuf frame) | ||
| 189 | "Return list of all windows displaying BUFFER, or nil if none. | ||
| 190 | BUFFER can be a buffer or a buffer name. | ||
| 191 | See `walk-windows' for the meaning of MINIBUF and FRAME." | ||
| 192 | (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows) | ||
| 193 | (walk-windows (function (lambda (window) | ||
| 194 | (if (eq (window-buffer window) buffer) | ||
| 195 | (setq windows (cons window windows))))) | ||
| 196 | minibuf frame) | ||
| 197 | windows)) | ||
| 198 | |||
| 199 | ;;;; List functions. | ||
| 147 | 200 | ||
| 148 | (defsubst caar (x) | 201 | (defsubst caar (x) |
| 149 | "Return the car of the car of X." | 202 | "Return the car of the car of X." |
| @@ -240,23 +293,6 @@ of course, also replace TO with a slightly larger value | |||
| 240 | next (+ from (* n inc))))) | 293 | next (+ from (* n inc))))) |
| 241 | (nreverse seq)))) | 294 | (nreverse seq)))) |
| 242 | 295 | ||
| 243 | (defun remove (elt seq) | ||
| 244 | "Return a copy of SEQ with all occurrences of ELT removed. | ||
| 245 | SEQ must be a list, vector, or string. The comparison is done with `equal'." | ||
| 246 | (if (nlistp seq) | ||
| 247 | ;; If SEQ isn't a list, there's no need to copy SEQ because | ||
| 248 | ;; `delete' will return a new object. | ||
| 249 | (delete elt seq) | ||
| 250 | (delete elt (copy-sequence seq)))) | ||
| 251 | |||
| 252 | (defun remq (elt list) | ||
| 253 | "Return LIST with all occurrences of ELT removed. | ||
| 254 | The comparison is done with `eq'. Contrary to `delq', this does not use | ||
| 255 | side-effects, and the argument LIST is not modified." | ||
| 256 | (if (memq elt list) | ||
| 257 | (delq elt (copy-sequence list)) | ||
| 258 | list)) | ||
| 259 | |||
| 260 | (defun copy-tree (tree &optional vecp) | 296 | (defun copy-tree (tree &optional vecp) |
| 261 | "Make a copy of TREE. | 297 | "Make a copy of TREE. |
| 262 | If TREE is a cons cell, this recursively copies both its car and its cdr. | 298 | If TREE is a cons cell, this recursively copies both its car and its cdr. |
| @@ -277,6 +313,8 @@ argument VECP, this copies vectors as well as conses." | |||
| 277 | (aset tree i (copy-tree (aref tree i) vecp))) | 313 | (aset tree i (copy-tree (aref tree i) vecp))) |
| 278 | tree) | 314 | tree) |
| 279 | tree))) | 315 | tree))) |
| 316 | |||
| 317 | ;;;; Various list-search functions. | ||
| 280 | 318 | ||
| 281 | (defun assoc-default (key alist &optional test default) | 319 | (defun assoc-default (key alist &optional test default) |
| 282 | "Find object KEY in a pseudo-alist ALIST. | 320 | "Find object KEY in a pseudo-alist ALIST. |
| @@ -321,15 +359,67 @@ Non-strings in LIST are ignored." | |||
| 321 | (setq list (cdr list))) | 359 | (setq list (cdr list))) |
| 322 | list) | 360 | list) |
| 323 | 361 | ||
| 362 | (defun assq-delete-all (key alist) | ||
| 363 | "Delete from ALIST all elements whose car is `eq' to KEY. | ||
| 364 | Return the modified alist. | ||
| 365 | Elements of ALIST that are not conses are ignored." | ||
| 366 | (while (and (consp (car alist)) | ||
| 367 | (eq (car (car alist)) key)) | ||
| 368 | (setq alist (cdr alist))) | ||
| 369 | (let ((tail alist) tail-cdr) | ||
| 370 | (while (setq tail-cdr (cdr tail)) | ||
| 371 | (if (and (consp (car tail-cdr)) | ||
| 372 | (eq (car (car tail-cdr)) key)) | ||
| 373 | (setcdr tail (cdr tail-cdr)) | ||
| 374 | (setq tail tail-cdr)))) | ||
| 375 | alist) | ||
| 376 | |||
| 377 | (defun rassq-delete-all (value alist) | ||
| 378 | "Delete from ALIST all elements whose cdr is `eq' to VALUE. | ||
| 379 | Return the modified alist. | ||
| 380 | Elements of ALIST that are not conses are ignored." | ||
| 381 | (while (and (consp (car alist)) | ||
| 382 | (eq (cdr (car alist)) value)) | ||
| 383 | (setq alist (cdr alist))) | ||
| 384 | (let ((tail alist) tail-cdr) | ||
| 385 | (while (setq tail-cdr (cdr tail)) | ||
| 386 | (if (and (consp (car tail-cdr)) | ||
| 387 | (eq (cdr (car tail-cdr)) value)) | ||
| 388 | (setcdr tail (cdr tail-cdr)) | ||
| 389 | (setq tail tail-cdr)))) | ||
| 390 | alist) | ||
| 391 | |||
| 392 | (defun remove (elt seq) | ||
| 393 | "Return a copy of SEQ with all occurrences of ELT removed. | ||
| 394 | SEQ must be a list, vector, or string. The comparison is done with `equal'." | ||
| 395 | (if (nlistp seq) | ||
| 396 | ;; If SEQ isn't a list, there's no need to copy SEQ because | ||
| 397 | ;; `delete' will return a new object. | ||
| 398 | (delete elt seq) | ||
| 399 | (delete elt (copy-sequence seq)))) | ||
| 400 | |||
| 401 | (defun remq (elt list) | ||
| 402 | "Return LIST with all occurrences of ELT removed. | ||
| 403 | The comparison is done with `eq'. Contrary to `delq', this does not use | ||
| 404 | side-effects, and the argument LIST is not modified." | ||
| 405 | (if (memq elt list) | ||
| 406 | (delq elt (copy-sequence list)) | ||
| 407 | list)) | ||
| 324 | 408 | ||
| 325 | ;;;; Keymap support. | 409 | ;;;; Keymap support. |
| 326 | 410 | ||
| 411 | (defmacro kbd (keys) | ||
| 412 | "Convert KEYS to the internal Emacs key representation. | ||
| 413 | KEYS should be a string constant in the format used for | ||
| 414 | saving keyboard macros (see `edmacro-mode')." | ||
| 415 | (read-kbd-macro keys)) | ||
| 416 | |||
| 327 | (defun undefined () | 417 | (defun undefined () |
| 328 | (interactive) | 418 | (interactive) |
| 329 | (ding)) | 419 | (ding)) |
| 330 | 420 | ||
| 331 | ;Prevent the \{...} documentation construct | 421 | ;; Prevent the \{...} documentation construct |
| 332 | ;from mentioning keys that run this command. | 422 | ;; from mentioning keys that run this command. |
| 333 | (put 'undefined 'suppress-keymap t) | 423 | (put 'undefined 'suppress-keymap t) |
| 334 | 424 | ||
| 335 | (defun suppress-keymap (map &optional nodigits) | 425 | (defun suppress-keymap (map &optional nodigits) |
| @@ -346,76 +436,6 @@ but optional second arg NODIGITS non-nil treats them like other chars." | |||
| 346 | (define-key map (char-to-string loop) 'digit-argument) | 436 | (define-key map (char-to-string loop) 'digit-argument) |
| 347 | (setq loop (1+ loop)))))) | 437 | (setq loop (1+ loop)))))) |
| 348 | 438 | ||
| 349 | (defvar key-substitution-in-progress nil | ||
| 350 | "Used internally by `substitute-key-definition'.") | ||
| 351 | |||
| 352 | (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) | ||
| 353 | "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. | ||
| 354 | In other words, OLDDEF is replaced with NEWDEF where ever it appears. | ||
| 355 | Alternatively, if optional fourth argument OLDMAP is specified, we redefine | ||
| 356 | in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP. | ||
| 357 | |||
| 358 | For most uses, it is simpler and safer to use command remappping like this: | ||
| 359 | \(define-key KEYMAP [remap OLDDEF] NEWDEF)" | ||
| 360 | ;; Don't document PREFIX in the doc string because we don't want to | ||
| 361 | ;; advertise it. It's meant for recursive calls only. Here's its | ||
| 362 | ;; meaning | ||
| 363 | |||
| 364 | ;; If optional argument PREFIX is specified, it should be a key | ||
| 365 | ;; prefix, a string. Redefined bindings will then be bound to the | ||
| 366 | ;; original key, with PREFIX added at the front. | ||
| 367 | (or prefix (setq prefix "")) | ||
| 368 | (let* ((scan (or oldmap keymap)) | ||
| 369 | (prefix1 (vconcat prefix [nil])) | ||
| 370 | (key-substitution-in-progress | ||
| 371 | (cons scan key-substitution-in-progress))) | ||
| 372 | ;; Scan OLDMAP, finding each char or event-symbol that | ||
| 373 | ;; has any definition, and act on it with hack-key. | ||
| 374 | (map-keymap | ||
| 375 | (lambda (char defn) | ||
| 376 | (aset prefix1 (length prefix) char) | ||
| 377 | (substitute-key-definition-key defn olddef newdef prefix1 keymap)) | ||
| 378 | scan))) | ||
| 379 | |||
| 380 | (defun substitute-key-definition-key (defn olddef newdef prefix keymap) | ||
| 381 | (let (inner-def skipped menu-item) | ||
| 382 | ;; Find the actual command name within the binding. | ||
| 383 | (if (eq (car-safe defn) 'menu-item) | ||
| 384 | (setq menu-item defn defn (nth 2 defn)) | ||
| 385 | ;; Skip past menu-prompt. | ||
| 386 | (while (stringp (car-safe defn)) | ||
| 387 | (push (pop defn) skipped)) | ||
| 388 | ;; Skip past cached key-equivalence data for menu items. | ||
| 389 | (if (consp (car-safe defn)) | ||
| 390 | (setq defn (cdr defn)))) | ||
| 391 | (if (or (eq defn olddef) | ||
| 392 | ;; Compare with equal if definition is a key sequence. | ||
| 393 | ;; That is useful for operating on function-key-map. | ||
| 394 | (and (or (stringp defn) (vectorp defn)) | ||
| 395 | (equal defn olddef))) | ||
| 396 | (define-key keymap prefix | ||
| 397 | (if menu-item | ||
| 398 | (let ((copy (copy-sequence menu-item))) | ||
| 399 | (setcar (nthcdr 2 copy) newdef) | ||
| 400 | copy) | ||
| 401 | (nconc (nreverse skipped) newdef))) | ||
| 402 | ;; Look past a symbol that names a keymap. | ||
| 403 | (setq inner-def | ||
| 404 | (and defn | ||
| 405 | (condition-case nil (indirect-function defn) (error defn)))) | ||
| 406 | ;; For nested keymaps, we use `inner-def' rather than `defn' so as to | ||
| 407 | ;; avoid autoloading a keymap. This is mostly done to preserve the | ||
| 408 | ;; original non-autoloading behavior of pre-map-keymap times. | ||
| 409 | (if (and (keymapp inner-def) | ||
| 410 | ;; Avoid recursively scanning | ||
| 411 | ;; where KEYMAP does not have a submap. | ||
| 412 | (let ((elt (lookup-key keymap prefix))) | ||
| 413 | (or (null elt) (natnump elt) (keymapp elt))) | ||
| 414 | ;; Avoid recursively rescanning keymap being scanned. | ||
| 415 | (not (memq inner-def key-substitution-in-progress))) | ||
| 416 | ;; If this one isn't being scanned already, scan it now. | ||
| 417 | (substitute-key-definition olddef newdef keymap inner-def prefix))))) | ||
| 418 | |||
| 419 | (defun define-key-after (keymap key definition &optional after) | 439 | (defun define-key-after (keymap key definition &optional after) |
| 420 | "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. | 440 | "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. |
| 421 | This is like `define-key' except that the binding for KEY is placed | 441 | This is like `define-key' except that the binding for KEY is placed |
| @@ -483,12 +503,6 @@ Don't call this function; it is for internal use only." | |||
| 483 | (funcall function (car p) (cdr p)))) | 503 | (funcall function (car p) (cdr p)))) |
| 484 | (map-keymap function keymap))) | 504 | (map-keymap function keymap))) |
| 485 | 505 | ||
| 486 | (defmacro kbd (keys) | ||
| 487 | "Convert KEYS to the internal Emacs key representation. | ||
| 488 | KEYS should be a string constant in the format used for | ||
| 489 | saving keyboard macros (see `edmacro-mode')." | ||
| 490 | (read-kbd-macro keys)) | ||
| 491 | |||
| 492 | (put 'keyboard-translate-table 'char-table-extra-slots 0) | 506 | (put 'keyboard-translate-table 'char-table-extra-slots 0) |
| 493 | 507 | ||
| 494 | (defun keyboard-translate (from to) | 508 | (defun keyboard-translate (from to) |
| @@ -499,6 +513,128 @@ and then modifies one entry in it." | |||
| 499 | (setq keyboard-translate-table | 513 | (setq keyboard-translate-table |
| 500 | (make-char-table 'keyboard-translate-table nil))) | 514 | (make-char-table 'keyboard-translate-table nil))) |
| 501 | (aset keyboard-translate-table from to)) | 515 | (aset keyboard-translate-table from to)) |
| 516 | |||
| 517 | ;;;; Key binding commands. | ||
| 518 | |||
| 519 | (defun global-set-key (key command) | ||
| 520 | "Give KEY a global binding as COMMAND. | ||
| 521 | COMMAND is the command definition to use; usually it is | ||
| 522 | a symbol naming an interactively-callable function. | ||
| 523 | KEY is a key sequence; noninteractively, it is a string or vector | ||
| 524 | of characters or event types, and non-ASCII characters with codes | ||
| 525 | above 127 (such as ISO Latin-1) can be included if you use a vector. | ||
| 526 | |||
| 527 | Note that if KEY has a local binding in the current buffer, | ||
| 528 | that local binding will continue to shadow any global binding | ||
| 529 | that you make with this function." | ||
| 530 | (interactive "KSet key globally: \nCSet key %s to command: ") | ||
| 531 | (or (vectorp key) (stringp key) | ||
| 532 | (signal 'wrong-type-argument (list 'arrayp key))) | ||
| 533 | (define-key (current-global-map) key command)) | ||
| 534 | |||
| 535 | (defun local-set-key (key command) | ||
| 536 | "Give KEY a local binding as COMMAND. | ||
| 537 | COMMAND is the command definition to use; usually it is | ||
| 538 | a symbol naming an interactively-callable function. | ||
| 539 | KEY is a key sequence; noninteractively, it is a string or vector | ||
| 540 | of characters or event types, and non-ASCII characters with codes | ||
| 541 | above 127 (such as ISO Latin-1) can be included if you use a vector. | ||
| 542 | |||
| 543 | The binding goes in the current buffer's local map, | ||
| 544 | which in most cases is shared with all other buffers in the same major mode." | ||
| 545 | (interactive "KSet key locally: \nCSet key %s locally to command: ") | ||
| 546 | (let ((map (current-local-map))) | ||
| 547 | (or map | ||
| 548 | (use-local-map (setq map (make-sparse-keymap)))) | ||
| 549 | (or (vectorp key) (stringp key) | ||
| 550 | (signal 'wrong-type-argument (list 'arrayp key))) | ||
| 551 | (define-key map key command))) | ||
| 552 | |||
| 553 | (defun global-unset-key (key) | ||
| 554 | "Remove global binding of KEY. | ||
| 555 | KEY is a string or vector representing a sequence of keystrokes." | ||
| 556 | (interactive "kUnset key globally: ") | ||
| 557 | (global-set-key key nil)) | ||
| 558 | |||
| 559 | (defun local-unset-key (key) | ||
| 560 | "Remove local binding of KEY. | ||
| 561 | KEY is a string or vector representing a sequence of keystrokes." | ||
| 562 | (interactive "kUnset key locally: ") | ||
| 563 | (if (current-local-map) | ||
| 564 | (local-set-key key nil)) | ||
| 565 | nil) | ||
| 566 | |||
| 567 | ;;;; substitute-key-definition and its subroutines. | ||
| 568 | |||
| 569 | (defvar key-substitution-in-progress nil | ||
| 570 | "Used internally by `substitute-key-definition'.") | ||
| 571 | |||
| 572 | (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) | ||
| 573 | "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. | ||
| 574 | In other words, OLDDEF is replaced with NEWDEF where ever it appears. | ||
| 575 | Alternatively, if optional fourth argument OLDMAP is specified, we redefine | ||
| 576 | in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP. | ||
| 577 | |||
| 578 | For most uses, it is simpler and safer to use command remappping like this: | ||
| 579 | \(define-key KEYMAP [remap OLDDEF] NEWDEF)" | ||
| 580 | ;; Don't document PREFIX in the doc string because we don't want to | ||
| 581 | ;; advertise it. It's meant for recursive calls only. Here's its | ||
| 582 | ;; meaning | ||
| 583 | |||
| 584 | ;; If optional argument PREFIX is specified, it should be a key | ||
| 585 | ;; prefix, a string. Redefined bindings will then be bound to the | ||
| 586 | ;; original key, with PREFIX added at the front. | ||
| 587 | (or prefix (setq prefix "")) | ||
| 588 | (let* ((scan (or oldmap keymap)) | ||
| 589 | (prefix1 (vconcat prefix [nil])) | ||
| 590 | (key-substitution-in-progress | ||
| 591 | (cons scan key-substitution-in-progress))) | ||
| 592 | ;; Scan OLDMAP, finding each char or event-symbol that | ||
| 593 | ;; has any definition, and act on it with hack-key. | ||
| 594 | (map-keymap | ||
| 595 | (lambda (char defn) | ||
| 596 | (aset prefix1 (length prefix) char) | ||
| 597 | (substitute-key-definition-key defn olddef newdef prefix1 keymap)) | ||
| 598 | scan))) | ||
| 599 | |||
| 600 | (defun substitute-key-definition-key (defn olddef newdef prefix keymap) | ||
| 601 | (let (inner-def skipped menu-item) | ||
| 602 | ;; Find the actual command name within the binding. | ||
| 603 | (if (eq (car-safe defn) 'menu-item) | ||
| 604 | (setq menu-item defn defn (nth 2 defn)) | ||
| 605 | ;; Skip past menu-prompt. | ||
| 606 | (while (stringp (car-safe defn)) | ||
| 607 | (push (pop defn) skipped)) | ||
| 608 | ;; Skip past cached key-equivalence data for menu items. | ||
| 609 | (if (consp (car-safe defn)) | ||
| 610 | (setq defn (cdr defn)))) | ||
| 611 | (if (or (eq defn olddef) | ||
| 612 | ;; Compare with equal if definition is a key sequence. | ||
| 613 | ;; That is useful for operating on function-key-map. | ||
| 614 | (and (or (stringp defn) (vectorp defn)) | ||
| 615 | (equal defn olddef))) | ||
| 616 | (define-key keymap prefix | ||
| 617 | (if menu-item | ||
| 618 | (let ((copy (copy-sequence menu-item))) | ||
| 619 | (setcar (nthcdr 2 copy) newdef) | ||
| 620 | copy) | ||
| 621 | (nconc (nreverse skipped) newdef))) | ||
| 622 | ;; Look past a symbol that names a keymap. | ||
| 623 | (setq inner-def | ||
| 624 | (and defn | ||
| 625 | (condition-case nil (indirect-function defn) (error defn)))) | ||
| 626 | ;; For nested keymaps, we use `inner-def' rather than `defn' so as to | ||
| 627 | ;; avoid autoloading a keymap. This is mostly done to preserve the | ||
| 628 | ;; original non-autoloading behavior of pre-map-keymap times. | ||
| 629 | (if (and (keymapp inner-def) | ||
| 630 | ;; Avoid recursively scanning | ||
| 631 | ;; where KEYMAP does not have a submap. | ||
| 632 | (let ((elt (lookup-key keymap prefix))) | ||
| 633 | (or (null elt) (natnump elt) (keymapp elt))) | ||
| 634 | ;; Avoid recursively rescanning keymap being scanned. | ||
| 635 | (not (memq inner-def key-substitution-in-progress))) | ||
| 636 | ;; If this one isn't being scanned already, scan it now. | ||
| 637 | (substitute-key-definition olddef newdef keymap inner-def prefix))))) | ||
| 502 | 638 | ||
| 503 | 639 | ||
| 504 | ;;;; The global keymap tree. | 640 | ;;;; The global keymap tree. |
| @@ -642,6 +778,8 @@ The `posn-' functions access elements of such lists." | |||
| 642 | "Return the multi-click count of EVENT, a click or drag event. | 778 | "Return the multi-click count of EVENT, a click or drag event. |
| 643 | The return value is a positive integer." | 779 | The return value is a positive integer." |
| 644 | (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1)) | 780 | (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1)) |
| 781 | |||
| 782 | ;;;; Extracting fields of the positions in an event. | ||
| 645 | 783 | ||
| 646 | (defsubst posn-window (position) | 784 | (defsubst posn-window (position) |
| 647 | "Return the window in POSITION. | 785 | "Return the window in POSITION. |
| @@ -831,6 +969,8 @@ is converted into a string by expressing it in decimal." | |||
| 831 | (defalias 'point-at-eol 'line-end-position) | 969 | (defalias 'point-at-eol 'line-end-position) |
| 832 | (defalias 'point-at-bol 'line-beginning-position) | 970 | (defalias 'point-at-bol 'line-beginning-position) |
| 833 | 971 | ||
| 972 | (defalias 'user-original-login-name 'user-login-name) | ||
| 973 | |||
| 834 | 974 | ||
| 835 | ;;;; Hook manipulation functions. | 975 | ;;;; Hook manipulation functions. |
| 836 | 976 | ||
| @@ -991,7 +1131,143 @@ The return value is the new value of LIST-VAR." | |||
| 991 | (if (and oa ob) | 1131 | (if (and oa ob) |
| 992 | (< oa ob) | 1132 | (< oa ob) |
| 993 | oa))))))) | 1133 | oa))))))) |
| 1134 | |||
| 1135 | ;;;; Mode hooks. | ||
| 1136 | |||
| 1137 | (defvar delay-mode-hooks nil | ||
| 1138 | "If non-nil, `run-mode-hooks' should delay running the hooks.") | ||
| 1139 | (defvar delayed-mode-hooks nil | ||
| 1140 | "List of delayed mode hooks waiting to be run.") | ||
| 1141 | (make-variable-buffer-local 'delayed-mode-hooks) | ||
| 1142 | (put 'delay-mode-hooks 'permanent-local t) | ||
| 1143 | |||
| 1144 | (defvar after-change-major-mode-hook nil | ||
| 1145 | "Normal hook run at the very end of major mode functions.") | ||
| 1146 | |||
| 1147 | (defun run-mode-hooks (&rest hooks) | ||
| 1148 | "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS. | ||
| 1149 | Execution is delayed if `delay-mode-hooks' is non-nil. | ||
| 1150 | If `delay-mode-hooks' is nil, run `after-change-major-mode-hook' | ||
| 1151 | after running the mode hooks. | ||
| 1152 | Major mode functions should use this." | ||
| 1153 | (if delay-mode-hooks | ||
| 1154 | ;; Delaying case. | ||
| 1155 | (dolist (hook hooks) | ||
| 1156 | (push hook delayed-mode-hooks)) | ||
| 1157 | ;; Normal case, just run the hook as before plus any delayed hooks. | ||
| 1158 | (setq hooks (nconc (nreverse delayed-mode-hooks) hooks)) | ||
| 1159 | (setq delayed-mode-hooks nil) | ||
| 1160 | (apply 'run-hooks hooks) | ||
| 1161 | (run-hooks 'after-change-major-mode-hook))) | ||
| 1162 | |||
| 1163 | (defmacro delay-mode-hooks (&rest body) | ||
| 1164 | "Execute BODY, but delay any `run-mode-hooks'. | ||
| 1165 | These hooks will be executed by the first following call to | ||
| 1166 | `run-mode-hooks' that occurs outside any `delayed-mode-hooks' form. | ||
| 1167 | Only affects hooks run in the current buffer." | ||
| 1168 | (declare (debug t) (indent 0)) | ||
| 1169 | `(progn | ||
| 1170 | (make-local-variable 'delay-mode-hooks) | ||
| 1171 | (let ((delay-mode-hooks t)) | ||
| 1172 | ,@body))) | ||
| 1173 | |||
| 1174 | ;; PUBLIC: find if the current mode derives from another. | ||
| 994 | 1175 | ||
| 1176 | (defun derived-mode-p (&rest modes) | ||
| 1177 | "Non-nil if the current major mode is derived from one of MODES. | ||
| 1178 | Uses the `derived-mode-parent' property of the symbol to trace backwards." | ||
| 1179 | (let ((parent major-mode)) | ||
| 1180 | (while (and (not (memq parent modes)) | ||
| 1181 | (setq parent (get parent 'derived-mode-parent)))) | ||
| 1182 | parent)) | ||
| 1183 | |||
| 1184 | ;;;; Minor modes. | ||
| 1185 | |||
| 1186 | ;; If a minor mode is not defined with define-minor-mode, | ||
| 1187 | ;; add it here explicitly. | ||
| 1188 | ;; isearch-mode is deliberately excluded, since you should | ||
| 1189 | ;; not call it yourself. | ||
| 1190 | (defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode | ||
| 1191 | overwrite-mode view-mode | ||
| 1192 | hs-minor-mode) | ||
| 1193 | "List of all minor mode functions.") | ||
| 1194 | |||
| 1195 | (defun add-minor-mode (toggle name &optional keymap after toggle-fun) | ||
| 1196 | "Register a new minor mode. | ||
| 1197 | |||
| 1198 | This is an XEmacs-compatibility function. Use `define-minor-mode' instead. | ||
| 1199 | |||
| 1200 | TOGGLE is a symbol which is the name of a buffer-local variable that | ||
| 1201 | is toggled on or off to say whether the minor mode is active or not. | ||
| 1202 | |||
| 1203 | NAME specifies what will appear in the mode line when the minor mode | ||
| 1204 | is active. NAME should be either a string starting with a space, or a | ||
| 1205 | symbol whose value is such a string. | ||
| 1206 | |||
| 1207 | Optional KEYMAP is the keymap for the minor mode that will be added | ||
| 1208 | to `minor-mode-map-alist'. | ||
| 1209 | |||
| 1210 | Optional AFTER specifies that TOGGLE should be added after AFTER | ||
| 1211 | in `minor-mode-alist'. | ||
| 1212 | |||
| 1213 | Optional TOGGLE-FUN is an interactive function to toggle the mode. | ||
| 1214 | It defaults to (and should by convention be) TOGGLE. | ||
| 1215 | |||
| 1216 | If TOGGLE has a non-nil `:included' property, an entry for the mode is | ||
| 1217 | included in the mode-line minor mode menu. | ||
| 1218 | If TOGGLE has a `:menu-tag', that is used for the menu item's label." | ||
| 1219 | (unless (memq toggle minor-mode-list) | ||
| 1220 | (push toggle minor-mode-list)) | ||
| 1221 | |||
| 1222 | (unless toggle-fun (setq toggle-fun toggle)) | ||
| 1223 | (unless (eq toggle-fun toggle) | ||
| 1224 | (put toggle :minor-mode-function toggle-fun)) | ||
| 1225 | ;; Add the name to the minor-mode-alist. | ||
| 1226 | (when name | ||
| 1227 | (let ((existing (assq toggle minor-mode-alist))) | ||
| 1228 | (if existing | ||
| 1229 | (setcdr existing (list name)) | ||
| 1230 | (let ((tail minor-mode-alist) found) | ||
| 1231 | (while (and tail (not found)) | ||
| 1232 | (if (eq after (caar tail)) | ||
| 1233 | (setq found tail) | ||
| 1234 | (setq tail (cdr tail)))) | ||
| 1235 | (if found | ||
| 1236 | (let ((rest (cdr found))) | ||
| 1237 | (setcdr found nil) | ||
| 1238 | (nconc found (list (list toggle name)) rest)) | ||
| 1239 | (setq minor-mode-alist (cons (list toggle name) | ||
| 1240 | minor-mode-alist))))))) | ||
| 1241 | ;; Add the toggle to the minor-modes menu if requested. | ||
| 1242 | (when (get toggle :included) | ||
| 1243 | (define-key mode-line-mode-menu | ||
| 1244 | (vector toggle) | ||
| 1245 | (list 'menu-item | ||
| 1246 | (concat | ||
| 1247 | (or (get toggle :menu-tag) | ||
| 1248 | (if (stringp name) name (symbol-name toggle))) | ||
| 1249 | (let ((mode-name (if (symbolp name) (symbol-value name)))) | ||
| 1250 | (if (and (stringp mode-name) (string-match "[^ ]+" mode-name)) | ||
| 1251 | (concat " (" (match-string 0 mode-name) ")")))) | ||
| 1252 | toggle-fun | ||
| 1253 | :button (cons :toggle toggle)))) | ||
| 1254 | |||
| 1255 | ;; Add the map to the minor-mode-map-alist. | ||
| 1256 | (when keymap | ||
| 1257 | (let ((existing (assq toggle minor-mode-map-alist))) | ||
| 1258 | (if existing | ||
| 1259 | (setcdr existing keymap) | ||
| 1260 | (let ((tail minor-mode-map-alist) found) | ||
| 1261 | (while (and tail (not found)) | ||
| 1262 | (if (eq after (caar tail)) | ||
| 1263 | (setq found tail) | ||
| 1264 | (setq tail (cdr tail)))) | ||
| 1265 | (if found | ||
| 1266 | (let ((rest (cdr found))) | ||
| 1267 | (setcdr found nil) | ||
| 1268 | (nconc found (list (cons toggle keymap)) rest)) | ||
| 1269 | (setq minor-mode-map-alist (cons (cons toggle keymap) | ||
| 1270 | minor-mode-map-alist)))))))) | ||
| 995 | 1271 | ||
| 996 | ;;; Load history | 1272 | ;;; Load history |
| 997 | 1273 | ||
| @@ -1080,7 +1356,9 @@ This makes or adds to an entry on `after-load-alist'. | |||
| 1080 | FILE should be the name of a library, with no directory name." | 1356 | FILE should be the name of a library, with no directory name." |
| 1081 | (eval-after-load file (read))) | 1357 | (eval-after-load file (read))) |
| 1082 | 1358 | ||
| 1083 | ;;; open-network-stream is a wrapper around make-network-process. | 1359 | ;;;; Process stuff. |
| 1360 | |||
| 1361 | ;; open-network-stream is a wrapper around make-network-process. | ||
| 1084 | 1362 | ||
| 1085 | (when (featurep 'make-network-process) | 1363 | (when (featurep 'make-network-process) |
| 1086 | (defun open-network-stream (name buffer host service) | 1364 | (defun open-network-stream (name buffer host service) |
| @@ -1380,6 +1658,8 @@ This finishes the change group by reverting all of its changes." | |||
| 1380 | ;; Revert the undo info to what it was when we grabbed the state. | 1658 | ;; Revert the undo info to what it was when we grabbed the state. |
| 1381 | (setq buffer-undo-list elt))))) | 1659 | (setq buffer-undo-list elt))))) |
| 1382 | 1660 | ||
| 1661 | ;;;; Display-related functions. | ||
| 1662 | |||
| 1383 | ;; For compatibility. | 1663 | ;; For compatibility. |
| 1384 | (defalias 'redraw-modeline 'force-mode-line-update) | 1664 | (defalias 'redraw-modeline 'force-mode-line-update) |
| 1385 | 1665 | ||
| @@ -1517,34 +1797,122 @@ mode.") | |||
| 1517 | This variable is meaningful on MS-DOG and Windows NT. | 1797 | This variable is meaningful on MS-DOG and Windows NT. |
| 1518 | On those systems, it is automatically local in every buffer. | 1798 | On those systems, it is automatically local in every buffer. |
| 1519 | On other systems, this variable is normally always nil.") | 1799 | On other systems, this variable is normally always nil.") |
| 1800 | |||
| 1801 | ;;;; Misc. useful functions. | ||
| 1520 | 1802 | ||
| 1521 | ;; This should probably be written in C (i.e., without using `walk-windows'). | 1803 | (defun find-tag-default () |
| 1522 | (defun get-buffer-window-list (buffer &optional minibuf frame) | 1804 | "Determine default tag to search for, based on text at point. |
| 1523 | "Return list of all windows displaying BUFFER, or nil if none. | 1805 | If there is no plausible default, return nil." |
| 1524 | BUFFER can be a buffer or a buffer name. | 1806 | (save-excursion |
| 1525 | See `walk-windows' for the meaning of MINIBUF and FRAME." | 1807 | (while (looking-at "\\sw\\|\\s_") |
| 1526 | (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows) | 1808 | (forward-char 1)) |
| 1527 | (walk-windows (function (lambda (window) | 1809 | (if (or (re-search-backward "\\sw\\|\\s_" |
| 1528 | (if (eq (window-buffer window) buffer) | 1810 | (save-excursion (beginning-of-line) (point)) |
| 1529 | (setq windows (cons window windows))))) | 1811 | t) |
| 1530 | minibuf frame) | 1812 | (re-search-forward "\\(\\sw\\|\\s_\\)+" |
| 1531 | windows)) | 1813 | (save-excursion (end-of-line) (point)) |
| 1814 | t)) | ||
| 1815 | (progn | ||
| 1816 | (goto-char (match-end 0)) | ||
| 1817 | (condition-case nil | ||
| 1818 | (buffer-substring-no-properties | ||
| 1819 | (point) | ||
| 1820 | (progn (forward-sexp -1) | ||
| 1821 | (while (looking-at "\\s'") | ||
| 1822 | (forward-char 1)) | ||
| 1823 | (point))) | ||
| 1824 | (error nil))) | ||
| 1825 | nil))) | ||
| 1532 | 1826 | ||
| 1533 | (defun ignore (&rest ignore) | 1827 | (defun play-sound (sound) |
| 1534 | "Do nothing and return nil. | 1828 | "SOUND is a list of the form `(sound KEYWORD VALUE...)'. |
| 1535 | This function accepts any number of arguments, but ignores them." | 1829 | The following keywords are recognized: |
| 1536 | (interactive) | ||
| 1537 | nil) | ||
| 1538 | 1830 | ||
| 1539 | (defun error (&rest args) | 1831 | :file FILE - read sound data from FILE. If FILE isn't an |
| 1540 | "Signal an error, making error message by passing all args to `format'. | 1832 | absolute file name, it is searched in `data-directory'. |
| 1541 | In Emacs, the convention is that error messages start with a capital | ||
| 1542 | letter but *do not* end with a period. Please follow this convention | ||
| 1543 | for the sake of consistency." | ||
| 1544 | (while t | ||
| 1545 | (signal 'error (list (apply 'format args))))) | ||
| 1546 | 1833 | ||
| 1547 | (defalias 'user-original-login-name 'user-login-name) | 1834 | :data DATA - read sound data from string DATA. |
| 1835 | |||
| 1836 | Exactly one of :file or :data must be present. | ||
| 1837 | |||
| 1838 | :volume VOL - set volume to VOL. VOL must an integer in the | ||
| 1839 | range 0..100 or a float in the range 0..1.0. If not specified, | ||
| 1840 | don't change the volume setting of the sound device. | ||
| 1841 | |||
| 1842 | :device DEVICE - play sound on DEVICE. If not specified, | ||
| 1843 | a system-dependent default device name is used." | ||
| 1844 | (if (fboundp 'play-sound-internal) | ||
| 1845 | (play-sound-internal sound) | ||
| 1846 | (error "This Emacs binary lacks sound support"))) | ||
| 1847 | |||
| 1848 | (defun make-temp-file (prefix &optional dir-flag suffix) | ||
| 1849 | "Create a temporary file. | ||
| 1850 | The returned file name (created by appending some random characters at the end | ||
| 1851 | of PREFIX, and expanding against `temporary-file-directory' if necessary), | ||
| 1852 | is guaranteed to point to a newly created empty file. | ||
| 1853 | You can then use `write-region' to write new data into the file. | ||
| 1854 | |||
| 1855 | If DIR-FLAG is non-nil, create a new empty directory instead of a file. | ||
| 1856 | |||
| 1857 | If SUFFIX is non-nil, add that at the end of the file name." | ||
| 1858 | (let ((umask (default-file-modes)) | ||
| 1859 | file) | ||
| 1860 | (unwind-protect | ||
| 1861 | (progn | ||
| 1862 | ;; Create temp files with strict access rights. It's easy to | ||
| 1863 | ;; loosen them later, whereas it's impossible to close the | ||
| 1864 | ;; time-window of loose permissions otherwise. | ||
| 1865 | (set-default-file-modes ?\700) | ||
| 1866 | (while (condition-case () | ||
| 1867 | (progn | ||
| 1868 | (setq file | ||
| 1869 | (make-temp-name | ||
| 1870 | (expand-file-name prefix temporary-file-directory))) | ||
| 1871 | (if suffix | ||
| 1872 | (setq file (concat file suffix))) | ||
| 1873 | (if dir-flag | ||
| 1874 | (make-directory file) | ||
| 1875 | (write-region "" nil file nil 'silent nil 'excl)) | ||
| 1876 | nil) | ||
| 1877 | (file-already-exists t)) | ||
| 1878 | ;; the file was somehow created by someone else between | ||
| 1879 | ;; `make-temp-name' and `write-region', let's try again. | ||
| 1880 | nil) | ||
| 1881 | file) | ||
| 1882 | ;; Reset the umask. | ||
| 1883 | (set-default-file-modes umask)))) | ||
| 1884 | |||
| 1885 | (defun shell-quote-argument (argument) | ||
| 1886 | "Quote an argument for passing as argument to an inferior shell." | ||
| 1887 | (if (eq system-type 'ms-dos) | ||
| 1888 | ;; Quote using double quotes, but escape any existing quotes in | ||
| 1889 | ;; the argument with backslashes. | ||
| 1890 | (let ((result "") | ||
| 1891 | (start 0) | ||
| 1892 | end) | ||
| 1893 | (if (or (null (string-match "[^\"]" argument)) | ||
| 1894 | (< (match-end 0) (length argument))) | ||
| 1895 | (while (string-match "[\"]" argument start) | ||
| 1896 | (setq end (match-beginning 0) | ||
| 1897 | result (concat result (substring argument start end) | ||
| 1898 | "\\" (substring argument end (1+ end))) | ||
| 1899 | start (1+ end)))) | ||
| 1900 | (concat "\"" result (substring argument start) "\"")) | ||
| 1901 | (if (eq system-type 'windows-nt) | ||
| 1902 | (concat "\"" argument "\"") | ||
| 1903 | (if (equal argument "") | ||
| 1904 | "''" | ||
| 1905 | ;; Quote everything except POSIX filename characters. | ||
| 1906 | ;; This should be safe enough even for really weird shells. | ||
| 1907 | (let ((result "") (start 0) end) | ||
| 1908 | (while (string-match "[^-0-9a-zA-Z_./]" argument start) | ||
| 1909 | (setq end (match-beginning 0) | ||
| 1910 | result (concat result (substring argument start end) | ||
| 1911 | "\\" (substring argument end (1+ end))) | ||
| 1912 | start (1+ end))) | ||
| 1913 | (concat result (substring argument start))))))) | ||
| 1914 | |||
| 1915 | ;;;; Support for yanking and text properties. | ||
| 1548 | 1916 | ||
| 1549 | (defvar yank-excluded-properties) | 1917 | (defvar yank-excluded-properties) |
| 1550 | 1918 | ||
| @@ -1650,7 +2018,7 @@ Strip text properties from the inserted text according to | |||
| 1650 | (remove-yank-excluded-properties opoint (point)))) | 2018 | (remove-yank-excluded-properties opoint (point)))) |
| 1651 | 2019 | ||
| 1652 | 2020 | ||
| 1653 | ;; Synchronous shell commands. | 2021 | ;;;; Synchronous shell commands. |
| 1654 | 2022 | ||
| 1655 | (defun start-process-shell-command (name buffer &rest args) | 2023 | (defun start-process-shell-command (name buffer &rest args) |
| 1656 | "Start a program in a subprocess. Return the process object for it. | 2024 | "Start a program in a subprocess. Return the process object for it. |
| @@ -1706,6 +2074,8 @@ If you quit, the process is killed with SIGINT, or SIGKILL if you quit again." | |||
| 1706 | shell-command-switch | 2074 | shell-command-switch |
| 1707 | (mapconcat 'identity (cons command args) " "))))) | 2075 | (mapconcat 'identity (cons command args) " "))))) |
| 1708 | 2076 | ||
| 2077 | ;;;; Lisp macros to do various things temporarily. | ||
| 2078 | |||
| 1709 | (defmacro with-current-buffer (buffer &rest body) | 2079 | (defmacro with-current-buffer (buffer &rest body) |
| 1710 | "Execute the forms in BODY with BUFFER as the current buffer. | 2080 | "Execute the forms in BODY with BUFFER as the current buffer. |
| 1711 | The value returned is the value of the last form in BODY. | 2081 | The value returned is the value of the last form in BODY. |
| @@ -1858,96 +2228,8 @@ in BODY." | |||
| 1858 | (let ((combine-after-change-calls t)) | 2228 | (let ((combine-after-change-calls t)) |
| 1859 | . ,body) | 2229 | . ,body) |
| 1860 | (combine-after-change-execute))) | 2230 | (combine-after-change-execute))) |
| 1861 | 2231 | ||
| 1862 | 2232 | ;;;; Constructing completion tables. | |
| 1863 | (defvar delay-mode-hooks nil | ||
| 1864 | "If non-nil, `run-mode-hooks' should delay running the hooks.") | ||
| 1865 | (defvar delayed-mode-hooks nil | ||
| 1866 | "List of delayed mode hooks waiting to be run.") | ||
| 1867 | (make-variable-buffer-local 'delayed-mode-hooks) | ||
| 1868 | (put 'delay-mode-hooks 'permanent-local t) | ||
| 1869 | |||
| 1870 | (defvar after-change-major-mode-hook nil | ||
| 1871 | "Normal hook run at the very end of major mode functions.") | ||
| 1872 | |||
| 1873 | (defun run-mode-hooks (&rest hooks) | ||
| 1874 | "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS. | ||
| 1875 | Execution is delayed if `delay-mode-hooks' is non-nil. | ||
| 1876 | If `delay-mode-hooks' is nil, run `after-change-major-mode-hook' | ||
| 1877 | after running the mode hooks. | ||
| 1878 | Major mode functions should use this." | ||
| 1879 | (if delay-mode-hooks | ||
| 1880 | ;; Delaying case. | ||
| 1881 | (dolist (hook hooks) | ||
| 1882 | (push hook delayed-mode-hooks)) | ||
| 1883 | ;; Normal case, just run the hook as before plus any delayed hooks. | ||
| 1884 | (setq hooks (nconc (nreverse delayed-mode-hooks) hooks)) | ||
| 1885 | (setq delayed-mode-hooks nil) | ||
| 1886 | (apply 'run-hooks hooks) | ||
| 1887 | (run-hooks 'after-change-major-mode-hook))) | ||
| 1888 | |||
| 1889 | (defmacro delay-mode-hooks (&rest body) | ||
| 1890 | "Execute BODY, but delay any `run-mode-hooks'. | ||
| 1891 | These hooks will be executed by the first following call to | ||
| 1892 | `run-mode-hooks' that occurs outside any `delayed-mode-hooks' form. | ||
| 1893 | Only affects hooks run in the current buffer." | ||
| 1894 | (declare (debug t) (indent 0)) | ||
| 1895 | `(progn | ||
| 1896 | (make-local-variable 'delay-mode-hooks) | ||
| 1897 | (let ((delay-mode-hooks t)) | ||
| 1898 | ,@body))) | ||
| 1899 | |||
| 1900 | ;; PUBLIC: find if the current mode derives from another. | ||
| 1901 | |||
| 1902 | (defun derived-mode-p (&rest modes) | ||
| 1903 | "Non-nil if the current major mode is derived from one of MODES. | ||
| 1904 | Uses the `derived-mode-parent' property of the symbol to trace backwards." | ||
| 1905 | (let ((parent major-mode)) | ||
| 1906 | (while (and (not (memq parent modes)) | ||
| 1907 | (setq parent (get parent 'derived-mode-parent)))) | ||
| 1908 | parent)) | ||
| 1909 | |||
| 1910 | (defun find-tag-default () | ||
| 1911 | "Determine default tag to search for, based on text at point. | ||
| 1912 | If there is no plausible default, return nil." | ||
| 1913 | (save-excursion | ||
| 1914 | (while (looking-at "\\sw\\|\\s_") | ||
| 1915 | (forward-char 1)) | ||
| 1916 | (if (or (re-search-backward "\\sw\\|\\s_" | ||
| 1917 | (save-excursion (beginning-of-line) (point)) | ||
| 1918 | t) | ||
| 1919 | (re-search-forward "\\(\\sw\\|\\s_\\)+" | ||
| 1920 | (save-excursion (end-of-line) (point)) | ||
| 1921 | t)) | ||
| 1922 | (progn | ||
| 1923 | (goto-char (match-end 0)) | ||
| 1924 | (condition-case nil | ||
| 1925 | (buffer-substring-no-properties | ||
| 1926 | (point) | ||
| 1927 | (progn (forward-sexp -1) | ||
| 1928 | (while (looking-at "\\s'") | ||
| 1929 | (forward-char 1)) | ||
| 1930 | (point))) | ||
| 1931 | (error nil))) | ||
| 1932 | nil))) | ||
| 1933 | |||
| 1934 | (defmacro with-syntax-table (table &rest body) | ||
| 1935 | "Evaluate BODY with syntax table of current buffer set to TABLE. | ||
| 1936 | The syntax table of the current buffer is saved, BODY is evaluated, and the | ||
| 1937 | saved table is restored, even in case of an abnormal exit. | ||
| 1938 | Value is what BODY returns." | ||
| 1939 | (declare (debug t)) | ||
| 1940 | (let ((old-table (make-symbol "table")) | ||
| 1941 | (old-buffer (make-symbol "buffer"))) | ||
| 1942 | `(let ((,old-table (syntax-table)) | ||
| 1943 | (,old-buffer (current-buffer))) | ||
| 1944 | (unwind-protect | ||
| 1945 | (progn | ||
| 1946 | (set-syntax-table ,table) | ||
| 1947 | ,@body) | ||
| 1948 | (save-current-buffer | ||
| 1949 | (set-buffer ,old-buffer) | ||
| 1950 | (set-syntax-table ,old-table)))))) | ||
| 1951 | 2233 | ||
| 1952 | (defmacro dynamic-completion-table (fun) | 2234 | (defmacro dynamic-completion-table (fun) |
| 1953 | "Use function FUN as a dynamic completion table. | 2235 | "Use function FUN as a dynamic completion table. |
| @@ -2007,7 +2289,7 @@ A and B should not be costly (or side-effecting) expressions." | |||
| 2007 | (or (test-completion string ,a predicate) | 2289 | (or (test-completion string ,a predicate) |
| 2008 | (test-completion string ,b predicate)))))) | 2290 | (test-completion string ,b predicate)))))) |
| 2009 | 2291 | ||
| 2010 | ;;; Matching and substitution | 2292 | ;;; Matching and match data. |
| 2011 | 2293 | ||
| 2012 | (defvar save-match-data-internal) | 2294 | (defvar save-match-data-internal) |
| 2013 | 2295 | ||
| @@ -2082,6 +2364,47 @@ of a match for REGEXP." | |||
| 2082 | (looking-at (concat "\\(?:" regexp "\\)\\'"))))) | 2364 | (looking-at (concat "\\(?:" regexp "\\)\\'"))))) |
| 2083 | (not (null pos)))) | 2365 | (not (null pos)))) |
| 2084 | 2366 | ||
| 2367 | (defun subregexp-context-p (regexp pos &optional start) | ||
| 2368 | "Return non-nil if POS is in a normal subregexp context in REGEXP. | ||
| 2369 | A subregexp context is one where a sub-regexp can appear. | ||
| 2370 | A non-subregexp context is for example within brackets, or within a | ||
| 2371 | repetition bounds operator `\\=\\{...\\}', or right after a `\\'. | ||
| 2372 | If START is non-nil, it should be a position in REGEXP, smaller | ||
| 2373 | than POS, and known to be in a subregexp context." | ||
| 2374 | ;; Here's one possible implementation, with the great benefit that it | ||
| 2375 | ;; reuses the regexp-matcher's own parser, so it understands all the | ||
| 2376 | ;; details of the syntax. A disadvantage is that it needs to match the | ||
| 2377 | ;; error string. | ||
| 2378 | (condition-case err | ||
| 2379 | (progn | ||
| 2380 | (string-match (substring regexp (or start 0) pos) "") | ||
| 2381 | t) | ||
| 2382 | (invalid-regexp | ||
| 2383 | (not (member (cadr err) '("Unmatched [ or [^" | ||
| 2384 | "Unmatched \\{" | ||
| 2385 | "Trailing backslash"))))) | ||
| 2386 | ;; An alternative implementation: | ||
| 2387 | ;; (defconst re-context-re | ||
| 2388 | ;; (let* ((harmless-ch "[^\\[]") | ||
| 2389 | ;; (harmless-esc "\\\\[^{]") | ||
| 2390 | ;; (class-harmless-ch "[^][]") | ||
| 2391 | ;; (class-lb-harmless "[^]:]") | ||
| 2392 | ;; (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?") | ||
| 2393 | ;; (class-lb (concat "\\[\\(" class-lb-harmless | ||
| 2394 | ;; "\\|" class-lb-colon-maybe-charclass "\\)")) | ||
| 2395 | ;; (class | ||
| 2396 | ;; (concat "\\[^?]?" | ||
| 2397 | ;; "\\(" class-harmless-ch | ||
| 2398 | ;; "\\|" class-lb "\\)*" | ||
| 2399 | ;; "\\[?]")) ; special handling for bare [ at end of re | ||
| 2400 | ;; (braces "\\\\{[0-9,]+\\\\}")) | ||
| 2401 | ;; (concat "\\`\\(" harmless-ch "\\|" harmless-esc | ||
| 2402 | ;; "\\|" class "\\|" braces "\\)*\\'")) | ||
| 2403 | ;; "Matches any prefix that corresponds to a normal subregexp context.") | ||
| 2404 | ;; (string-match re-context-re (substring regexp (or start 0) pos)) | ||
| 2405 | ) | ||
| 2406 | |||
| 2407 | ;;;; split-string | ||
| 2085 | 2408 | ||
| 2086 | (defconst split-string-default-separators "[ \f\t\n\r\v]+" | 2409 | (defconst split-string-default-separators "[ \f\t\n\r\v]+" |
| 2087 | "The default value of separators for `split-string'. | 2410 | "The default value of separators for `split-string'. |
| @@ -2142,6 +2465,8 @@ Modifies the match data; use `save-match-data' if necessary." | |||
| 2142 | (cons (substring string start) | 2465 | (cons (substring string start) |
| 2143 | list))) | 2466 | list))) |
| 2144 | (nreverse list))) | 2467 | (nreverse list))) |
| 2468 | |||
| 2469 | ;;;; Replacement in strings. | ||
| 2145 | 2470 | ||
| 2146 | (defun subst-char-in-string (fromchar tochar string &optional inplace) | 2471 | (defun subst-char-in-string (fromchar tochar string &optional inplace) |
| 2147 | "Replace FROMCHAR with TOCHAR in STRING each time it occurs. | 2472 | "Replace FROMCHAR with TOCHAR in STRING each time it occurs. |
| @@ -2211,76 +2536,42 @@ and replace a sub-expression, e.g. | |||
| 2211 | ;; Reconstruct a string from the pieces. | 2536 | ;; Reconstruct a string from the pieces. |
| 2212 | (setq matches (cons (substring string start l) matches)) ; leftover | 2537 | (setq matches (cons (substring string start l) matches)) ; leftover |
| 2213 | (apply #'concat (nreverse matches))))) | 2538 | (apply #'concat (nreverse matches))))) |
| 2539 | |||
| 2540 | ;;;; invisibility specs | ||
| 2214 | 2541 | ||
| 2215 | (defun subregexp-context-p (regexp pos &optional start) | 2542 | (defun add-to-invisibility-spec (element) |
| 2216 | "Return non-nil if POS is in a normal subregexp context in REGEXP. | 2543 | "Add ELEMENT to `buffer-invisibility-spec'. |
| 2217 | A subregexp context is one where a sub-regexp can appear. | 2544 | See documentation for `buffer-invisibility-spec' for the kind of elements |
| 2218 | A non-subregexp context is for example within brackets, or within a | 2545 | that can be added." |
| 2219 | repetition bounds operator `\\=\\{...\\}', or right after a `\\'. | 2546 | (if (eq buffer-invisibility-spec t) |
| 2220 | If START is non-nil, it should be a position in REGEXP, smaller | 2547 | (setq buffer-invisibility-spec (list t))) |
| 2221 | than POS, and known to be in a subregexp context." | 2548 | (setq buffer-invisibility-spec |
| 2222 | ;; Here's one possible implementation, with the great benefit that it | 2549 | (cons element buffer-invisibility-spec))) |
| 2223 | ;; reuses the regexp-matcher's own parser, so it understands all the | 2550 | |
| 2224 | ;; details of the syntax. A disadvantage is that it needs to match the | 2551 | (defun remove-from-invisibility-spec (element) |
| 2225 | ;; error string. | 2552 | "Remove ELEMENT from `buffer-invisibility-spec'." |
| 2226 | (condition-case err | 2553 | (if (consp buffer-invisibility-spec) |
| 2227 | (progn | 2554 | (setq buffer-invisibility-spec (delete element buffer-invisibility-spec)))) |
| 2228 | (string-match (substring regexp (or start 0) pos) "") | ||
| 2229 | t) | ||
| 2230 | (invalid-regexp | ||
| 2231 | (not (member (cadr err) '("Unmatched [ or [^" | ||
| 2232 | "Unmatched \\{" | ||
| 2233 | "Trailing backslash"))))) | ||
| 2234 | ;; An alternative implementation: | ||
| 2235 | ;; (defconst re-context-re | ||
| 2236 | ;; (let* ((harmless-ch "[^\\[]") | ||
| 2237 | ;; (harmless-esc "\\\\[^{]") | ||
| 2238 | ;; (class-harmless-ch "[^][]") | ||
| 2239 | ;; (class-lb-harmless "[^]:]") | ||
| 2240 | ;; (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?") | ||
| 2241 | ;; (class-lb (concat "\\[\\(" class-lb-harmless | ||
| 2242 | ;; "\\|" class-lb-colon-maybe-charclass "\\)")) | ||
| 2243 | ;; (class | ||
| 2244 | ;; (concat "\\[^?]?" | ||
| 2245 | ;; "\\(" class-harmless-ch | ||
| 2246 | ;; "\\|" class-lb "\\)*" | ||
| 2247 | ;; "\\[?]")) ; special handling for bare [ at end of re | ||
| 2248 | ;; (braces "\\\\{[0-9,]+\\\\}")) | ||
| 2249 | ;; (concat "\\`\\(" harmless-ch "\\|" harmless-esc | ||
| 2250 | ;; "\\|" class "\\|" braces "\\)*\\'")) | ||
| 2251 | ;; "Matches any prefix that corresponds to a normal subregexp context.") | ||
| 2252 | ;; (string-match re-context-re (substring regexp (or start 0) pos)) | ||
| 2253 | ) | ||
| 2254 | 2555 | ||
| 2255 | (defun shell-quote-argument (argument) | 2556 | ;;;; Syntax tables. |
| 2256 | "Quote an argument for passing as argument to an inferior shell." | 2557 | |
| 2257 | (if (eq system-type 'ms-dos) | 2558 | (defmacro with-syntax-table (table &rest body) |
| 2258 | ;; Quote using double quotes, but escape any existing quotes in | 2559 | "Evaluate BODY with syntax table of current buffer set to TABLE. |
| 2259 | ;; the argument with backslashes. | 2560 | The syntax table of the current buffer is saved, BODY is evaluated, and the |
| 2260 | (let ((result "") | 2561 | saved table is restored, even in case of an abnormal exit. |
| 2261 | (start 0) | 2562 | Value is what BODY returns." |
| 2262 | end) | 2563 | (declare (debug t)) |
| 2263 | (if (or (null (string-match "[^\"]" argument)) | 2564 | (let ((old-table (make-symbol "table")) |
| 2264 | (< (match-end 0) (length argument))) | 2565 | (old-buffer (make-symbol "buffer"))) |
| 2265 | (while (string-match "[\"]" argument start) | 2566 | `(let ((,old-table (syntax-table)) |
| 2266 | (setq end (match-beginning 0) | 2567 | (,old-buffer (current-buffer))) |
| 2267 | result (concat result (substring argument start end) | 2568 | (unwind-protect |
| 2268 | "\\" (substring argument end (1+ end))) | 2569 | (progn |
| 2269 | start (1+ end)))) | 2570 | (set-syntax-table ,table) |
| 2270 | (concat "\"" result (substring argument start) "\"")) | 2571 | ,@body) |
| 2271 | (if (eq system-type 'windows-nt) | 2572 | (save-current-buffer |
| 2272 | (concat "\"" argument "\"") | 2573 | (set-buffer ,old-buffer) |
| 2273 | (if (equal argument "") | 2574 | (set-syntax-table ,old-table)))))) |
| 2274 | "''" | ||
| 2275 | ;; Quote everything except POSIX filename characters. | ||
| 2276 | ;; This should be safe enough even for really weird shells. | ||
| 2277 | (let ((result "") (start 0) end) | ||
| 2278 | (while (string-match "[^-0-9a-zA-Z_./]" argument start) | ||
| 2279 | (setq end (match-beginning 0) | ||
| 2280 | result (concat result (substring argument start end) | ||
| 2281 | "\\" (substring argument end (1+ end))) | ||
| 2282 | start (1+ end))) | ||
| 2283 | (concat result (substring argument start))))))) | ||
| 2284 | 2575 | ||
| 2285 | (defun make-syntax-table (&optional oldtable) | 2576 | (defun make-syntax-table (&optional oldtable) |
| 2286 | "Return a new syntax table. | 2577 | "Return a new syntax table. |
| @@ -2303,247 +2594,8 @@ If POS is outside the buffer's accessible portion, return nil." | |||
| 2303 | "Return the syntax class part of the syntax descriptor SYNTAX. | 2594 | "Return the syntax class part of the syntax descriptor SYNTAX. |
| 2304 | If SYNTAX is nil, return nil." | 2595 | If SYNTAX is nil, return nil." |
| 2305 | (and syntax (logand (car syntax) 65535))) | 2596 | (and syntax (logand (car syntax) 65535))) |
| 2306 | |||
| 2307 | (defun add-to-invisibility-spec (element) | ||
| 2308 | "Add ELEMENT to `buffer-invisibility-spec'. | ||
| 2309 | See documentation for `buffer-invisibility-spec' for the kind of elements | ||
| 2310 | that can be added." | ||
| 2311 | (if (eq buffer-invisibility-spec t) | ||
| 2312 | (setq buffer-invisibility-spec (list t))) | ||
| 2313 | (setq buffer-invisibility-spec | ||
| 2314 | (cons element buffer-invisibility-spec))) | ||
| 2315 | |||
| 2316 | (defun remove-from-invisibility-spec (element) | ||
| 2317 | "Remove ELEMENT from `buffer-invisibility-spec'." | ||
| 2318 | (if (consp buffer-invisibility-spec) | ||
| 2319 | (setq buffer-invisibility-spec (delete element buffer-invisibility-spec)))) | ||
| 2320 | |||
| 2321 | (defun global-set-key (key command) | ||
| 2322 | "Give KEY a global binding as COMMAND. | ||
| 2323 | COMMAND is the command definition to use; usually it is | ||
| 2324 | a symbol naming an interactively-callable function. | ||
| 2325 | KEY is a key sequence; noninteractively, it is a string or vector | ||
| 2326 | of characters or event types, and non-ASCII characters with codes | ||
| 2327 | above 127 (such as ISO Latin-1) can be included if you use a vector. | ||
| 2328 | |||
| 2329 | Note that if KEY has a local binding in the current buffer, | ||
| 2330 | that local binding will continue to shadow any global binding | ||
| 2331 | that you make with this function." | ||
| 2332 | (interactive "KSet key globally: \nCSet key %s to command: ") | ||
| 2333 | (or (vectorp key) (stringp key) | ||
| 2334 | (signal 'wrong-type-argument (list 'arrayp key))) | ||
| 2335 | (define-key (current-global-map) key command)) | ||
| 2336 | |||
| 2337 | (defun local-set-key (key command) | ||
| 2338 | "Give KEY a local binding as COMMAND. | ||
| 2339 | COMMAND is the command definition to use; usually it is | ||
| 2340 | a symbol naming an interactively-callable function. | ||
| 2341 | KEY is a key sequence; noninteractively, it is a string or vector | ||
| 2342 | of characters or event types, and non-ASCII characters with codes | ||
| 2343 | above 127 (such as ISO Latin-1) can be included if you use a vector. | ||
| 2344 | |||
| 2345 | The binding goes in the current buffer's local map, | ||
| 2346 | which in most cases is shared with all other buffers in the same major mode." | ||
| 2347 | (interactive "KSet key locally: \nCSet key %s locally to command: ") | ||
| 2348 | (let ((map (current-local-map))) | ||
| 2349 | (or map | ||
| 2350 | (use-local-map (setq map (make-sparse-keymap)))) | ||
| 2351 | (or (vectorp key) (stringp key) | ||
| 2352 | (signal 'wrong-type-argument (list 'arrayp key))) | ||
| 2353 | (define-key map key command))) | ||
| 2354 | |||
| 2355 | (defun global-unset-key (key) | ||
| 2356 | "Remove global binding of KEY. | ||
| 2357 | KEY is a string or vector representing a sequence of keystrokes." | ||
| 2358 | (interactive "kUnset key globally: ") | ||
| 2359 | (global-set-key key nil)) | ||
| 2360 | |||
| 2361 | (defun local-unset-key (key) | ||
| 2362 | "Remove local binding of KEY. | ||
| 2363 | KEY is a string or vector representing a sequence of keystrokes." | ||
| 2364 | (interactive "kUnset key locally: ") | ||
| 2365 | (if (current-local-map) | ||
| 2366 | (local-set-key key nil)) | ||
| 2367 | nil) | ||
| 2368 | 2597 | ||
| 2369 | ;; We put this here instead of in frame.el so that it's defined even on | 2598 | ;;;; Text clones |
| 2370 | ;; systems where frame.el isn't loaded. | ||
| 2371 | (defun frame-configuration-p (object) | ||
| 2372 | "Return non-nil if OBJECT seems to be a frame configuration. | ||
| 2373 | Any list whose car is `frame-configuration' is assumed to be a frame | ||
| 2374 | configuration." | ||
| 2375 | (and (consp object) | ||
| 2376 | (eq (car object) 'frame-configuration))) | ||
| 2377 | |||
| 2378 | (defun functionp (object) | ||
| 2379 | "Non-nil if OBJECT is any kind of function or a special form. | ||
| 2380 | Also non-nil if OBJECT is a symbol and its function definition is | ||
| 2381 | \(recursively) a function or special form. This does not include | ||
| 2382 | macros." | ||
| 2383 | (or (and (symbolp object) (fboundp object) | ||
| 2384 | (condition-case nil | ||
| 2385 | (setq object (indirect-function object)) | ||
| 2386 | (error nil)) | ||
| 2387 | (eq (car-safe object) 'autoload) | ||
| 2388 | (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object))))))) | ||
| 2389 | (subrp object) (byte-code-function-p object) | ||
| 2390 | (eq (car-safe object) 'lambda))) | ||
| 2391 | |||
| 2392 | (defun assq-delete-all (key alist) | ||
| 2393 | "Delete from ALIST all elements whose car is `eq' to KEY. | ||
| 2394 | Return the modified alist. | ||
| 2395 | Elements of ALIST that are not conses are ignored." | ||
| 2396 | (while (and (consp (car alist)) | ||
| 2397 | (eq (car (car alist)) key)) | ||
| 2398 | (setq alist (cdr alist))) | ||
| 2399 | (let ((tail alist) tail-cdr) | ||
| 2400 | (while (setq tail-cdr (cdr tail)) | ||
| 2401 | (if (and (consp (car tail-cdr)) | ||
| 2402 | (eq (car (car tail-cdr)) key)) | ||
| 2403 | (setcdr tail (cdr tail-cdr)) | ||
| 2404 | (setq tail tail-cdr)))) | ||
| 2405 | alist) | ||
| 2406 | |||
| 2407 | (defun rassq-delete-all (value alist) | ||
| 2408 | "Delete from ALIST all elements whose cdr is `eq' to VALUE. | ||
| 2409 | Return the modified alist. | ||
| 2410 | Elements of ALIST that are not conses are ignored." | ||
| 2411 | (while (and (consp (car alist)) | ||
| 2412 | (eq (cdr (car alist)) value)) | ||
| 2413 | (setq alist (cdr alist))) | ||
| 2414 | (let ((tail alist) tail-cdr) | ||
| 2415 | (while (setq tail-cdr (cdr tail)) | ||
| 2416 | (if (and (consp (car tail-cdr)) | ||
| 2417 | (eq (cdr (car tail-cdr)) value)) | ||
| 2418 | (setcdr tail (cdr tail-cdr)) | ||
| 2419 | (setq tail tail-cdr)))) | ||
| 2420 | alist) | ||
| 2421 | |||
| 2422 | (defun make-temp-file (prefix &optional dir-flag suffix) | ||
| 2423 | "Create a temporary file. | ||
| 2424 | The returned file name (created by appending some random characters at the end | ||
| 2425 | of PREFIX, and expanding against `temporary-file-directory' if necessary), | ||
| 2426 | is guaranteed to point to a newly created empty file. | ||
| 2427 | You can then use `write-region' to write new data into the file. | ||
| 2428 | |||
| 2429 | If DIR-FLAG is non-nil, create a new empty directory instead of a file. | ||
| 2430 | |||
| 2431 | If SUFFIX is non-nil, add that at the end of the file name." | ||
| 2432 | (let ((umask (default-file-modes)) | ||
| 2433 | file) | ||
| 2434 | (unwind-protect | ||
| 2435 | (progn | ||
| 2436 | ;; Create temp files with strict access rights. It's easy to | ||
| 2437 | ;; loosen them later, whereas it's impossible to close the | ||
| 2438 | ;; time-window of loose permissions otherwise. | ||
| 2439 | (set-default-file-modes ?\700) | ||
| 2440 | (while (condition-case () | ||
| 2441 | (progn | ||
| 2442 | (setq file | ||
| 2443 | (make-temp-name | ||
| 2444 | (expand-file-name prefix temporary-file-directory))) | ||
| 2445 | (if suffix | ||
| 2446 | (setq file (concat file suffix))) | ||
| 2447 | (if dir-flag | ||
| 2448 | (make-directory file) | ||
| 2449 | (write-region "" nil file nil 'silent nil 'excl)) | ||
| 2450 | nil) | ||
| 2451 | (file-already-exists t)) | ||
| 2452 | ;; the file was somehow created by someone else between | ||
| 2453 | ;; `make-temp-name' and `write-region', let's try again. | ||
| 2454 | nil) | ||
| 2455 | file) | ||
| 2456 | ;; Reset the umask. | ||
| 2457 | (set-default-file-modes umask)))) | ||
| 2458 | |||
| 2459 | |||
| 2460 | ;; If a minor mode is not defined with define-minor-mode, | ||
| 2461 | ;; add it here explicitly. | ||
| 2462 | ;; isearch-mode is deliberately excluded, since you should | ||
| 2463 | ;; not call it yourself. | ||
| 2464 | (defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode | ||
| 2465 | overwrite-mode view-mode | ||
| 2466 | hs-minor-mode) | ||
| 2467 | "List of all minor mode functions.") | ||
| 2468 | |||
| 2469 | (defun add-minor-mode (toggle name &optional keymap after toggle-fun) | ||
| 2470 | "Register a new minor mode. | ||
| 2471 | |||
| 2472 | This is an XEmacs-compatibility function. Use `define-minor-mode' instead. | ||
| 2473 | |||
| 2474 | TOGGLE is a symbol which is the name of a buffer-local variable that | ||
| 2475 | is toggled on or off to say whether the minor mode is active or not. | ||
| 2476 | |||
| 2477 | NAME specifies what will appear in the mode line when the minor mode | ||
| 2478 | is active. NAME should be either a string starting with a space, or a | ||
| 2479 | symbol whose value is such a string. | ||
| 2480 | |||
| 2481 | Optional KEYMAP is the keymap for the minor mode that will be added | ||
| 2482 | to `minor-mode-map-alist'. | ||
| 2483 | |||
| 2484 | Optional AFTER specifies that TOGGLE should be added after AFTER | ||
| 2485 | in `minor-mode-alist'. | ||
| 2486 | |||
| 2487 | Optional TOGGLE-FUN is an interactive function to toggle the mode. | ||
| 2488 | It defaults to (and should by convention be) TOGGLE. | ||
| 2489 | |||
| 2490 | If TOGGLE has a non-nil `:included' property, an entry for the mode is | ||
| 2491 | included in the mode-line minor mode menu. | ||
| 2492 | If TOGGLE has a `:menu-tag', that is used for the menu item's label." | ||
| 2493 | (unless (memq toggle minor-mode-list) | ||
| 2494 | (push toggle minor-mode-list)) | ||
| 2495 | |||
| 2496 | (unless toggle-fun (setq toggle-fun toggle)) | ||
| 2497 | (unless (eq toggle-fun toggle) | ||
| 2498 | (put toggle :minor-mode-function toggle-fun)) | ||
| 2499 | ;; Add the name to the minor-mode-alist. | ||
| 2500 | (when name | ||
| 2501 | (let ((existing (assq toggle minor-mode-alist))) | ||
| 2502 | (if existing | ||
| 2503 | (setcdr existing (list name)) | ||
| 2504 | (let ((tail minor-mode-alist) found) | ||
| 2505 | (while (and tail (not found)) | ||
| 2506 | (if (eq after (caar tail)) | ||
| 2507 | (setq found tail) | ||
| 2508 | (setq tail (cdr tail)))) | ||
| 2509 | (if found | ||
| 2510 | (let ((rest (cdr found))) | ||
| 2511 | (setcdr found nil) | ||
| 2512 | (nconc found (list (list toggle name)) rest)) | ||
| 2513 | (setq minor-mode-alist (cons (list toggle name) | ||
| 2514 | minor-mode-alist))))))) | ||
| 2515 | ;; Add the toggle to the minor-modes menu if requested. | ||
| 2516 | (when (get toggle :included) | ||
| 2517 | (define-key mode-line-mode-menu | ||
| 2518 | (vector toggle) | ||
| 2519 | (list 'menu-item | ||
| 2520 | (concat | ||
| 2521 | (or (get toggle :menu-tag) | ||
| 2522 | (if (stringp name) name (symbol-name toggle))) | ||
| 2523 | (let ((mode-name (if (symbolp name) (symbol-value name)))) | ||
| 2524 | (if (and (stringp mode-name) (string-match "[^ ]+" mode-name)) | ||
| 2525 | (concat " (" (match-string 0 mode-name) ")")))) | ||
| 2526 | toggle-fun | ||
| 2527 | :button (cons :toggle toggle)))) | ||
| 2528 | |||
| 2529 | ;; Add the map to the minor-mode-map-alist. | ||
| 2530 | (when keymap | ||
| 2531 | (let ((existing (assq toggle minor-mode-map-alist))) | ||
| 2532 | (if existing | ||
| 2533 | (setcdr existing keymap) | ||
| 2534 | (let ((tail minor-mode-map-alist) found) | ||
| 2535 | (while (and tail (not found)) | ||
| 2536 | (if (eq after (caar tail)) | ||
| 2537 | (setq found tail) | ||
| 2538 | (setq tail (cdr tail)))) | ||
| 2539 | (if found | ||
| 2540 | (let ((rest (cdr found))) | ||
| 2541 | (setcdr found nil) | ||
| 2542 | (nconc found (list (cons toggle keymap)) rest)) | ||
| 2543 | (setq minor-mode-map-alist (cons (cons toggle keymap) | ||
| 2544 | minor-mode-map-alist)))))))) | ||
| 2545 | |||
| 2546 | ;; Clones ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | ||
| 2547 | 2599 | ||
| 2548 | (defun text-clone-maintain (ol1 after beg end &optional len) | 2600 | (defun text-clone-maintain (ol1 after beg end &optional len) |
| 2549 | "Propagate the changes made under the overlay OL1 to the other clones. | 2601 | "Propagate the changes made under the overlay OL1 to the other clones. |
| @@ -2637,27 +2689,11 @@ clone should be incorporated in the clone." | |||
| 2637 | ;;(overlay-put ol2 'face 'underline) | 2689 | ;;(overlay-put ol2 'face 'underline) |
| 2638 | (overlay-put ol2 'evaporate t) | 2690 | (overlay-put ol2 'evaporate t) |
| 2639 | (overlay-put ol2 'text-clones dups))) | 2691 | (overlay-put ol2 'text-clones dups))) |
| 2692 | |||
| 2693 | ;;;; Mail user agents. | ||
| 2640 | 2694 | ||
| 2641 | (defun play-sound (sound) | 2695 | ;; Here we include just enough for other packages to be able |
| 2642 | "SOUND is a list of the form `(sound KEYWORD VALUE...)'. | 2696 | ;; to define them. |
| 2643 | The following keywords are recognized: | ||
| 2644 | |||
| 2645 | :file FILE - read sound data from FILE. If FILE isn't an | ||
| 2646 | absolute file name, it is searched in `data-directory'. | ||
| 2647 | |||
| 2648 | :data DATA - read sound data from string DATA. | ||
| 2649 | |||
| 2650 | Exactly one of :file or :data must be present. | ||
| 2651 | |||
| 2652 | :volume VOL - set volume to VOL. VOL must an integer in the | ||
| 2653 | range 0..100 or a float in the range 0..1.0. If not specified, | ||
| 2654 | don't change the volume setting of the sound device. | ||
| 2655 | |||
| 2656 | :device DEVICE - play sound on DEVICE. If not specified, | ||
| 2657 | a system-dependent default device name is used." | ||
| 2658 | (if (fboundp 'play-sound-internal) | ||
| 2659 | (play-sound-internal sound) | ||
| 2660 | (error "This Emacs binary lacks sound support"))) | ||
| 2661 | 2697 | ||
| 2662 | (defun define-mail-user-agent (symbol composefunc sendfunc | 2698 | (defun define-mail-user-agent (symbol composefunc sendfunc |
| 2663 | &optional abortfunc hookvar) | 2699 | &optional abortfunc hookvar) |
| @@ -2693,8 +2729,8 @@ The properties used on SYMBOL are `composefunc', `sendfunc', | |||
| 2693 | (put symbol 'sendfunc sendfunc) | 2729 | (put symbol 'sendfunc sendfunc) |
| 2694 | (put symbol 'abortfunc (or abortfunc 'kill-buffer)) | 2730 | (put symbol 'abortfunc (or abortfunc 'kill-buffer)) |
| 2695 | (put symbol 'hookvar (or hookvar 'mail-send-hook))) | 2731 | (put symbol 'hookvar (or hookvar 'mail-send-hook))) |
| 2696 | 2732 | ||
| 2697 | ;; Standardized progress reporting | 2733 | ;;;; Progress reporters. |
| 2698 | 2734 | ||
| 2699 | ;; Progress reporter has the following structure: | 2735 | ;; Progress reporter has the following structure: |
| 2700 | ;; | 2736 | ;; |
| @@ -2851,7 +2887,7 @@ convenience wrapper around `make-progress-reporter' and friends. | |||
| 2851 | nil ,@(cdr (cdr spec))))) | 2887 | nil ,@(cdr (cdr spec))))) |
| 2852 | 2888 | ||
| 2853 | 2889 | ||
| 2854 | ;;;; Compare Version Strings | 2890 | ;;;; Comparing version strings. |
| 2855 | 2891 | ||
| 2856 | (defvar version-separator "." | 2892 | (defvar version-separator "." |
| 2857 | "*Specify the string used to separate the version elements. | 2893 | "*Specify the string used to separate the version elements. |