Clarify manual and `add-hook' doc string about buffer-local hooks
[bpt/emacs.git] / lisp / subr.el
index 3330fa2..a2f5604 100644 (file)
@@ -92,7 +92,7 @@ Both SYMBOL and SPEC are unevaluated.  The SPEC can be:
 0 (instrument no arguments); t (instrument all arguments);
 a symbol (naming a function with an Edebug specification); or a list.
 The elements of the list describe the argument types; see
-\(info \"(elisp)Specification List\") for details."
+Info node `(elisp)Specification List' for details."
   `(put (quote ,symbol) 'edebug-form-spec (quote ,spec)))
 
 (defmacro lambda (&rest cdr)
@@ -116,6 +116,17 @@ BODY should be a list of Lisp expressions.
   ;; depend on backquote.el.
   (list 'function (cons 'lambda cdr)))
 
+;; Partial application of functions (similar to "currying").
+;; This function is here rather than in subr.el because it uses CL.
+(defun apply-partially (fun &rest args)
+  "Return a function that is a partial application of FUN to ARGS.
+ARGS is a list of the first N arguments to pass to FUN.
+The result is a new function which does the same as FUN, except that
+the first N arguments are fixed at the values with which this function
+was called."
+  `(closure (t) (&rest args)
+            (apply ',fun ,@(mapcar (lambda (arg) `',arg) args) args)))
+
 (if (null (featurep 'cl))
     (progn
   ;; If we reload subr.el after having loaded CL, be careful not to
@@ -163,8 +174,6 @@ value of last one, or nil if there are none.
   ;; If we reload subr.el after having loaded CL, be careful not to
   ;; overwrite CL's extended definition of `dolist', `dotimes',
   ;; `declare', `push' and `pop'.
-(defvar --dolist-tail-- nil
-  "Temporary variable used in `dolist' expansion.")
 
 (defmacro dolist (spec &rest body)
   "Loop over a list.
@@ -176,18 +185,29 @@ Then evaluate RESULT to get return value, default nil.
   ;; It would be cleaner to create an uninterned symbol,
   ;; but that uses a lot more space when many functions in many files
   ;; use dolist.
+  ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
   (let ((temp '--dolist-tail--))
-    `(let ((,temp ,(nth 1 spec))
-          ,(car spec))
-       (while ,temp
-        (setq ,(car spec) (car ,temp))
-        ,@body
-        (setq ,temp (cdr ,temp)))
-       ,@(if (cdr (cdr spec))
-            `((setq ,(car spec) nil) ,@(cdr (cdr spec)))))))
-
-(defvar --dotimes-limit-- nil
-  "Temporary variable used in `dotimes' expansion.")
+    ;; This is not a reliable test, but it does not matter because both
+    ;; semantics are acceptable, tho one is slightly faster with dynamic
+    ;; scoping and the other is slightly faster (and has cleaner semantics)
+    ;; with lexical scoping.
+    (if lexical-binding
+        `(let ((,temp ,(nth 1 spec)))
+           (while ,temp
+             (let ((,(car spec) (car ,temp)))
+               ,@body
+               (setq ,temp (cdr ,temp))))
+           ,@(if (cdr (cdr spec))
+                 ;; FIXME: This let often leads to "unused var" warnings.
+                 `((let ((,(car spec) nil)) ,@(cdr (cdr spec))))))
+      `(let ((,temp ,(nth 1 spec))
+             ,(car spec))
+         (while ,temp
+           (setq ,(car spec) (car ,temp))
+           ,@body
+           (setq ,temp (cdr ,temp)))
+         ,@(if (cdr (cdr spec))
+               `((setq ,(car spec) nil) ,@(cdr (cdr spec))))))))
 
 (defmacro dotimes (spec &rest body)
   "Loop a certain number of times.
@@ -200,17 +220,32 @@ the return value (nil if RESULT is omitted).
   ;; It would be cleaner to create an uninterned symbol,
   ;; but that uses a lot more space when many functions in many files
   ;; use dotimes.
+  ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
   (let ((temp '--dotimes-limit--)
        (start 0)
        (end (nth 1 spec)))
-    `(let ((,temp ,end)
-          (,(car spec) ,start))
-       (while (< ,(car spec) ,temp)
-        ,@body
-        (setq ,(car spec) (1+ ,(car spec))))
-       ,@(cdr (cdr spec)))))
-
-(defmacro declare (&rest specs)
+    ;; This is not a reliable test, but it does not matter because both
+    ;; semantics are acceptable, tho one is slightly faster with dynamic
+    ;; scoping and the other has cleaner semantics.
+    (if lexical-binding
+        (let ((counter '--dotimes-counter--))
+          `(let ((,temp ,end)
+                 (,counter ,start))
+             (while (< ,counter ,temp)
+               (let ((,(car spec) ,counter))
+                 ,@body)
+               (setq ,counter (1+ ,counter)))
+             ,@(if (cddr spec)
+                   ;; FIXME: This let often leads to "unused var" warnings.
+                   `((let ((,(car spec) ,counter)) ,@(cddr spec))))))
+      `(let ((,temp ,end)
+             (,(car spec) ,start))
+         (while (< ,(car spec) ,temp)
+           ,@body
+           (setq ,(car spec) (1+ ,(car spec))))
+         ,@(cdr (cdr spec))))))
+
+(defmacro declare (&rest _specs)
   "Do not evaluate any arguments and return nil.
 Treated as a declaration when used at the right place in a
 `defmacro' form.  \(See Info anchor `(elisp)Definition of declare'.)"
@@ -225,7 +260,7 @@ Otherwise, return result of last form in BODY."
 \f
 ;;;; Basic Lisp functions.
 
-(defun ignore (&rest ignore)
+(defun ignore (&rest _ignore)
   "Do nothing and return nil.
 This function accepts any number of arguments, but ignores them."
   (interactive)
@@ -249,20 +284,6 @@ Any list whose car is `frame-configuration' is assumed to be a frame
 configuration."
   (and (consp object)
        (eq (car object) 'frame-configuration)))
-
-(defun functionp (object)
-  "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)))))))
-      (and (subrp object)
-           ;; Filter out special forms.
-           (not (eq 'unevalled (cdr (subr-arity object)))))
-      (byte-code-function-p object)
-      (eq (car-safe object) 'lambda)))
 \f
 ;;;; List functions.
 
@@ -469,6 +490,7 @@ SEQ must be a list, vector, or string.  The comparison is done with `equal'."
   "Return LIST with all occurrences of ELT removed.
 The comparison is done with `eq'.  Contrary to `delq', this does not use
 side-effects, and the argument LIST is not modified."
+  (while (and (eq elt (car list)) (setq list (cdr list))))
   (if (memq elt list)
       (delq elt (copy-sequence list))
     list))
@@ -570,31 +592,88 @@ Don't call this function; it is for internal use only."
     (dolist (p list)
       (funcall function (car p) (cdr p)))))
 
+(defun keymap--menu-item-binding (val)
+  "Return the binding part of a menu-item."
+  (cond
+   ((not (consp val)) val)              ;Not a menu-item.
+   ((eq 'menu-item (car val))
+    (let* ((binding (nth 2 val))
+           (plist (nthcdr 3 val))
+           (filter (plist-get plist :filter)))
+      (if filter (funcall filter binding)
+        binding)))
+   ((and (consp (cdr val)) (stringp (cadr val)))
+    (cddr val))
+   ((stringp (car val))
+    (cdr val))
+   (t val)))                            ;Not a menu-item either.
+
+(defun keymap--menu-item-with-binding (item binding)
+  "Build a menu-item like ITEM but with its binding changed to BINDING."
+  (cond
+   ((eq 'menu-item (car item))
+    (setq item (copy-sequence item))
+    (let ((tail (nthcdr 2 item)))
+      (setcar tail binding)
+      ;; Remove any potential filter.
+      (if (plist-get (cdr tail) :filter)
+          (setcdr tail (plist-put (cdr tail) :filter nil))))
+    item)
+   ((and (consp (cdr item)) (stringp (cadr item)))
+    (cons (car item) (cons (cadr item) binding)))
+   (t (cons (car item) binding))))
+
+(defun keymap--merge-bindings (val1 val2)
+  "Merge bindings VAL1 and VAL2."
+  (let ((map1 (keymap--menu-item-binding val1))
+        (map2 (keymap--menu-item-binding val2)))
+    (if (not (and (keymapp map1) (keymapp map2)))
+        ;; There's nothing to merge: val1 takes precedence.
+        val1
+      (let ((map (list 'keymap map1 map2))
+            (item (if (keymapp val1) (if (keymapp val2) nil val2) val1)))
+        (keymap--menu-item-with-binding item map)))))
+
 (defun keymap-canonicalize (map)
-  "Return an equivalent keymap, without inheritance."
+  "Return a simpler equivalent keymap.
+This resolves inheritance and redefinitions.  The returned keymap
+should behave identically to a copy of KEYMAP w.r.t `lookup-key'
+and use in active keymaps and menus.
+Subkeymaps may be modified but are not canonicalized."
+  ;; FIXME: Problem with the difference between a nil binding
+  ;; that hides a binding in an inherited map and a nil binding that's ignored
+  ;; to let some further binding visible.  Currently a nil binding hides all.
+  ;; FIXME: we may want to carefully (re)order elements in case they're
+  ;; menu-entries.
   (let ((bindings ())
         (ranges ())
        (prompt (keymap-prompt map)))
     (while (keymapp map)
-      (setq map (map-keymap-internal
+      (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)))
+    ;; Create the new map.
     (setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap) prompt))
     (dolist (binding ranges)
-      ;; Treat char-ranges specially.
+      ;; Treat char-ranges specially.  FIXME: need to merge as well.
       (define-key map (vector (car binding)) (cdr binding)))
+    ;; Process the bindings starting from the end.
     (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))))
+        (push (if (not oldbind)
+                  ;; The normal case: no duplicate bindings.
+                  binding
+                ;; This is the second binding for this key.
+                (setq bindings (delq oldbind bindings))
+                (cons key (keymap--merge-bindings (cdr binding)
+                                                  (cdr oldbind))))
+              bindings)))
     (nconc map bindings)))
 
 (put 'keyboard-translate-table 'char-table-extra-slots 0)
@@ -1101,6 +1180,8 @@ is converted into a string by expressing it in decimal."
 
 (make-obsolete-variable 'define-key-rebound-commands nil "23.2")
 (make-obsolete-variable 'redisplay-end-trigger-functions 'jit-lock-register "23.1")
+(make-obsolete-variable 'deferred-action-list 'post-command-hook "24.1")
+(make-obsolete-variable 'deferred-action-function 'post-command-hook "24.1")
 (make-obsolete 'window-redisplay-end-trigger nil "23.1")
 (make-obsolete 'set-window-redisplay-end-trigger nil "23.1")
 
@@ -1181,10 +1262,10 @@ unless the optional argument APPEND is non-nil, in which case
 FUNCTION is added at the end.
 
 The optional fourth argument, LOCAL, if non-nil, says to modify
-the hook's buffer-local value rather than its default value.
-This makes the hook buffer-local if needed, and it makes t a member
-of the buffer-local value.  That acts as a flag to run the hook
-functions in the default value as well as in the local value.
+the hook's buffer-local value rather than its global value.
+This makes the hook buffer-local, and it makes t a member of the
+buffer-local value.  That acts as a flag to run the hook
+functions of the global value as well as in the local value.
 
 HOOK should be a symbol, and FUNCTION may be any valid function.  If
 HOOK is void, it is first set to nil.  If HOOK's value is a single
@@ -1256,6 +1337,67 @@ the hook's buffer-local value rather than its default value."
            (kill-local-variable hook)
          (set hook hook-value))))))
 
+(defmacro letrec (binders &rest body)
+  "Bind variables according to BINDERS then eval BODY.
+The value of the last form in BODY is returned.
+Each element of BINDERS is a list (SYMBOL VALUEFORM) which binds
+SYMBOL to the value of VALUEFORM.
+All symbols are bound before the VALUEFORMs are evalled."
+  ;; Only useful in lexical-binding mode.
+  ;; As a special-form, we could implement it more efficiently (and cleanly,
+  ;; making the vars actually unbound during evaluation of the binders).
+  (declare (debug let) (indent 1))
+  `(let ,(mapcar #'car binders)
+     ,@(mapcar (lambda (binder) `(setq ,@binder)) binders)
+     ,@body))
+
+(defmacro with-wrapper-hook (var args &rest body)
+  "Run BODY wrapped with the VAR hook.
+VAR is a special hook: its functions are called with a first argument
+which is the \"original\" code (the BODY), so the hook function can wrap
+the original function, or call it any number of times (including not calling
+it at all).  This is similar to an `around' advice.
+VAR is normally a symbol (a variable) in which case it is treated like
+a hook, with a buffer-local and a global part.  But it can also be an
+arbitrary expression.
+ARGS is a list of variables which will be passed as additional arguments
+to each function, after the initial argument, and which the first argument
+expects to receive when called."
+  (declare (indent 2) (debug t))
+  ;; We need those two gensyms because CL's lexical scoping is not available
+  ;; for function arguments :-(
+  (let ((funs (make-symbol "funs"))
+        (global (make-symbol "global"))
+        (argssym (make-symbol "args"))
+        (runrestofhook (make-symbol "runrestofhook")))
+    ;; Since the hook is a wrapper, the loop has to be done via
+    ;; recursion: a given hook function will call its parameter in order to
+    ;; continue looping.
+    `(letrec ((,runrestofhook
+               (lambda (,funs ,global ,argssym)
+                 ;; `funs' holds the functions left on the hook and `global'
+                 ;; holds the functions left on the global part of the hook
+                 ;; (in case the hook is local).
+                 (if (consp ,funs)
+                     (if (eq t (car ,funs))
+                         (funcall ,runrestofhook
+                                  (append ,global (cdr ,funs)) nil ,argssym)
+                       (apply (car ,funs)
+                              (apply-partially
+                               (lambda (,funs ,global &rest ,argssym)
+                                 (funcall ,runrestofhook ,funs ,global ,argssym))
+                               (cdr ,funs) ,global)
+                              ,argssym))
+                   ;; Once there are no more functions on the hook, run
+                   ;; the original body.
+                   (apply (lambda ,args ,@body) ,argssym)))))
+       (funcall ,runrestofhook ,var
+                ;; The global part of the hook, if any.
+                ,(if (symbolp var)
+                     `(if (local-variable-p ',var)
+                          (default-value ',var)))
+                (list ,@args)))))
+
 (defun add-to-list (list-var element &optional append compare-fn)
   "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
 The test for presence of ELEMENT is done with `equal',
@@ -1628,6 +1770,8 @@ This function makes or adds to an entry on `after-load-alist'."
     (unless elt
       (setq elt (list regexp-or-feature))
       (push elt after-load-alist))
+    ;; Make sure `form' is evalled in the current lexical/dynamic code.
+    (setq form `(funcall ',(eval `(lambda () ,form) lexical-binding)))
     (when (symbolp regexp-or-feature)
       ;; For features, the after-load-alist elements get run when `provide' is
       ;; called rather than at the end of the file.  So add an indirection to
@@ -1686,6 +1830,19 @@ This makes or adds to an entry on `after-load-alist'.
 FILE should be the name of a library, with no directory name."
   (eval-after-load file (read)))
 (make-obsolete 'eval-next-after-load `eval-after-load "23.2")
+
+(defun display-delayed-warnings ()
+  "Display delayed warnings from `delayed-warnings-list'.
+This is the default value of `delayed-warnings-hook'."
+  (dolist (warning (nreverse delayed-warnings-list))
+    (apply 'display-warning warning))
+  (setq delayed-warnings-list nil))
+
+(defvar delayed-warnings-hook '(display-delayed-warnings)
+  "Normal hook run to process delayed warnings.
+Functions in this hook should access the `delayed-warnings-list'
+variable (which see) and remove from it the warnings they process.")
+
 \f
 ;;;; Process stuff.
 
@@ -1706,27 +1863,12 @@ Signal an error if the program returns with a non-zero exit status."
          (forward-line 1))
        (nreverse lines)))))
 
-;; open-network-stream is a wrapper around make-network-process.
-
-(when (featurep 'make-network-process)
-  (defun open-network-stream (name buffer host service)
-    "Open a TCP connection for a service to a host.
-Returns a subprocess-object to represent the connection.
-Input and output work as for subprocesses; `delete-process' closes it.
-
-NAME is the name for the process.  It is modified if necessary to make
- it unique.
-BUFFER is the buffer (or buffer name) to associate with the
- process.  Process output goes at end of that buffer.  BUFFER may
- be nil, meaning that this process is not associated with any buffer.
-HOST is the name or IP address of the host to connect to.
-SERVICE is the name of the service desired, or an integer specifying
- a port number to connect to.
-
-This is a wrapper around `make-network-process', and only offers a
-subset of its functionality."
-    (make-network-process :name name :buffer buffer
-                                    :host host :service service)))
+(defun process-live-p (process)
+  "Returns non-nil if PROCESS is alive.
+A process is considered alive if its status is `run', `open',
+`listen', `connect' or `stop'."
+  (memq (process-status process)
+        '(run open listen connect stop)))
 
 ;; compatibility
 
@@ -1734,7 +1876,7 @@ subset of its functionality."
  'process-kill-without-query
  "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
  "22.1")
-(defun process-kill-without-query (process &optional flag)
+(defun process-kill-without-query (process &optional _flag)
   "Say no query needed if PROCESS is running when Emacs is exited.
 Optional second argument if non-nil says to require a query.
 Value is t if a query was formerly required."
@@ -2003,24 +2145,24 @@ If optional argument INHIBIT-KEYBOARD-QUIT is non-nil, ignore
 keyboard-quit events while waiting for a valid input."
   (unless (consp chars)
     (error "Called `read-char-choice' without valid char choices"))
-  (let ((cursor-in-echo-area t)
-       (executing-kbd-macro executing-kbd-macro)
-       char done)
-    (while (not done)
-      (unless (get-text-property 0 'face prompt)
-       (setq prompt (propertize prompt 'face 'minibuffer-prompt)))
-      (setq char (let ((inhibit-quit inhibit-keyboard-quit))
-                  (read-key prompt)))
-      (cond
-       ((not (numberp char)))
-       ((memq char chars)
-       (setq done t))
-       ((and executing-kbd-macro (= char -1))
-       ;; read-event returns -1 if we are in a kbd macro and
-       ;; there are no more events in the macro.  Attempt to
-       ;; get an event interactively.
-       (setq executing-kbd-macro nil))))
-    ;; Display the question with the answer.
+  (let (char done)
+    (let ((cursor-in-echo-area t)
+          (executing-kbd-macro executing-kbd-macro))
+      (while (not done)
+        (unless (get-text-property 0 'face prompt)
+          (setq prompt (propertize prompt 'face 'minibuffer-prompt)))
+        (setq char (let ((inhibit-quit inhibit-keyboard-quit))
+                     (read-key prompt)))
+        (cond
+         ((not (numberp char)))
+         ((memq char chars)
+          (setq done t))
+         ((and executing-kbd-macro (= char -1))
+          ;; read-event returns -1 if we are in a kbd macro and
+          ;; there are no more events in the macro.  Attempt to
+          ;; get an event interactively.
+          (setq executing-kbd-macro nil)))))
+    ;; Display the question with the answer.  But without cursor-in-echo-area.
     (message "%s%s" prompt (char-to-string char))
     char))
 
@@ -2441,27 +2583,63 @@ Note: :data and :device are currently not supported on Windows."
 
 (defun shell-quote-argument (argument)
   "Quote ARGUMENT for passing as argument to an inferior shell."
-  (if (or (eq system-type 'ms-dos)
-          (and (eq system-type 'windows-nt) (w32-shell-dos-semantics)))
-      ;; Quote using double quotes, but escape any existing quotes in
-      ;; the argument with backslashes.
-      (let ((result "")
-           (start 0)
-           end)
-       (if (or (null (string-match "[^\"]" argument))
-               (< (match-end 0) (length argument)))
-           (while (string-match "[\"]" argument start)
-             (setq end (match-beginning 0)
-                   result (concat result (substring argument start end)
-                                  "\\" (substring argument end (1+ end)))
-                   start (1+ end))))
-       (concat "\"" result (substring argument start) "\""))
+  (cond
+   ((eq system-type 'ms-dos)
+    ;; Quote using double quotes, but escape any existing quotes in
+    ;; the argument with backslashes.
+    (let ((result "")
+          (start 0)
+          end)
+      (if (or (null (string-match "[^\"]" argument))
+              (< (match-end 0) (length argument)))
+          (while (string-match "[\"]" argument start)
+            (setq end (match-beginning 0)
+                  result (concat result (substring argument start end)
+                                 "\\" (substring argument end (1+ end)))
+                  start (1+ end))))
+      (concat "\"" result (substring argument start) "\"")))
+
+   ((and (eq system-type 'windows-nt) (w32-shell-dos-semantics))
+
+    ;; First, quote argument so that CommandLineToArgvW will
+    ;; understand it.  See
+    ;; http://msdn.microsoft.com/en-us/library/17w5ykft%28v=vs.85%29.aspx
+    ;; After we perform that level of quoting, escape shell
+    ;; metacharacters so that cmd won't mangle our argument.  If the
+    ;; argument contains no double quote characters, we can just
+    ;; surround it with double quotes.  Otherwise, we need to prefix
+    ;; each shell metacharacter with a caret.
+
+    (setq argument
+          ;; escape backslashes at end of string
+          (replace-regexp-in-string
+           "\\(\\\\*\\)$"
+           "\\1\\1"
+           ;; escape backslashes and quotes in string body
+           (replace-regexp-in-string
+            "\\(\\\\*\\)\""
+            "\\1\\1\\\\\""
+            argument)))
+
+    (if (string-match "[%!\"]" argument)
+        (concat
+         "^\""
+         (replace-regexp-in-string
+          "\\([%!()\"<>&|^]\\)"
+          "^\\1"
+          argument)
+         "^\"")
+      (concat "\"" argument "\"")))
+
+   (t
     (if (equal argument "")
         "''"
       ;; Quote everything except POSIX filename characters.
       ;; This should be safe enough even for really weird shells.
-      (replace-regexp-in-string "\n" "'\n'"
-       (replace-regexp-in-string "[^-0-9a-zA-Z_./\n]" "\\\\\\&" argument)))))
+      (replace-regexp-in-string
+       "\n" "'\n'"
+       (replace-regexp-in-string "[^-0-9a-zA-Z_./\n]" "\\\\\\&" argument))))
+   ))
 
 (defun string-or-null-p (object)
   "Return t if OBJECT is a string or nil.
@@ -2480,6 +2658,14 @@ Otherwise, return nil."
        (get-char-property (1- (field-end pos)) 'field)
       raw-field)))
 
+(defun sha1 (object &optional start end binary)
+  "Return the SHA1 (Secure Hash Algorithm) of an OBJECT.
+OBJECT is either a string or a buffer.  Optional arguments START and
+END are character positions specifying which portion of OBJECT for
+computing the hash.  If BINARY is non-nil, return a string in binary
+form."
+  (secure-hash 'sha1 object start end binary))
+
 \f
 ;;;; Support for yanking and text properties.
 
@@ -2761,6 +2947,72 @@ nor the buffer list."
         (when (buffer-live-p ,old-buffer)
           (set-buffer ,old-buffer))))))
 
+(defmacro save-window-excursion (&rest body)
+  "Execute BODY, preserving window sizes and contents.
+Return the value of the last form in BODY.
+Restore which buffer appears in which window, where display starts,
+and the value of point and mark for each window.
+Also restore the choice of selected window.
+Also restore which buffer is current.
+Does not restore the value of point in current buffer.
+
+BEWARE: Most uses of this macro introduce bugs.
+E.g. it should not be used to try and prevent some code from opening
+a new window, since that window may sometimes appear in another frame,
+in which case `save-window-excursion' cannot help."
+  (declare (indent 0) (debug t))
+  (let ((c (make-symbol "wconfig")))
+    `(let ((,c (current-window-configuration)))
+       (unwind-protect (progn ,@body)
+         (set-window-configuration ,c)))))
+
+(defmacro with-output-to-temp-buffer (bufname &rest body)
+  "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
+
+This construct makes buffer BUFNAME empty before running BODY.
+It does not make the buffer current for BODY.
+Instead it binds `standard-output' to that buffer, so that output
+generated with `prin1' and similar functions in BODY goes into
+the buffer.
+
+At the end of BODY, this marks buffer BUFNAME unmodifed and displays
+it in a window, but does not select it.  The normal way to do this is
+by calling `display-buffer', then running `temp-buffer-show-hook'.
+However, if `temp-buffer-show-function' is non-nil, it calls that
+function instead (and does not run `temp-buffer-show-hook').  The
+function gets one argument, the buffer to display.
+
+The return value of `with-output-to-temp-buffer' is the value of the
+last form in BODY.  If BODY does not finish normally, the buffer
+BUFNAME is not displayed.
+
+This runs the hook `temp-buffer-setup-hook' before BODY,
+with the buffer BUFNAME temporarily current.  It runs the hook
+`temp-buffer-show-hook' after displaying buffer BUFNAME, with that
+buffer temporarily current, and the window that was used to display it
+temporarily selected.  But it doesn't run `temp-buffer-show-hook'
+if it uses `temp-buffer-show-function'."
+  (declare (debug t))
+  (let ((old-dir (make-symbol "old-dir"))
+        (buf (make-symbol "buf")))
+    `(let* ((,old-dir default-directory)
+            (,buf
+             (with-current-buffer (get-buffer-create ,bufname)
+               (prog1 (current-buffer)
+                 (kill-all-local-variables)
+                 ;; FIXME: delete_all_overlays
+                 (setq default-directory ,old-dir)
+                 (setq buffer-read-only nil)
+                 (setq buffer-file-name nil)
+                 (setq buffer-undo-list t)
+                 (let ((inhibit-read-only t)
+                       (inhibit-modification-hooks t))
+                   (erase-buffer)
+                   (run-hooks 'temp-buffer-setup-hook)))))
+            (standard-output ,buf))
+       (prog1 (progn ,@body)
+         (internal-temp-output-buffer-show ,buf)))))
+
 (defmacro with-temp-file (file &rest body)
   "Create a new buffer, evaluate BODY there, and write the buffer to FILE.
 The value returned is the value of the last form in BODY.
@@ -3316,7 +3568,7 @@ If SYNTAX is nil, return nil."
 \f
 ;;;; Text clones
 
-(defun text-clone-maintain (ol1 after beg end &optional len)
+(defun text-clone-maintain (ol1 after beg end &optional _len)
   "Propagate the changes made under the overlay OL1 to the other clones.
 This is used on the `modification-hooks' property of text clones."
   (when (and after (not undo-in-progress) (overlay-start ol1))
@@ -3516,6 +3768,8 @@ echo area updates (default is 0.2 seconds.)  If the function
 `float-time' is not present, time is not tracked at all.  If the
 OS is not capable of measuring fractions of seconds, this
 parameter is effectively rounded up."
+  (when (string-match "[[:alnum:]]\\'" message)
+    (setq message (concat message "...")))
   (unless min-time
     (setq min-time 0.2))
   (let ((reporter