X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/ba69b876ac836a88877dab99e6fc2352dd36c855..db18c5fd6fca1633508dc77d687789f38d905dd1:/lisp/subr.el diff --git a/lisp/subr.el b/lisp/subr.el index 17008e058b..b15e463693 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1,17 +1,17 @@ ;;; subr.el --- basic lisp subroutines for Emacs ;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. +;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -19,9 +19,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -36,6 +34,42 @@ Each element of this list holds the arguments to one call to `defcustom'.") (setq custom-declare-variable-list (cons arguments custom-declare-variable-list))) +(defmacro declare-function (fn file &optional arglist fileonly) + "Tell the byte-compiler that function FN is defined, in FILE. +Optional ARGLIST is the argument list used by the function. The +FILE argument is not used by the byte-compiler, but by the +`check-declare' package, which checks that FILE contains a +definition for FN. ARGLIST is used by both the byte-compiler and +`check-declare' to check for consistency. + +FILE can be either a Lisp file (in which case the \".el\" +extension is optional), or a C file. C files are expanded +relative to the Emacs \"src/\" directory. Lisp files are +searched for using `locate-library', and if that fails they are +expanded relative to the location of the file containing the +declaration. A FILE with an \"ext:\" prefix is an external file. +`check-declare' will check such files if they are found, and skip +them without error if they are not. + +FILEONLY non-nil means that `check-declare' will only check that +FILE exists, not that it defines FN. This is intended for +function-definitions that `check-declare' does not recognize, e.g. +`defstruct'. + +To specify a value for FILEONLY without passing an argument list, +set ARGLIST to `t'. This is necessary because `nil' means an +empty argument list, rather than an unspecified one. + +Note that for the purposes of `check-declare', this statement +must be the first non-whitespace on a line, and everything up to +the end of FILE must be all on the same line. For example: + +\(declare-function c-end-of-defun \"progmodes/cc-cmds.el\" + \(&optional arg)) + +For more information, see Info node `elisp(Declaring Functions)'." + ;; Does nothing - byte-compile-declare-function does the work. + nil) ;;;; Basic Lisp macros. @@ -168,6 +202,11 @@ the return value (nil if RESULT is omitted). Treated as a declaration when used at the right place in a `defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)" nil) + +(defmacro ignore-errors (&rest body) + "Execute BODY; if an error occurs, return nil. +Otherwise, return result of last form in BODY." + `(condition-case nil (progn ,@body) (error nil))) ;;;; Basic Lisp functions. @@ -195,17 +234,17 @@ configuration." (eq (car object) 'frame-configuration))) (defun functionp (object) - "Non-nil if OBJECT is any kind of function or a special form. -Also non-nil if OBJECT is a symbol and its function definition is -\(recursively) a function or special form. This does not include -macros." + "Non-nil if OBJECT is a function." (or (and (symbolp object) (fboundp object) (condition-case nil (setq object (indirect-function object)) (error nil)) (eq (car-safe object) 'autoload) (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object))))))) - (subrp object) (byte-code-function-p object) + (and (subrp object) + ;; Filter out special forms. + (not (eq 'unevalled (cdr (subr-arity object))))) + (byte-code-function-p object) (eq (car-safe object) 'lambda))) ;;;; List functions. @@ -346,14 +385,14 @@ If TEST is omitted or nil, `equal' is used." (setq tail (cdr tail))) value)) -(make-obsolete 'assoc-ignore-case 'assoc-string) +(make-obsolete 'assoc-ignore-case 'assoc-string "22.1") (defun assoc-ignore-case (key alist) "Like `assoc', but ignores differences in case and text representation. KEY must be a string. Upper-case and lower-case letters are treated as equal. Unibyte strings are converted to multibyte for comparison." (assoc-string key alist t)) -(make-obsolete 'assoc-ignore-representation 'assoc-string) +(make-obsolete 'assoc-ignore-representation 'assoc-string "22.1") (defun assoc-ignore-representation (key alist) "Like `assoc', but ignores differences in text representation. KEY must be a string. @@ -496,25 +535,50 @@ The order of bindings in a keymap matters when it is used as a menu." (setq inserted t))) (setq tail (cdr tail))))) -(defun map-keymap-internal (function keymap &optional sort-first) +(defun map-keymap-sorted (function keymap) "Implement `map-keymap' with sorting. Don't call this function; it is for internal use only." - (if sort-first - (let (list) - (map-keymap (lambda (a b) (push (cons a b) list)) - keymap) - (setq list (sort list - (lambda (a b) - (setq a (car a) b (car b)) - (if (integerp a) - (if (integerp b) (< a b) - t) - (if (integerp b) t - ;; string< also accepts symbols. - (string< a b)))))) - (dolist (p list) - (funcall function (car p) (cdr p)))) - (map-keymap function keymap))) + (let (list) + (map-keymap (lambda (a b) (push (cons a b) list)) + keymap) + (setq list (sort list + (lambda (a b) + (setq a (car a) b (car b)) + (if (integerp a) + (if (integerp b) (< a b) + t) + (if (integerp b) t + ;; string< also accepts symbols. + (string< a b)))))) + (dolist (p list) + (funcall function (car p) (cdr p))))) + +(defun keymap-canonicalize (map) + "Return an equivalent keymap, without inheritance." + (let ((bindings ()) + (ranges ())) + (while (keymapp map) + (setq map (map-keymap-internal + (lambda (key item) + (if (consp key) + ;; Treat char-ranges specially. + (push (cons key item) ranges) + (push (cons key item) bindings))) + map))) + (setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap) + (keymap-prompt map))) + (dolist (binding ranges) + ;; Treat char-ranges specially. + (define-key map (vector (car binding)) (cdr binding))) + (dolist (binding (prog1 bindings (setq bindings ()))) + (let* ((key (car binding)) + (item (cdr binding)) + (oldbind (assq key bindings))) + ;; Newer bindings override older. + (if oldbind (setq bindings (delq oldbind bindings))) + (when item ;nil bindings just hide older ones. + (push binding bindings)))) + (nconc map bindings))) (put 'keyboard-translate-table 'char-table-extra-slots 0) @@ -703,7 +767,7 @@ The normal global definition of the character C-x indirects to this keymap.") ;; Filter out integers too large to be events. ;; M is the biggest modifier. (zerop (logand obj (lognot (1- (lsh ?\M-\^@ 1))))) - (char-valid-p (event-basic-type obj))) + (characterp (event-basic-type obj))) (and (symbolp obj) (get obj 'event-symbol-elements)) (and (consp obj) @@ -723,7 +787,9 @@ even when EVENT actually has modifiers." (if (listp type) (setq type (car type))) (if (symbolp type) - (cdr (get type 'event-symbol-elements)) + ;; Don't read event-symbol-elements directly since we're not + ;; sure the symbol has already been parsed. + (cdr (internal-event-symbol-parse-modifiers type)) (let ((list nil) (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@ ?\H-\^@ ?\s-\^@ ?\A-\^@))))) @@ -765,6 +831,11 @@ in the current Emacs session, then this function may return nil." "Return non-nil if OBJECT is a mouse movement event." (eq (car-safe object) 'mouse-movement)) +(defun mouse-event-p (object) + "Return non-nil if OBJECT is a mouse click event." + ;; is this really correct? maybe remove mouse-movement? + (memq (event-basic-type object) '(mouse-1 mouse-2 mouse-3 mouse-movement))) + (defsubst event-start (event) "Return the starting position of EVENT. If EVENT is a mouse or key press or a mouse click, this returns the location @@ -834,6 +905,8 @@ POSITION should be a list of the form returned by the `event-start' and `event-end' functions." (nth 2 position)) +(declare-function scroll-bar-scale "scroll-bar" (num-denom whole)) + (defun posn-col-row (position) "Return the nominal column and row in POSITION, measured in characters. The column and row values are approximations calculated from the x @@ -858,7 +931,8 @@ and `event-end' functions." (x (/ (car pair) (frame-char-width frame))) (y (/ (cdr pair) (+ (frame-char-height frame) (or (frame-parameter frame 'line-spacing) - default-line-spacing + ;; FIXME: Why the `default'? + (default-value 'line-spacing) 0))))) (cons x y)))))) @@ -945,10 +1019,17 @@ is converted into a string by expressing it in decimal." (make-obsolete 'focus-frame "it does nothing." "22.1") (defalias 'unfocus-frame 'ignore "") (make-obsolete 'unfocus-frame "it does nothing." "22.1") -(make-obsolete 'make-variable-frame-local "use a frame-parameter instead" "22.2") +(make-obsolete 'make-variable-frame-local "use a frame-parameter instead." "22.2") ;;;; Obsolescence declarations for variables, and aliases. +(make-obsolete-variable 'redisplay-end-trigger-functions 'jit-lock-register "23.1") +(make-obsolete 'window-redisplay-end-trigger nil "23.1") +(make-obsolete 'set-window-redisplay-end-trigger nil "23.1") + +(make-obsolete 'process-filter-multibyte-p nil "23.1") +(make-obsolete 'set-process-filter-multibyte nil "23.1") + (make-obsolete-variable 'directory-sep-char "do not use it." "21.1") (make-obsolete-variable 'mode-line-inverse-video @@ -970,6 +1051,9 @@ to reread, so it now uses nil to mean `no event', instead of -1." (defvaralias 'x-sent-selection-hooks 'x-sent-selection-functions) (make-obsolete-variable 'x-sent-selection-hooks 'x-sent-selection-functions "22.1") +;; This was introduced in 21.4 for pre-unicode unification and was rendered +;; obsolete by the use of Unicode internally in 23.1. +(make-obsolete-variable 'translation-table-for-input nil "23.1") (defvaralias 'messages-buffer-max-lines 'message-log-max) @@ -1064,7 +1148,17 @@ function, it is changed to a list of functions." (append hook-value (list function)) (cons function hook-value)))) ;; Set the actual variable - (if local (set hook hook-value) (set-default hook hook-value)))) + (if local + (progn + ;; If HOOK isn't a permanent local, + ;; but FUNCTION wants to survive a change of modes, + ;; mark HOOK as partially permanent. + (and (symbolp function) + (get function 'permanent-local-hook) + (not (get hook 'permanent-local)) + (put hook 'permanent-local 'permanent-local-hook)) + (set hook hook-value)) + (set-default hook hook-value)))) (defun remove-hook (hook function &optional local) "Remove from the value of HOOK the function FUNCTION. @@ -1392,7 +1486,6 @@ definition only or variable definition only. (setq files (cdr files))) file))) -;;;###autoload (defun locate-library (library &optional nosuffix path interactive-call) "Show the precise file name of Emacs library LIBRARY. This command searches the directories in `load-path' like `\\[load-library]' @@ -1403,12 +1496,13 @@ to the specified name LIBRARY. If the optional third arg PATH is specified, that list of directories is used instead of `load-path'. -When called from a program, the file name is normaly returned as a +When called from a program, the file name is normally returned as a string. When run interactively, the argument INTERACTIVE-CALL is t, and the file name is displayed in the echo area." (interactive (list (completing-read "Locate library: " - 'locate-file-completion - (cons load-path (get-load-suffixes))) + (apply-partially + 'locate-file-completion-table + load-path (get-load-suffixes))) nil nil t)) (let ((file (locate-file library @@ -1537,6 +1631,23 @@ FILE should be the name of a library, with no directory name." ;;;; Process stuff. +(defun process-lines (program &rest args) + "Execute PROGRAM with ARGS, returning its output as a list of lines. +Signal an error if the program returns with a non-zero exit status." + (with-temp-buffer + (let ((status (apply 'call-process program nil (current-buffer) nil args))) + (unless (eq status 0) + (error "%s exited with status %s" program status)) + (goto-char (point-min)) + (let (lines) + (while (not (eobp)) + (setq lines (cons (buffer-substring-no-properties + (line-beginning-position) + (line-end-position)) + lines)) + (forward-line 1)) + (nreverse lines))))) + ;; open-network-stream is a wrapper around make-network-process. (when (featurep 'make-network-process) @@ -1627,7 +1738,10 @@ any other non-digit terminates the character code and is then used as input.")) ;; We could try and use read-key-sequence instead, but then C-q ESC ;; or C-q C-x might not return immediately since ESC or C-x might be ;; bound to some prefix in function-key-map or key-translation-map. - (setq translated char) + (setq translated + (if (integerp char) + (char-resolve-modifers char) + char)) (let ((translation (lookup-key local-function-key-map (vector char)))) (if (arrayp translation) (setq translated (aref translation 0)))) @@ -1765,9 +1879,10 @@ in milliseconds; this was useful when Emacs was built without floating point support. \(fn SECONDS &optional NODISP)" - (when (or obsolete (numberp nodisp)) - (setq seconds (+ seconds (* 1e-3 nodisp))) - (setq nodisp obsolete)) + (if (numberp nodisp) + (setq seconds (+ seconds (* 1e-3 nodisp)) + nodisp obsolete) + (if obsolete (setq nodisp obsolete))) (cond (noninteractive (sleep-for seconds) @@ -1804,6 +1919,10 @@ user can undo the change normally." (let ((handle (make-symbol "--change-group-handle--")) (success (make-symbol "--change-group-success--"))) `(let ((,handle (prepare-change-group)) + ;; Don't truncate any undo data in the middle of this. + (undo-outer-limit nil) + (undo-limit most-positive-fixnum) + (undo-strong-limit most-positive-fixnum) (,success nil)) (unwind-protect (progn @@ -1873,24 +1992,25 @@ This finishes the change group by reverting all of its changes." (with-current-buffer (car elt) (setq elt (cdr elt)) (let ((old-car - (if (consp elt) (car elt))) - (old-cdr - (if (consp elt) (cdr elt)))) - ;; Temporarily truncate the undo log at ELT. - (when (consp elt) - (setcar elt nil) (setcdr elt nil)) - (unless (eq last-command 'undo) (undo-start)) - ;; Make sure there's no confusion. - (when (and (consp elt) (not (eq elt (last pending-undo-list)))) - (error "Undoing to some unrelated state")) - ;; Undo it all. - (while (listp pending-undo-list) (undo-more 1)) - ;; Reset the modified cons cell ELT to its original content. - (when (consp elt) - (setcar elt old-car) - (setcdr elt old-cdr)) - ;; Revert the undo info to what it was when we grabbed the state. - (setq buffer-undo-list elt))))) + (if (consp elt) (car elt))) + (old-cdr + (if (consp elt) (cdr elt)))) + ;; Temporarily truncate the undo log at ELT. + (when (consp elt) + (setcar elt nil) (setcdr elt nil)) + (unless (eq last-command 'undo) (undo-start)) + ;; Make sure there's no confusion. + (when (and (consp elt) (not (eq elt (last pending-undo-list)))) + (error "Undoing to some unrelated state")) + ;; Undo it all. + (save-excursion + (while (listp pending-undo-list) (undo-more 1))) + ;; Reset the modified cons cell ELT to its original content. + (when (consp elt) + (setcar elt old-car) + (setcdr elt old-cdr)) + ;; Revert the undo info to what it was when we grabbed the state. + (setq buffer-undo-list elt))))) ;;;; Display-related functions. @@ -1916,56 +2036,37 @@ input (as a command if nothing else). Display MESSAGE (optional fourth arg) in the echo area. If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." (or exit-char (setq exit-char ?\s)) - (let ((inhibit-read-only t) - ;; Don't modify the undo list at all. - (buffer-undo-list t) - (modified (buffer-modified-p)) - (name buffer-file-name) - insert-end) + (let ((ol (make-overlay pos pos)) + (message (copy-sequence string))) (unwind-protect - (progn - (save-excursion - (goto-char pos) - ;; To avoid trouble with out-of-bounds position - (setq pos (point)) - ;; defeat file locking... don't try this at home, kids! - (setq buffer-file-name nil) - (insert-before-markers string) - (setq insert-end (point)) - ;; If the message end is off screen, recenter now. - (if (< (window-end nil t) insert-end) - (recenter (/ (window-height) 2))) - ;; If that pushed message start off the screen, - ;; scroll to start it at the top of the screen. - (move-to-window-line 0) - (if (> (point) pos) - (progn - (goto-char pos) - (recenter 0)))) - (message (or message "Type %s to continue editing.") - (single-key-description exit-char)) - (let (char) - (if (integerp exit-char) - (condition-case nil - (progn - (setq char (read-char)) - (or (eq char exit-char) - (setq unread-command-events (list char)))) - (error - ;; `exit-char' is a character, hence it differs - ;; from char, which is an event. - (setq unread-command-events (list char)))) - ;; `exit-char' can be an event, or an event description - ;; list. - (setq char (read-event)) - (or (eq char exit-char) - (eq char (event-convert-list exit-char)) - (setq unread-command-events (list char)))))) - (if insert-end - (save-excursion - (delete-region pos insert-end))) - (setq buffer-file-name name) - (set-buffer-modified-p modified)))) + (progn + (save-excursion + (overlay-put ol 'after-string message) + (goto-char pos) + ;; To avoid trouble with out-of-bounds position + (setq pos (point)) + ;; If the message end is off screen, recenter now. + (if (<= (window-end nil t) pos) + (recenter (/ (window-height) 2)))) + (message (or message "Type %s to continue editing.") + (single-key-description exit-char)) + (let (char) + (if (integerp exit-char) + (condition-case nil + (progn + (setq char (read-char)) + (or (eq char exit-char) + (setq unread-command-events (list char)))) + (error + ;; `exit-char' is a character, hence it differs + ;; from char, which is an event. + (setq unread-command-events (list char)))) + ;; `exit-char' can be an event, or an event description list. + (setq char (read-event)) + (or (eq char exit-char) + (eq char (event-convert-list exit-char)) + (setq unread-command-events (list char)))))) + (delete-overlay ol)))) ;;;; Overlay operations @@ -2057,26 +2158,29 @@ Note that this should end with a directory separator.") (defun find-tag-default () "Determine default tag to search for, based on text at point. If there is no plausible default, return nil." - (save-excursion - (while (looking-at "\\sw\\|\\s_") - (forward-char 1)) - (if (or (re-search-backward "\\sw\\|\\s_" - (save-excursion (beginning-of-line) (point)) - t) - (re-search-forward "\\(\\sw\\|\\s_\\)+" - (save-excursion (end-of-line) (point)) - t)) - (progn - (goto-char (match-end 0)) - (condition-case nil - (buffer-substring-no-properties - (point) - (progn (forward-sexp -1) - (while (looking-at "\\s'") - (forward-char 1)) - (point))) - (error nil))) - nil))) + (let (from to bound) + (when (or (progn + ;; Look at text around `point'. + (save-excursion + (skip-syntax-backward "w_") (setq from (point))) + (save-excursion + (skip-syntax-forward "w_") (setq to (point))) + (> to from)) + ;; Look between `line-beginning-position' and `point'. + (save-excursion + (and (setq bound (line-beginning-position)) + (skip-syntax-backward "^w_" bound) + (> (setq to (point)) bound) + (skip-syntax-backward "w_") + (setq from (point)))) + ;; Look between `point' and `line-end-position'. + (save-excursion + (and (setq bound (line-end-position)) + (skip-syntax-forward "^w_" bound) + (< (setq from (point)) bound) + (skip-syntax-forward "w_") + (setq to (point))))) + (buffer-substring-no-properties from to)))) (defun play-sound (sound) "SOUND is a list of the form `(sound KEYWORD VALUE...)'. @@ -2099,6 +2203,8 @@ a system-dependent default device name is used." (play-sound-internal sound) (error "This Emacs binary lacks sound support"))) +(declare-function w32-shell-dos-semantics "w32-fns" nil) + (defun shell-quote-argument (argument) "Quote an argument for passing as argument to an inferior shell." (if (or (eq system-type 'ms-dos) @@ -2300,14 +2406,10 @@ passing the command to the shell. Wildcards and redirection are handled as usual in the shell. \(fn NAME BUFFER COMMAND &rest COMMAND-ARGS)" - (cond - ((eq system-type 'vax-vms) - (apply 'start-process name buffer args)) ;; We used to use `exec' to replace the shell with the command, ;; but that failed to handle (...) and semicolon, etc. - (t - (start-process name buffer shell-file-name shell-command-switch - (mapconcat 'identity args " "))))) + (start-process name buffer shell-file-name shell-command-switch + (mapconcat 'identity args " "))) (defun start-file-process-shell-command (name buffer &rest args) "Start a program in a subprocess. Return the process object for it. @@ -2339,16 +2441,12 @@ If BUFFER is 0, `call-process-shell-command' returns immediately with value nil. Otherwise it waits for COMMAND to terminate and returns a numeric exit status or a signal description string. If you quit, the process is killed with SIGINT, or SIGKILL if you quit again." - (cond - ((eq system-type 'vax-vms) - (apply 'call-process command infile buffer display args)) - ;; We used to use `exec' to replace the shell with the command, - ;; but that failed to handle (...) and semicolon, etc. - (t - (call-process shell-file-name - infile buffer display - shell-command-switch - (mapconcat 'identity (cons command args) " "))))) + ;; We used to use `exec' to replace the shell with the command, + ;; but that failed to handle (...) and semicolon, etc. + (call-process shell-file-name + infile buffer display + shell-command-switch + (mapconcat 'identity (cons command args) " "))) (defun process-file-shell-command (command &optional infile buffer display &rest args) @@ -2439,8 +2537,7 @@ See also `with-temp-buffer'." (with-current-buffer ,temp-buffer ,@body) (with-current-buffer ,temp-buffer - (widen) - (write-region (point-min) (point-max) ,temp-file nil 0))) + (write-region nil nil ,temp-file nil 0))) (and (buffer-name ,temp-buffer) (kill-buffer ,temp-buffer)))))) @@ -2473,11 +2570,12 @@ See also `with-temp-file' and `with-output-to-string'." (declare (indent 0) (debug t)) (let ((temp-buffer (make-symbol "temp-buffer"))) `(let ((,temp-buffer (generate-new-buffer " *temp*"))) - (unwind-protect - (with-current-buffer ,temp-buffer - ,@body) - (and (buffer-name ,temp-buffer) - (kill-buffer ,temp-buffer)))))) + ;; FIXME: kill-buffer can change current-buffer in some odd cases. + (with-current-buffer ,temp-buffer + (unwind-protect + (progn ,@body) + (and (buffer-name ,temp-buffer) + (kill-buffer ,temp-buffer))))))) (defmacro with-output-to-string (&rest body) "Execute BODY, return the text it sent to `standard-output', as a string." @@ -2519,7 +2617,7 @@ If BODY finishes, `while-no-input' returns whatever value BODY produced." (catch ',catch-sym (let ((throw-on-input ',catch-sym)) (or (input-pending-p) - ,@body)))))) + (progn ,@body))))))) (defmacro condition-case-no-debug (var bodyform &rest handlers) "Like `condition-case' except that it does not catch anything when debugging. @@ -2537,7 +2635,7 @@ More specifically if `debug-on-error' is set, then it does not catch any signal. "Run BODY and demote any errors to simple messages. If `debug-on-error' is non-nil, run BODY without catching its errors. This is to be used around code which is not expected to signal an error -but which should be robust in the unexpected case that an error is signalled." +but which should be robust in the unexpected case that an error is signaled." (declare (debug t) (indent 0)) (let ((err (make-symbol "err"))) `(condition-case-no-debug ,err @@ -2576,92 +2674,6 @@ The value returned is the value of the last form in BODY." (with-current-buffer ,old-buffer (set-case-table ,old-case-table)))))) -;;;; Constructing completion tables. - -(defun complete-with-action (action table string pred) - "Perform completion ACTION. -STRING is the string to complete. -TABLE is the completion table, which should not be a function. -PRED is a completion predicate. -ACTION can be one of nil, t or `lambda'." - ;; (assert (not (functionp table))) - (funcall - (cond - ((null action) 'try-completion) - ((eq action t) 'all-completions) - (t 'test-completion)) - string table pred)) - -(defmacro dynamic-completion-table (fun) - "Use function FUN as a dynamic completion table. -FUN is called with one argument, the string for which completion is required, -and it should return an alist containing all the intended possible -completions. This alist may be a full list of possible completions so that FUN -can ignore the value of its argument. If completion is performed in the -minibuffer, FUN will be called in the buffer from which the minibuffer was -entered. - -The result of the `dynamic-completion-table' form is a function -that can be used as the ALIST argument to `try-completion' and -`all-completion'. See Info node `(elisp)Programmed Completion'." - (declare (debug (lambda-expr))) - (let ((win (make-symbol "window")) - (string (make-symbol "string")) - (predicate (make-symbol "predicate")) - (mode (make-symbol "mode"))) - `(lambda (,string ,predicate ,mode) - (with-current-buffer (let ((,win (minibuffer-selected-window))) - (if (window-live-p ,win) (window-buffer ,win) - (current-buffer))) - (complete-with-action ,mode (,fun ,string) ,string ,predicate))))) - -(defmacro lazy-completion-table (var fun) - ;; We used to have `&rest args' where `args' were evaluated late (at the - ;; time of the call to `fun'), which was counter intuitive. But to get - ;; them to be evaluated early, we have to either use lexical-let (which is - ;; not available in subr.el) or use `(lambda (,str) ...) which prevents the use - ;; of lexical-let in the callers. - ;; So we just removed the argument. Callers can then simply use either of: - ;; (lazy-completion-table var (lambda () (fun x y))) - ;; or - ;; (lazy-completion-table var `(lambda () (fun ',x ',y))) - ;; or - ;; (lexical-let ((x x)) ((y y)) - ;; (lazy-completion-table var (lambda () (fun x y)))) - ;; depending on the behavior they want. - "Initialize variable VAR as a lazy completion table. -If the completion table VAR is used for the first time (e.g., by passing VAR -as an argument to `try-completion'), the function FUN is called with no -arguments. FUN must return the completion table that will be stored in VAR. -If completion is requested in the minibuffer, FUN will be called in the buffer -from which the minibuffer was entered. The return value of -`lazy-completion-table' must be used to initialize the value of VAR. - -You should give VAR a non-nil `risky-local-variable' property." - (declare (debug (symbol lambda-expr))) - (let ((str (make-symbol "string"))) - `(dynamic-completion-table - (lambda (,str) - (when (functionp ,var) - (setq ,var (,fun))) - ,var)))) - -(defmacro complete-in-turn (a b) - "Create a completion table that first tries completion in A and then in B. -A and B should not be costly (or side-effecting) expressions." - (declare (debug (def-form def-form))) - `(lambda (string predicate mode) - (cond - ((eq mode t) - (or (all-completions string ,a predicate) - (all-completions string ,b predicate))) - ((eq mode nil) - (or (try-completion string ,a predicate) - (try-completion string ,b predicate))) - (t - (or (test-completion string ,a predicate) - (test-completion string ,b predicate)))))) - ;;; Matching and match data. (defvar save-match-data-internal) @@ -2709,6 +2721,24 @@ STRING should be given if the last search was by `string-match' on STRING." (buffer-substring-no-properties (match-beginning num) (match-end num))))) + +(defun match-substitute-replacement (replacement + &optional fixedcase literal string subexp) + "Return REPLACEMENT as it will be inserted by `replace-match'. +In other words, all back-references in the form `\\&' and `\\N' +are substituted with actual strings matched by the last search. +Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same +meaning as for `replace-match'." + (let ((match (match-string 0 string))) + (save-match-data + (set-match-data (mapcar (lambda (x) + (if (numberp x) + (- x (match-beginning 0)) + x)) + (match-data t))) + (replace-match replacement fixedcase literal match subexp)))) + + (defun looking-back (regexp &optional limit greedy) "Return non-nil if text before point matches regular expression REGEXP. Like `looking-at' except matches before point, and is slower. @@ -2857,10 +2887,11 @@ Modifies the match data; use `save-match-data' if necessary." This tries to quote the strings to avoid ambiguity such that (split-string-and-unquote (combine-and-quote-strings strs)) == strs Only some SEPARATORs will work properly." - (let ((sep (or separator " "))) + (let* ((sep (or separator " ")) + (re (concat "[\\\"]" "\\|" (regexp-quote sep)))) (mapconcat (lambda (str) - (if (string-match "[\\\"]" str) + (if (string-match re str) (concat "\"" (replace-regexp-in-string "[\\\"]" "\\\\\\&" str) "\"") str)) strings sep)))