Move dependencies into subdirectory

That way they don't enter the user's `load-path' when following
the installation instructions.

4 files changed, 5947 insertions, 0 deletions

diff --git a/lib/README b/lib/README
new file mode 100644
index 0000000..16766cb
--- /dev/null
+++ b/lib/README
@@ -0,0 +1,6 @@
+This folder contains external libraries that are freely distributable
+under the GNU GPL license. They may not be up to date.
+
+Emacs does not add subdirectories to the `load-path' by default.
+Therefore this directory is not covered by the installation
+instructions.
diff --git a/lib/ert.el b/lib/ert.el
new file mode 100644
index 0000000..5bd8fd0
--- /dev/null
+++ b/lib/ert.el
@@ -0,0 +1,2549 @@
+;;; ert.el --- Emacs Lisp Regression Testing
+
+;; Copyright (C) 2007-2008, 2010-2011 Free Software Foundation, Inc.
+
+;; Author: Christian Ohler <ohler@gnu.org>
+;; Keywords: lisp, tools
+
+;; This file is part of GNU Emacs.
+
+;; This program 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 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see `http://www.gnu.org/licenses/'.
+
+;;; Commentary:
+
+;; ERT is a tool for automated testing in Emacs Lisp.  Its main
+;; features are facilities for defining and running test cases and
+;; reporting the results as well as for debugging test failures
+;; interactively.
+;;
+;; The main entry points are `ert-deftest', which is similar to
+;; `defun' but defines a test, and `ert-run-tests-interactively',
+;; which runs tests and offers an interactive interface for inspecting
+;; results and debugging.  There is also
+;; `ert-run-tests-batch-and-exit' for non-interactive use.
+;;
+;; The body of `ert-deftest' forms resembles a function body, but the
+;; additional operators `should', `should-not' and `should-error' are
+;; available.  `should' is similar to cl's `assert', but signals a
+;; different error when its condition is violated that is caught and
+;; processed by ERT.  In addition, it analyzes its argument form and
+;; records information that helps debugging (`assert' tries to do
+;; something similar when its second argument SHOW-ARGS is true, but
+;; `should' is more sophisticated).  For information on `should-not'
+;; and `should-error', see their docstrings.
+;;
+;; See ERT's info manual as well as the docstrings for more details.
+;; To compile the manual, run `makeinfo ert.texinfo' in the ERT
+;; directory, then C-u M-x info ert.info in Emacs to view it.
+;;
+;; To see some examples of tests written in ERT, see its self-tests in
+;; ert-tests.el.  Some of these are tricky due to the bootstrapping
+;; problem of writing tests for a testing tool, others test simple
+;; functions and are straightforward.
+
+;;; Code:
+
+(eval-when-compile
+  (require 'cl))
+(require 'button)
+(require 'debug)
+(require 'easymenu)
+(require 'ewoc)
+(require 'find-func)
+(require 'help)
+
+
+;;; UI customization options.
+
+(defgroup ert ()
+  "ERT, the Emacs Lisp regression testing tool."
+  :prefix "ert-"
+  :group 'lisp)
+
+(defface ert-test-result-expected '((((class color) (background light))
+                                     :background "green1")
+                                    (((class color) (background dark))
+                                     :background "green3"))
+  "Face used for expected results in the ERT results buffer."
+  :group 'ert)
+
+(defface ert-test-result-unexpected '((((class color) (background light))
+                                       :background "red1")
+                                      (((class color) (background dark))
+                                       :background "red3"))
+  "Face used for unexpected results in the ERT results buffer."
+  :group 'ert)
+
+
+;;; Copies/reimplementations of cl functions.
+
+(defun ert--cl-do-remf (plist tag)
+  "Copy of `cl-do-remf'.  Modify PLIST by removing TAG."
+  (let ((p (cdr plist)))
+    (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
+    (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
+
+(defun ert--remprop (sym tag)
+  "Copy of `cl-remprop'.  Modify SYM's plist by removing TAG."
+  (let ((plist (symbol-plist sym)))
+    (if (and plist (eq tag (car plist)))
+	(progn (setplist sym (cdr (cdr plist))) t)
+      (ert--cl-do-remf plist tag))))
+
+(defun ert--remove-if-not (ert-pred ert-list)
+  "A reimplementation of `remove-if-not'.
+
+ERT-PRED is a predicate, ERT-LIST is the input list."
+  (loop for ert-x in ert-list
+        if (funcall ert-pred ert-x)
+        collect ert-x))
+
+(defun ert--intersection (a b)
+  "A reimplementation of `intersection'.  Intersect the sets A and B.
+
+Elements are compared using `eql'."
+  (loop for x in a
+        if (memql x b)
+        collect x))
+
+(defun ert--set-difference (a b)
+  "A reimplementation of `set-difference'.  Subtract the set B from the set A.
+
+Elements are compared using `eql'."
+  (loop for x in a
+        unless (memql x b)
+        collect x))
+
+(defun ert--set-difference-eq (a b)
+  "A reimplementation of `set-difference'.  Subtract the set B from the set A.
+
+Elements are compared using `eq'."
+  (loop for x in a
+        unless (memq x b)
+        collect x))
+
+(defun ert--union (a b)
+  "A reimplementation of `union'.  Compute the union of the sets A and B.
+
+Elements are compared using `eql'."
+  (append a (ert--set-difference b a)))
+
+(eval-and-compile
+  (defvar ert--gensym-counter 0))
+
+(eval-and-compile
+  (defun ert--gensym (&optional prefix)
+    "Only allows string PREFIX, not compatible with CL."
+    (unless prefix (setq prefix "G"))
+    (make-symbol (format "%s%s"
+                         prefix
+                         (prog1 ert--gensym-counter
+                           (incf ert--gensym-counter))))))
+
+(defun ert--coerce-to-vector (x)
+  "Coerce X to a vector."
+  (when (char-table-p x) (error "Not supported"))
+  (if (vectorp x)
+      x
+    (vconcat x)))
+
+(defun* ert--remove* (x list &key key test)
+  "Does not support all the keywords of remove*."
+  (unless key (setq key #'identity))
+  (unless test (setq test #'eql))
+  (loop for y in list
+        unless (funcall test x (funcall key y))
+        collect y))
+
+(defun ert--string-position (c s)
+  "Return the position of the first occurrence of C in S, or nil if none."
+  (loop for i from 0
+        for x across s
+        when (eql x c) return i))
+
+(defun ert--mismatch (a b)
+  "Return index of first element that differs between A and B.
+
+Like `mismatch'.  Uses `equal' for comparison."
+  (cond ((or (listp a) (listp b))
+         (ert--mismatch (ert--coerce-to-vector a)
+                        (ert--coerce-to-vector b)))
+        ((> (length a) (length b))
+         (ert--mismatch b a))
+        (t
+         (let ((la (length a))
+               (lb (length b)))
+           (assert (arrayp a) t)
+           (assert (arrayp b) t)
+           (assert (<= la lb) t)
+           (loop for i below la
+                 when (not (equal (aref a i) (aref b i))) return i
+                 finally (return (if (/= la lb)
+                                     la
+                                   (assert (equal a b) t)
+                                   nil)))))))
+
+(defun ert--subseq (seq start &optional end)
+  "Return a subsequence of SEQ from START to END."
+  (when (char-table-p seq) (error "Not supported"))
+  (let ((vector (substring (ert--coerce-to-vector seq) start end)))
+    (etypecase seq
+      (vector vector)
+      (string (concat vector))
+      (list (append vector nil))
+      (bool-vector (loop with result = (make-bool-vector (length vector) nil)
+                         for i below (length vector) do
+                         (setf (aref result i) (aref vector i))
+                         finally (return result)))
+      (char-table (assert nil)))))
+
+(defun ert-equal-including-properties (a b)
+  "Return t if A and B have similar structure and contents.
+
+This is like `equal-including-properties' except that it compares
+the property values of text properties structurally (by
+recursing) rather than with `eq'.  Perhaps this is what
+`equal-including-properties' should do in the first place; see
+Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'."
+  ;; This implementation is inefficient.  Rather than making it
+  ;; efficient, let's hope bug 6581 gets fixed so that we can delete
+  ;; it altogether.
+  (not (ert--explain-equal-including-properties a b)))
+
+
+;;; Defining and locating tests.
+
+;; The data structure that represents a test case.
+(defstruct ert-test
+  (name nil)
+  (documentation nil)
+  (body (assert nil))
+  (most-recent-result nil)
+  (expected-result-type ':passed)
+  (tags '()))
+
+(defun ert-test-boundp (symbol)
+  "Return non-nil if SYMBOL names a test."
+  (and (get symbol 'ert--test) t))
+
+(defun ert-get-test (symbol)
+  "If SYMBOL names a test, return that.  Signal an error otherwise."
+  (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol))
+  (get symbol 'ert--test))
+
+(defun ert-set-test (symbol definition)
+  "Make SYMBOL name the test DEFINITION, and return DEFINITION."
+  (when (eq symbol 'nil)
+    ;; We disallow nil since `ert-test-at-point' and related functions
+    ;; want to return a test name, but also need an out-of-band value
+    ;; on failure.  Nil is the most natural out-of-band value; using 0
+    ;; or "" or signalling an error would be too awkward.
+    ;;
+    ;; Note that nil is still a valid value for the `name' slot in
+    ;; ert-test objects.  It designates an anonymous test.
+    (error "Attempt to define a test named nil"))
+  (put symbol 'ert--test definition)
+  definition)
+
+(defun ert-make-test-unbound (symbol)
+  "Make SYMBOL name no test.  Return SYMBOL."
+  (ert--remprop symbol 'ert--test)
+  symbol)
+
+(defun ert--parse-keys-and-body (keys-and-body)
+  "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body.
+
+KEYS-AND-BODY should have the form of a property list, with the
+exception that only keywords are permitted as keys and that the
+tail -- the body -- is a list of forms that does not start with a
+keyword.
+
+Returns a two-element list containing the keys-and-values plist
+and the body."
+  (let ((extracted-key-accu '())
+        (remaining keys-and-body))
+    (while (and (consp remaining) (keywordp (first remaining)))
+      (let ((keyword (pop remaining)))
+        (unless (consp remaining)
+          (error "Value expected after keyword %S in %S"
+                 keyword keys-and-body))
+        (when (assoc keyword extracted-key-accu)
+          (warn "Keyword %S appears more than once in %S" keyword
+                keys-and-body))
+        (push (cons keyword (pop remaining)) extracted-key-accu)))
+    (setq extracted-key-accu (nreverse extracted-key-accu))
+    (list (loop for (key . value) in extracted-key-accu
+                collect key
+                collect value)
+          remaining)))
+
+;;;###autoload
+(defmacro* ert-deftest (name () &body docstring-keys-and-body)
+  "Define NAME (a symbol) as a test.
+
+BODY is evaluated as a `progn' when the test is run.  It should
+signal a condition on failure or just return if the test passes.
+
+`should', `should-not' and `should-error' are useful for
+assertions in BODY.
+
+Use `ert' to run tests interactively.
+
+Tests that are expected to fail can be marked as such
+using :expected-result.  See `ert-test-result-type-p' for a
+description of valid values for RESULT-TYPE.
+
+\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
+\[:tags '(TAG...)] BODY...)"
+  (declare (debug (&define :name test
+                           name sexp [&optional stringp]
+			   [&rest keywordp sexp] def-body))
+           (doc-string 3)
+           (indent 2))
+  (let ((documentation nil)
+        (documentation-supplied-p nil))
+    (when (stringp (first docstring-keys-and-body))
+      (setq documentation (pop docstring-keys-and-body)
+            documentation-supplied-p t))
+    (destructuring-bind ((&key (expected-result nil expected-result-supplied-p)
+                               (tags nil tags-supplied-p))
+                         body)
+        (ert--parse-keys-and-body docstring-keys-and-body)
+      `(progn
+         (ert-set-test ',name
+                       (make-ert-test
+                        :name ',name
+                        ,@(when documentation-supplied-p
+                            `(:documentation ,documentation))
+                        ,@(when expected-result-supplied-p
+                            `(:expected-result-type ,expected-result))
+                        ,@(when tags-supplied-p
+                            `(:tags ,tags))
+                        :body (lambda () ,@body)))
+         ;; This hack allows `symbol-file' to associate `ert-deftest'
+         ;; forms with files, and therefore enables `find-function' to
+         ;; work with tests.  However, it leads to warnings in
+         ;; `unload-feature', which doesn't know how to undefine tests
+         ;; and has no mechanism for extension.
+         (push '(ert-deftest . ,name) current-load-list)
+         ',name))))
+
+;; We use these `put' forms in addition to the (declare (indent)) in
+;; the defmacro form since the `declare' alone does not lead to
+;; correct indentation before the .el/.elc file is loaded.
+;; Autoloading these `put' forms solves this.
+;;;###autoload
+(progn
+  ;; TODO(ohler): Figure out what these mean and make sure they are correct.
+  (put 'ert-deftest 'lisp-indent-function 2)
+  (put 'ert-info 'lisp-indent-function 1))
+
+(defvar ert--find-test-regexp
+  (concat "^\\s-*(ert-deftest"
+          find-function-space-re
+          "%s\\(\\s-\\|$\\)")
+  "The regexp the `find-function' mechanisms use for finding test definitions.")
+
+
+(put 'ert-test-failed 'error-conditions '(error ert-test-failed))
+(put 'ert-test-failed 'error-message "Test failed")
+
+(defun ert-pass ()
+  "Terminate the current test and mark it passed.  Does not return."
+  (throw 'ert--pass nil))
+
+(defun ert-fail (data)
+  "Terminate the current test and mark it failed.  Does not return.
+DATA is displayed to the user and should state the reason of the failure."
+  (signal 'ert-test-failed (list data)))
+
+
+;;; The `should' macros.
+
+(defvar ert--should-execution-observer nil)
+
+(defun ert--signal-should-execution (form-description)
+  "Tell the current `should' form observer (if any) about FORM-DESCRIPTION."
+  (when ert--should-execution-observer
+    (funcall ert--should-execution-observer form-description)))
+
+(defun ert--special-operator-p (thing)
+  "Return non-nil if THING is a symbol naming a special operator."
+  (and (symbolp thing)
+       (let ((definition (indirect-function thing t)))
+         (and (subrp definition)
+              (eql (cdr (subr-arity definition)) 'unevalled)))))
+
+(defun ert--expand-should-1 (whole form inner-expander)
+  "Helper function for the `should' macro and its variants."
+  (let ((form
+         ;; If `cl-macroexpand' isn't bound, the code that we're
+         ;; compiling doesn't depend on cl and thus doesn't need an
+         ;; environment arg for `macroexpand'.
+         (if (fboundp 'cl-macroexpand)
+             ;; Suppress warning about run-time call to cl funtion: we
+             ;; only call it if it's fboundp.
+             (with-no-warnings
+               (cl-macroexpand form (and (boundp 'cl-macro-environment)
+                                         cl-macro-environment)))
+           (macroexpand form))))
+    (cond
+     ((or (atom form) (ert--special-operator-p (car form)))
+      (let ((value (ert--gensym "value-")))
+        `(let ((,value (ert--gensym "ert-form-evaluation-aborted-")))
+           ,(funcall inner-expander
+                     `(setq ,value ,form)
+                     `(list ',whole :form ',form :value ,value)
+                     value)
+           ,value)))
+     (t
+      (let ((fn-name (car form))
+            (arg-forms (cdr form)))
+        (assert (or (symbolp fn-name)
+                    (and (consp fn-name)
+                         (eql (car fn-name) 'lambda)
+                         (listp (cdr fn-name)))))
+        (let ((fn (ert--gensym "fn-"))
+              (args (ert--gensym "args-"))
+              (value (ert--gensym "value-"))
+              (default-value (ert--gensym "ert-form-evaluation-aborted-")))
+          `(let ((,fn (function ,fn-name))
+                 (,args (list ,@arg-forms)))
+             (let ((,value ',default-value))
+               ,(funcall inner-expander
+                         `(setq ,value (apply ,fn ,args))
+                         `(nconc (list ',whole)
+                                 (list :form `(,,fn ,@,args))
+                                 (unless (eql ,value ',default-value)
+                                   (list :value ,value))
+                                 (let ((-explainer-
+                                        (and (symbolp ',fn-name)
+                                             (get ',fn-name 'ert-explainer))))
+                                   (when -explainer-
+                                     (list :explanation
+                                           (apply -explainer- ,args)))))
+                         value)
+               ,value))))))))
+
+(defun ert--expand-should (whole form inner-expander)
+  "Helper function for the `should' macro and its variants.
+
+Analyzes FORM and returns an expression that has the same
+semantics under evaluation but records additional debugging
+information.
+
+INNER-EXPANDER should be a function and is called with two
+arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM
+is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is
+an expression that returns a description of FORM.  INNER-EXPANDER
+should return code that calls INNER-FORM and performs the checks
+and error signalling specific to the particular variant of
+`should'.  The code that INNER-EXPANDER returns must not call
+FORM-DESCRIPTION-FORM before it has called INNER-FORM."
+  (lexical-let ((inner-expander inner-expander))
+    (ert--expand-should-1
+     whole form
+     (lambda (inner-form form-description-form value-var)
+       (let ((form-description (ert--gensym "form-description-")))
+         `(let (,form-description)
+            ,(funcall inner-expander
+                      `(unwind-protect
+                           ,inner-form
+                         (setq ,form-description ,form-description-form)
+                         (ert--signal-should-execution ,form-description))
+                      `,form-description
+                      value-var)))))))
+
+(defmacro* should (form)
+  "Evaluate FORM.  If it returns nil, abort the current test as failed.
+
+Returns the value of FORM."
+  (ert--expand-should `(should ,form) form
+                      (lambda (inner-form form-description-form value-var)
+                        `(unless ,inner-form
+                           (ert-fail ,form-description-form)))))
+
+(defmacro* should-not (form)
+  "Evaluate FORM.  If it returns non-nil, abort the current test as failed.
+
+Returns nil."
+  (ert--expand-should `(should-not ,form) form
+                      (lambda (inner-form form-description-form value-var)
+                        `(unless (not ,inner-form)
+                           (ert-fail ,form-description-form)))))
+
+(defun ert--should-error-handle-error (form-description-fn
+                                       condition type exclude-subtypes)
+  "Helper function for `should-error'.
+
+Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES,
+and aborts the current test as failed if it doesn't."
+  (let ((signalled-conditions (get (car condition) 'error-conditions))
+        (handled-conditions (etypecase type
+                              (list type)
+                              (symbol (list type)))))
+    (assert signalled-conditions)
+    (unless (ert--intersection signalled-conditions handled-conditions)
+      (ert-fail (append
+                 (funcall form-description-fn)
+                 (list
+                  :condition condition
+                  :fail-reason (concat "the error signalled did not"
+                                       " have the expected type")))))
+    (when exclude-subtypes
+      (unless (member (car condition) handled-conditions)
+        (ert-fail (append
+                   (funcall form-description-fn)
+                   (list
+                    :condition condition
+                    :fail-reason (concat "the error signalled was a subtype"
+                                         " of the expected type"))))))))
+
+;; FIXME: The expansion will evaluate the keyword args (if any) in
+;; nonstandard order.
+(defmacro* should-error (form &rest keys &key type exclude-subtypes)
+  "Evaluate FORM and check that it signals an error.
+
+The error signalled needs to match TYPE.  TYPE should be a list
+of condition names.  (It can also be a non-nil symbol, which is
+equivalent to a singleton list containing that symbol.)  If
+EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its
+condition names is an element of TYPE.  If EXCLUDE-SUBTYPES is
+non-nil, the error matches TYPE if it is an element of TYPE.
+
+If the error matches, returns (ERROR-SYMBOL . DATA) from the
+error.  If not, or if no error was signalled, abort the test as
+failed."
+  (unless type (setq type ''error))
+  (ert--expand-should
+   `(should-error ,form ,@keys)
+   form
+   (lambda (inner-form form-description-form value-var)
+     (let ((errorp (ert--gensym "errorp"))
+           (form-description-fn (ert--gensym "form-description-fn-")))
+       `(let ((,errorp nil)
+              (,form-description-fn (lambda () ,form-description-form)))
+          (condition-case -condition-
+              ,inner-form
+            ;; We can't use ,type here because we want to evaluate it.
+            (error
+             (setq ,errorp t)
+             (ert--should-error-handle-error ,form-description-fn
+                                             -condition-
+                                             ,type ,exclude-subtypes)
+             (setq ,value-var -condition-)))
+          (unless ,errorp
+            (ert-fail (append
+                       (funcall ,form-description-fn)
+                       (list
+                        :fail-reason "did not signal an error")))))))))
+
+
+;;; Explanation of `should' failures.
+
+;; TODO(ohler): Rework explanations so that they are displayed in a
+;; similar way to `ert-info' messages; in particular, allow text
+;; buttons in explanations that give more detail or open an ediff
+;; buffer.  Perhaps explanations should be reported through `ert-info'
+;; rather than as part of the condition.
+
+(defun ert--proper-list-p (x)
+  "Return non-nil if X is a proper list, nil otherwise."
+  (loop
+   for firstp = t then nil
+   for fast = x then (cddr fast)
+   for slow = x then (cdr slow) do
+   (when (null fast) (return t))
+   (when (not (consp fast)) (return nil))
+   (when (null (cdr fast)) (return t))
+   (when (not (consp (cdr fast))) (return nil))
+   (when (and (not firstp) (eq fast slow)) (return nil))))
+
+(defun ert--explain-format-atom (x)
+  "Format the atom X for `ert--explain-equal'."
+  (typecase x
+    (fixnum (list x (format "#x%x" x) (format "?%c" x)))
+    (t x)))
+
+(defun ert--explain-equal-rec (a b)
+  "Returns a programmer-readable explanation of why A and B are not `equal'.
+
+Returns nil if they are."
+  (if (not (equal (type-of a) (type-of b)))
+      `(different-types ,a ,b)
+    (etypecase a
+      (cons
+       (let ((a-proper-p (ert--proper-list-p a))
+             (b-proper-p (ert--proper-list-p b)))
+         (if (not (eql (not a-proper-p) (not b-proper-p)))
+             `(one-list-proper-one-improper ,a ,b)
+           (if a-proper-p
+               (if (not (equal (length a) (length b)))
+                   `(proper-lists-of-different-length ,(length a) ,(length b)
+                                                      ,a ,b
+                                                      first-mismatch-at
+                                                      ,(ert--mismatch a b))
+                 (loop for i from 0
+                       for ai in a
+                       for bi in b
+                       for xi = (ert--explain-equal-rec ai bi)
+                       do (when xi (return `(list-elt ,i ,xi)))
+                       finally (assert (equal a b) t)))
+             (let ((car-x (ert--explain-equal-rec (car a) (car b))))
+               (if car-x
+                   `(car ,car-x)
+                 (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b))))
+                   (if cdr-x
+                       `(cdr ,cdr-x)
+                     (assert (equal a b) t)
+                     nil))))))))
+      (array (if (not (equal (length a) (length b)))
+                 `(arrays-of-different-length ,(length a) ,(length b)
+                                              ,a ,b
+                                              ,@(unless (char-table-p a)
+                                                  `(first-mismatch-at
+                                                    ,(ert--mismatch a b))))
+               (loop for i from 0
+                     for ai across a
+                     for bi across b
+                     for xi = (ert--explain-equal-rec ai bi)
+                     do (when xi (return `(array-elt ,i ,xi)))
+                     finally (assert (equal a b) t))))
+      (atom (if (not (equal a b))
+                (if (and (symbolp a) (symbolp b) (string= a b))
+                    `(different-symbols-with-the-same-name ,a ,b)
+                  `(different-atoms ,(ert--explain-format-atom a)
+                                    ,(ert--explain-format-atom b)))
+              nil)))))
+
+(defun ert--explain-equal (a b)
+  "Explainer function for `equal'."
+  ;; Do a quick comparison in C to avoid running our expensive
+  ;; comparison when possible.
+  (if (equal a b)
+      nil
+    (ert--explain-equal-rec a b)))
+(put 'equal 'ert-explainer 'ert--explain-equal)
+
+(defun ert--significant-plist-keys (plist)
+  "Return the keys of PLIST that have non-null values, in order."
+  (assert (zerop (mod (length plist) 2)) t)
+  (loop for (key value . rest) on plist by #'cddr
+        unless (or (null value) (memq key accu)) collect key into accu
+        finally (return accu)))
+
+(defun ert--plist-difference-explanation (a b)
+  "Return a programmer-readable explanation of why A and B are different plists.
+
+Returns nil if they are equivalent, i.e., have the same value for
+each key, where absent values are treated as nil.  The order of
+key/value pairs in each list does not matter."
+  (assert (zerop (mod (length a) 2)) t)
+  (assert (zerop (mod (length b) 2)) t)
+  ;; Normalizing the plists would be another way to do this but it
+  ;; requires a total ordering on all lisp objects (since any object
+  ;; is valid as a text property key).  Perhaps defining such an
+  ;; ordering is useful in other contexts, too, but it's a lot of
+  ;; work, so let's punt on it for now.
+  (let* ((keys-a (ert--significant-plist-keys a))
+         (keys-b (ert--significant-plist-keys b))
+         (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b))
+         (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a)))
+    (flet ((explain-with-key (key)
+             (let ((value-a (plist-get a key))
+                   (value-b (plist-get b key)))
+               (assert (not (equal value-a value-b)) t)
+               `(different-properties-for-key
+                 ,key ,(ert--explain-equal-including-properties value-a
+                                                                value-b)))))
+      (cond (keys-in-a-not-in-b
+             (explain-with-key (first keys-in-a-not-in-b)))
+            (keys-in-b-not-in-a
+             (explain-with-key (first keys-in-b-not-in-a)))
+            (t
+             (loop for key in keys-a
+                   when (not (equal (plist-get a key) (plist-get b key)))
+                   return (explain-with-key key)))))))
+
+(defun ert--abbreviate-string (s len suffixp)
+  "Shorten string S to at most LEN chars.
+
+If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix."
+  (let ((n (length s)))
+    (cond ((< n len)
+           s)
+          (suffixp
+           (substring s (- n len)))
+          (t
+           (substring s 0 len)))))
+
+;; TODO(ohler): Once bug 6581 is fixed, rename this to
+;; `ert--explain-equal-including-properties-rec' and add a fast-path
+;; wrapper like `ert--explain-equal'.
+(defun ert--explain-equal-including-properties (a b)
+  "Explainer function for `ert-equal-including-properties'.
+
+Returns a programmer-readable explanation of why A and B are not
+`ert-equal-including-properties', or nil if they are."
+  (if (not (equal a b))
+      (ert--explain-equal a b)
+    (assert (stringp a) t)
+    (assert (stringp b) t)
+    (assert (eql (length a) (length b)) t)
+    (loop for i from 0 to (length a)
+          for props-a = (text-properties-at i a)
+          for props-b = (text-properties-at i b)
+          for difference = (ert--plist-difference-explanation props-a props-b)
+          do (when difference
+               (return `(char ,i ,(substring-no-properties a i (1+ i))
+                              ,difference
+                              context-before
+                              ,(ert--abbreviate-string
+                                (substring-no-properties a 0 i)
+                                10 t)
+                              context-after
+                              ,(ert--abbreviate-string
+                                (substring-no-properties a (1+ i))
+                                10 nil))))
+          ;; TODO(ohler): Get `equal-including-properties' fixed in
+          ;; Emacs, delete `ert-equal-including-properties', and
+          ;; re-enable this assertion.
+          ;;finally (assert (equal-including-properties a b) t)
+          )))
+(put 'ert-equal-including-properties
+     'ert-explainer
+     'ert--explain-equal-including-properties)
+
+
+;;; Implementation of `ert-info'.
+
+;; TODO(ohler): The name `info' clashes with
+;; `ert--test-execution-info'.  One or both should be renamed.
+(defvar ert--infos '()
+  "The stack of `ert-info' infos that currently apply.
+
+Bound dynamically.  This is a list of (PREFIX . MESSAGE) pairs.")
+
+(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: "))
+                     &body body)
+  "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails.
+
+To be used within ERT tests.  MESSAGE-FORM should evaluate to a
+string that will be displayed together with the test result if
+the test fails.  PREFIX-FORM should evaluate to a string as well
+and is displayed in front of the value of MESSAGE-FORM."
+  (declare (debug ((form &rest [sexp form]) body))
+	   (indent 1))
+  `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos)))
+     ,@body))
+
+
+
+;;; Facilities for running a single test.
+
+(defvar ert-debug-on-error nil
+  "Non-nil means enter debugger when a test fails or terminates with an error.")
+
+;; The data structures that represent the result of running a test.
+(defstruct ert-test-result
+  (messages nil)
+  (should-forms nil)
+  )
+(defstruct (ert-test-passed (:include ert-test-result)))
+(defstruct (ert-test-result-with-condition (:include ert-test-result))
+  (condition (assert nil))
+  (backtrace (assert nil))
+  (infos (assert nil)))
+(defstruct (ert-test-quit (:include ert-test-result-with-condition)))
+(defstruct (ert-test-failed (:include ert-test-result-with-condition)))
+(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result)))
+
+
+(defun ert--record-backtrace ()
+  "Record the current backtrace (as a list) and return it."
+  ;; Since the backtrace is stored in the result object, result
+  ;; objects must only be printed with appropriate limits
+  ;; (`print-level' and `print-length') in place.  For interactive
+  ;; use, the cost of ensuring this possibly outweighs the advantage
+  ;; of storing the backtrace for
+  ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we
+  ;; already have `ert-results-rerun-test-debugging-errors-at-point'.
+  ;; For batch use, however, printing the backtrace may be useful.
+  (loop
+   ;; 6 is the number of frames our own debugger adds (when
+   ;; compiled; more when interpreted).  FIXME: Need to describe a
+   ;; procedure for determining this constant.
+   for i from 6
+   for frame = (backtrace-frame i)
+   while frame
+   collect frame))
+
+(defun ert--print-backtrace (backtrace)
+  "Format the backtrace BACKTRACE to the current buffer."
+  ;; This is essentially a reimplementation of Fbacktrace
+  ;; (src/eval.c), but for a saved backtrace, not the current one.
+  (let ((print-escape-newlines t)
+        (print-level 8)
+        (print-length 50))
+    (dolist (frame backtrace)
+      (ecase (first frame)
+        ((nil)
+         ;; Special operator.
+         (destructuring-bind (special-operator &rest arg-forms)
+             (cdr frame)
+           (insert
+            (format "  %S\n" (list* special-operator arg-forms)))))
+        ((t)
+         ;; Function call.
+         (destructuring-bind (fn &rest args) (cdr frame)
+           (insert (format "  %S(" fn))
+           (loop for firstp = t then nil
+                 for arg in args do
+                 (unless firstp
+                   (insert " "))
+                 (insert (format "%S" arg)))
+           (insert ")\n")))))))
+
+;; A container for the state of the execution of a single test and
+;; environment data needed during its execution.
+(defstruct ert--test-execution-info
+  (test (assert nil))
+  (result (assert nil))
+  ;; A thunk that may be called when RESULT has been set to its final
+  ;; value and test execution should be terminated.  Should not
+  ;; return.
+  (exit-continuation (assert nil))
+  ;; The binding of `debugger' outside of the execution of the test.
+  next-debugger
+  ;; The binding of `ert-debug-on-error' that is in effect for the
+  ;; execution of the current test.  We store it to avoid being
+  ;; affected by any new bindings the test itself may establish.  (I
+  ;; don't remember whether this feature is important.)
+  ert-debug-on-error)
+
+(defun ert--run-test-debugger (info debugger-args)
+  "During a test run, `debugger' is bound to a closure that calls this function.
+
+This function records failures and errors and either terminates
+the test silently or calls the interactive debugger, as
+appropriate.
+
+INFO is the ert--test-execution-info corresponding to this test
+run.  DEBUGGER-ARGS are the arguments to `debugger'."
+  (destructuring-bind (first-debugger-arg &rest more-debugger-args)
+      debugger-args
+    (ecase first-debugger-arg
+      ((lambda debug t exit nil)
+       (apply (ert--test-execution-info-next-debugger info) debugger-args))
+      (error
+       (let* ((condition (first more-debugger-args))
+              (type (case (car condition)
+                      ((quit) 'quit)
+                      (otherwise 'failed)))
+              (backtrace (ert--record-backtrace))
+              (infos (reverse ert--infos)))
+         (setf (ert--test-execution-info-result info)
+               (ecase type
+                 (quit
+                  (make-ert-test-quit :condition condition
+                                      :backtrace backtrace
+                                      :infos infos))
+                 (failed
+                  (make-ert-test-failed :condition condition
+                                        :backtrace backtrace
+                                        :infos infos))))
+         ;; Work around Emacs' heuristic (in eval.c) for detecting
+         ;; errors in the debugger.
+         (incf num-nonmacro-input-events)
+         ;; FIXME: We should probably implement more fine-grained
+         ;; control a la non-t `debug-on-error' here.
+         (cond
+          ((ert--test-execution-info-ert-debug-on-error info)
+           (apply (ert--test-execution-info-next-debugger info) debugger-args))
+          (t))
+         (funcall (ert--test-execution-info-exit-continuation info)))))))
+
+(defun ert--run-test-internal (ert-test-execution-info)
+  "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO.
+
+This mainly sets up debugger-related bindings."
+  (lexical-let ((info ert-test-execution-info))
+    (setf (ert--test-execution-info-next-debugger info) debugger
+          (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error)
+    (catch 'ert--pass
+      ;; For now, each test gets its own temp buffer and its own
+      ;; window excursion, just to be safe.  If this turns out to be
+      ;; too expensive, we can remove it.
+      (with-temp-buffer
+        (save-window-excursion
+          (let ((debugger (lambda (&rest debugger-args)
+                            (ert--run-test-debugger info debugger-args)))
+                (debug-on-error t)
+                (debug-on-quit t)
+                ;; FIXME: Do we need to store the old binding of this
+                ;; and consider it in `ert--run-test-debugger'?
+                (debug-ignored-errors nil)
+                (ert--infos '()))
+            (funcall (ert-test-body (ert--test-execution-info-test info))))))
+      (ert-pass))
+    (setf (ert--test-execution-info-result info) (make-ert-test-passed)))
+  nil)
+
+(defun ert--force-message-log-buffer-truncation ()
+  "Immediately truncate *Messages* buffer according to `message-log-max'.
+
+This can be useful after reducing the value of `message-log-max'."
+  (with-current-buffer (get-buffer-create "*Messages*")
+    ;; This is a reimplementation of this part of message_dolog() in xdisp.c:
+    ;; if (NATNUMP (Vmessage_log_max))
+    ;;   {
+    ;;     scan_newline (Z, Z_BYTE, BEG, BEG_BYTE,
+    ;;                   -XFASTINT (Vmessage_log_max) - 1, 0);
+    ;;     del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0);
+    ;;   }
+    (when (and (integerp message-log-max) (>= message-log-max 0))
+      (let ((begin (point-min))
+            (end (save-excursion
+                   (goto-char (point-max))
+                   (forward-line (- message-log-max))
+                   (point))))
+        (delete-region begin end)))))
+
+(defvar ert--running-tests nil
+  "List of tests that are currently in execution.
+
+This list is empty while no test is running, has one element
+while a test is running, two elements while a test run from
+inside a test is running, etc.  The list is in order of nesting,
+innermost test first.
+
+The elements are of type `ert-test'.")
+
+(defun ert-run-test (ert-test)
+  "Run ERT-TEST.
+
+Returns the result and stores it in ERT-TEST's `most-recent-result' slot."
+  (setf (ert-test-most-recent-result ert-test) nil)
+  (block error
+    (lexical-let ((begin-marker
+                   (with-current-buffer (get-buffer-create "*Messages*")
+                     (set-marker (make-marker) (point-max)))))
+      (unwind-protect
+          (lexical-let ((info (make-ert--test-execution-info
+                               :test ert-test
+                               :result
+                               (make-ert-test-aborted-with-non-local-exit)
+                               :exit-continuation (lambda ()
+                                                    (return-from error nil))))
+                        (should-form-accu (list)))
+            (unwind-protect
+                (let ((ert--should-execution-observer
+                       (lambda (form-description)
+                         (push form-description should-form-accu)))
+                      (message-log-max t)
+                      (ert--running-tests (cons ert-test ert--running-tests)))
+                  (ert--run-test-internal info))
+              (let ((result (ert--test-execution-info-result info)))
+                (setf (ert-test-result-messages result)
+                      (with-current-buffer (get-buffer-create "*Messages*")
+                        (buffer-substring begin-marker (point-max))))
+                (ert--force-message-log-buffer-truncation)
+                (setq should-form-accu (nreverse should-form-accu))
+                (setf (ert-test-result-should-forms result)
+                      should-form-accu)
+                (setf (ert-test-most-recent-result ert-test) result))))
+        (set-marker begin-marker nil))))
+  (ert-test-most-recent-result ert-test))
+
+(defun ert-running-test ()
+  "Return the top-level test currently executing."
+  (car (last ert--running-tests)))
+
+
+;;; Test selectors.
+
+(defun ert-test-result-type-p (result result-type)
+  "Return non-nil if RESULT matches type RESULT-TYPE.
+
+Valid result types:
+
+nil -- Never matches.
+t -- Always matches.
+:failed, :passed -- Matches corresponding results.
+\(and TYPES...\) -- Matches if all TYPES match.
+\(or TYPES...\) -- Matches if some TYPES match.
+\(not TYPE\) -- Matches if TYPE does not match.
+\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with
+                           RESULT."
+  ;; It would be easy to add `member' and `eql' types etc., but I
+  ;; haven't bothered yet.
+  (etypecase result-type
+    ((member nil) nil)
+    ((member t) t)
+    ((member :failed) (ert-test-failed-p result))
+    ((member :passed) (ert-test-passed-p result))
+    (cons
+     (destructuring-bind (operator &rest operands) result-type
+       (ecase operator
+         (and
+          (case (length operands)
+            (0 t)
+            (t
+             (and (ert-test-result-type-p result (first operands))
+                  (ert-test-result-type-p result `(and ,@(rest operands)))))))
+         (or
+          (case (length operands)
+            (0 nil)
+            (t
+             (or (ert-test-result-type-p result (first operands))
+                 (ert-test-result-type-p result `(or ,@(rest operands)))))))
+         (not
+          (assert (eql (length operands) 1))
+          (not (ert-test-result-type-p result (first operands))))
+         (satisfies
+          (assert (eql (length operands) 1))
+          (funcall (first operands) result)))))))
+
+(defun ert-test-result-expected-p (test result)
+  "Return non-nil if TEST's expected result type matches RESULT."
+  (ert-test-result-type-p result (ert-test-expected-result-type test)))
+
+(defun ert-select-tests (selector universe)
+  "Return the tests that match SELECTOR.
+
+UNIVERSE specifies the set of tests to select from; it should be
+a list of tests, or t, which refers to all tests named by symbols
+in `obarray'.
+
+Returns the set of tests as a list.
+
+Valid selectors:
+
+nil -- Selects the empty set.
+t -- Selects UNIVERSE.
+:new -- Selects all tests that have not been run yet.
+:failed, :passed -- Select tests according to their most recent result.
+:expected, :unexpected -- Select tests according to their most recent result.
+a string -- Selects all tests that have a name that matches the string,
+            a regexp.
+a test -- Selects that test.
+a symbol -- Selects the test that the symbol names, errors if none.
+\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests.
+\(eql TEST\) -- Selects TEST, a test or a symbol naming a test.
+\(and SELECTORS...\) -- Selects the tests that match all SELECTORS.
+\(or SELECTORS...\) -- Selects the tests that match any SELECTOR.
+\(not SELECTOR\) -- Selects all tests that do not match SELECTOR.
+\(tag TAG) -- Selects all tests that have TAG on their tags list.
+\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE.
+
+Only selectors that require a superset of tests, such
+as (satisfies ...), strings, :new, etc. make use of UNIVERSE.
+Selectors that do not, such as \(member ...\), just return the
+set implied by them without checking whether it is really
+contained in UNIVERSE."
+  ;; This code needs to match the etypecase in
+  ;; `ert-insert-human-readable-selector'.
+  (etypecase selector
+    ((member nil) nil)
+    ((member t) (etypecase universe
+                  (list universe)
+                  ((member t) (ert-select-tests "" universe))))
+    ((member :new) (ert-select-tests
+                    `(satisfies ,(lambda (test)
+                                   (null (ert-test-most-recent-result test))))
+                    universe))
+    ((member :failed) (ert-select-tests
+                       `(satisfies ,(lambda (test)
+                                      (ert-test-result-type-p
+                                       (ert-test-most-recent-result test)
+                                       ':failed)))
+                       universe))
+    ((member :passed) (ert-select-tests
+                       `(satisfies ,(lambda (test)
+                                      (ert-test-result-type-p
+                                       (ert-test-most-recent-result test)
+                                       ':passed)))
+                       universe))
+    ((member :expected) (ert-select-tests
+                         `(satisfies
+                           ,(lambda (test)
+                              (ert-test-result-expected-p
+                               test
+                               (ert-test-most-recent-result test))))
+                         universe))
+    ((member :unexpected) (ert-select-tests `(not :expected) universe))
+    (string
+     (etypecase universe
+       ((member t) (mapcar #'ert-get-test
+                           (apropos-internal selector #'ert-test-boundp)))
+       (list (ert--remove-if-not (lambda (test)
+                                   (and (ert-test-name test)
+                                        (string-match selector
+                                                      (ert-test-name test))))
+                                 universe))))
+    (ert-test (list selector))
+    (symbol
+     (assert (ert-test-boundp selector))
+     (list (ert-get-test selector)))
+    (cons
+     (destructuring-bind (operator &rest operands) selector
+       (ecase operator
+         (member
+          (mapcar (lambda (purported-test)
+                    (etypecase purported-test
+                      (symbol (assert (ert-test-boundp purported-test))
+                              (ert-get-test purported-test))
+                      (ert-test purported-test)))
+                  operands))
+         (eql
+          (assert (eql (length operands) 1))
+          (ert-select-tests `(member ,@operands) universe))
+         (and
+          ;; Do these definitions of AND, NOT and OR satisfy de
+          ;; Morgan's laws?  Should they?
+          (case (length operands)
+            (0 (ert-select-tests 't universe))
+            (t (ert-select-tests `(and ,@(rest operands))
+                                 (ert-select-tests (first operands)
+                                                   universe)))))
+         (not
+          (assert (eql (length operands) 1))
+          (let ((all-tests (ert-select-tests 't universe)))
+            (ert--set-difference all-tests
+                                 (ert-select-tests (first operands)
+                                                   all-tests))))
+         (or
+          (case (length operands)
+            (0 (ert-select-tests 'nil universe))
+            (t (ert--union (ert-select-tests (first operands) universe)
+                           (ert-select-tests `(or ,@(rest operands))
+                                             universe)))))
+         (tag
+          (assert (eql (length operands) 1))
+          (let ((tag (first operands)))
+            (ert-select-tests `(satisfies
+                                ,(lambda (test)
+                                   (member tag (ert-test-tags test))))
+                              universe)))
+         (satisfies
+          (assert (eql (length operands) 1))
+          (ert--remove-if-not (first operands)
+                              (ert-select-tests 't universe))))))))
+
+(defun ert--insert-human-readable-selector (selector)
+  "Insert a human-readable presentation of SELECTOR into the current buffer."
+  ;; This is needed to avoid printing the (huge) contents of the
+  ;; `backtrace' slot of the result objects in the
+  ;; `most-recent-result' slots of test case objects in (eql ...) or
+  ;; (member ...) selectors.
+  (labels ((rec (selector)
+             ;; This code needs to match the etypecase in `ert-select-tests'.
+             (etypecase selector
+               ((or (member nil t
+                            :new :failed :passed
+                            :expected :unexpected)
+                    string
+                    symbol)
+                selector)
+               (ert-test
+                (if (ert-test-name selector)
+                    (make-symbol (format "<%S>" (ert-test-name selector)))
+                  (make-symbol "<unnamed test>")))
+               (cons
+                (destructuring-bind (operator &rest operands) selector
+                  (ecase operator
+                    ((member eql and not or)
+                     `(,operator ,@(mapcar #'rec operands)))
+                    ((member tag satisfies)
+                     selector)))))))
+    (insert (format "%S" (rec selector)))))
+
+
+;;; Facilities for running a whole set of tests.
+
+;; The data structure that contains the set of tests being executed
+;; during one particular test run, their results, the state of the
+;; execution, and some statistics.
+;;
+;; The data about results and expected results of tests may seem
+;; redundant here, since the test objects also carry such information.
+;; However, the information in the test objects may be more recent, it
+;; may correspond to a different test run.  We need the information
+;; that corresponds to this run in order to be able to update the
+;; statistics correctly when a test is re-run interactively and has a
+;; different result than before.
+(defstruct ert--stats
+  (selector (assert nil))
+  ;; The tests, in order.
+  (tests (assert nil) :type vector)
+  ;; A map of test names (or the test objects themselves for unnamed
+  ;; tests) to indices into the `tests' vector.
+  (test-map (assert nil) :type hash-table)
+  ;; The results of the tests during this run, in order.
+  (test-results (assert nil) :type vector)
+  ;; The start times of the tests, in order, as reported by
+  ;; `current-time'.
+  (test-start-times (assert nil) :type vector)
+  ;; The end times of the tests, in order, as reported by
+  ;; `current-time'.
+  (test-end-times (assert nil) :type vector)
+  (passed-expected 0)
+  (passed-unexpected 0)
+  (failed-expected 0)
+  (failed-unexpected 0)
+  (start-time nil)
+  (end-time nil)
+  (aborted-p nil)
+  (current-test nil)
+  ;; The time at or after which the next redisplay should occur, as a
+  ;; float.
+  (next-redisplay 0.0))
+
+(defun ert-stats-completed-expected (stats)
+  "Return the number of tests in STATS that had expected results."
+  (+ (ert--stats-passed-expected stats)
+     (ert--stats-failed-expected stats)))
+
+(defun ert-stats-completed-unexpected (stats)
+  "Return the number of tests in STATS that had unexpected results."
+  (+ (ert--stats-passed-unexpected stats)
+     (ert--stats-failed-unexpected stats)))
+
+(defun ert-stats-completed (stats)
+  "Number of tests in STATS that have run so far."
+  (+ (ert-stats-completed-expected stats)
+     (ert-stats-completed-unexpected stats)))
+
+(defun ert-stats-total (stats)
+  "Number of tests in STATS, regardless of whether they have run yet."
+  (length (ert--stats-tests stats)))
+
+;; The stats object of the current run, dynamically bound.  This is
+;; used for the mode line progress indicator.
+(defvar ert--current-run-stats nil)
+
+(defun ert--stats-test-key (test)
+  "Return the key used for TEST in the test map of ert--stats objects.
+
+Returns the name of TEST if it has one, or TEST itself otherwise."
+  (or (ert-test-name test) test))
+
+(defun ert--stats-set-test-and-result (stats pos test result)
+  "Change STATS by replacing the test at position POS with TEST and RESULT.
+
+Also changes the counters in STATS to match."
+  (let* ((tests (ert--stats-tests stats))
+         (results (ert--stats-test-results stats))
+         (old-test (aref tests pos))
+         (map (ert--stats-test-map stats)))
+    (flet ((update (d)
+             (if (ert-test-result-expected-p (aref tests pos)
+                                             (aref results pos))
+                 (etypecase (aref results pos)
+                   (ert-test-passed (incf (ert--stats-passed-expected stats) d))
+                   (ert-test-failed (incf (ert--stats-failed-expected stats) d))
+                   (null)
+                   (ert-test-aborted-with-non-local-exit)
+                   (ert-test-quit))
+               (etypecase (aref results pos)
+                 (ert-test-passed (incf (ert--stats-passed-unexpected stats) d))
+                 (ert-test-failed (incf (ert--stats-failed-unexpected stats) d))
+                 (null)
+                 (ert-test-aborted-with-non-local-exit)
+                 (ert-test-quit)))))
+      ;; Adjust counters to remove the result that is currently in stats.
+      (update -1)
+      ;; Put new test and result into stats.
+      (setf (aref tests pos) test
+            (aref results pos) result)
+      (remhash (ert--stats-test-key old-test) map)
+      (setf (gethash (ert--stats-test-key test) map) pos)
+      ;; Adjust counters to match new result.
+      (update +1)
+      nil)))
+
+(defun ert--make-stats (tests selector)
+  "Create a new `ert--stats' object for running TESTS.
+
+SELECTOR is the selector that was used to select TESTS."
+  (setq tests (ert--coerce-to-vector tests))
+  (let ((map (make-hash-table :size (length tests))))
+    (loop for i from 0
+          for test across tests
+          for key = (ert--stats-test-key test) do
+          (assert (not (gethash key map)))
+          (setf (gethash key map) i))
+    (make-ert--stats :selector selector
+                     :tests tests
+                     :test-map map
+                     :test-results (make-vector (length tests) nil)
+                     :test-start-times (make-vector (length tests) nil)
+                     :test-end-times (make-vector (length tests) nil))))
+
+(defun ert-run-or-rerun-test (stats test listener)
+  ;; checkdoc-order: nil
+  "Run the single test TEST and record the result using STATS and LISTENER."
+  (let ((ert--current-run-stats stats)
+        (pos (ert--stats-test-pos stats test)))
+    (ert--stats-set-test-and-result stats pos test nil)
+    ;; Call listener after setting/before resetting
+    ;; (ert--stats-current-test stats); the listener might refresh the
+    ;; mode line display, and if the value is not set yet/any more
+    ;; during this refresh, the mode line will flicker unnecessarily.
+    (setf (ert--stats-current-test stats) test)
+    (funcall listener 'test-started stats test)
+    (setf (ert-test-most-recent-result test) nil)
+    (setf (aref (ert--stats-test-start-times stats) pos) (current-time))
+    (unwind-protect
+        (ert-run-test test)
+      (setf (aref (ert--stats-test-end-times stats) pos) (current-time))
+      (let ((result (ert-test-most-recent-result test)))
+        (ert--stats-set-test-and-result stats pos test result)
+        (funcall listener 'test-ended stats test result))
+      (setf (ert--stats-current-test stats) nil))))
+
+(defun ert-run-tests (selector listener)
+  "Run the tests specified by SELECTOR, sending progress updates to LISTENER."
+  (let* ((tests (ert-select-tests selector t))
+         (stats (ert--make-stats tests selector)))
+    (setf (ert--stats-start-time stats) (current-time))
+    (funcall listener 'run-started stats)
+    (let ((abortedp t))
+      (unwind-protect
+          (let ((ert--current-run-stats stats))
+            (force-mode-line-update)
+            (unwind-protect
+                (progn
+                  (loop for test in tests do
+                        (ert-run-or-rerun-test stats test listener))
+                  (setq abortedp nil))
+              (setf (ert--stats-aborted-p stats) abortedp)
+              (setf (ert--stats-end-time stats) (current-time))
+              (funcall listener 'run-ended stats abortedp)))
+        (force-mode-line-update))
+      stats)))
+
+(defun ert--stats-test-pos (stats test)
+  ;; checkdoc-order: nil
+  "Return the position (index) of TEST in the run represented by STATS."
+  (gethash (ert--stats-test-key test) (ert--stats-test-map stats)))
+
+
+;;; Formatting functions shared across UIs.
+
+(defun ert--format-time-iso8601 (time)
+  "Format TIME in the variant of ISO 8601 used for timestamps in ERT."
+  (format-time-string "%Y-%m-%d %T%z" time))
+
+(defun ert-char-for-test-result (result expectedp)
+  "Return a character that represents the test result RESULT.
+
+EXPECTEDP specifies whether the result was expected."
+  (let ((s (etypecase result
+             (ert-test-passed ".P")
+             (ert-test-failed "fF")
+             (null "--")
+             (ert-test-aborted-with-non-local-exit "aA")
+             (ert-test-quit "qQ"))))
+    (elt s (if expectedp 0 1))))
+
+(defun ert-string-for-test-result (result expectedp)
+  "Return a string that represents the test result RESULT.
+
+EXPECTEDP specifies whether the result was expected."
+  (let ((s (etypecase result
+             (ert-test-passed '("passed" "PASSED"))
+             (ert-test-failed '("failed" "FAILED"))
+             (null '("unknown" "UNKNOWN"))
+             (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))
+             (ert-test-quit '("quit" "QUIT")))))
+    (elt s (if expectedp 0 1))))
+
+(defun ert--pp-with-indentation-and-newline (object)
+  "Pretty-print OBJECT, indenting it to the current column of point.
+Ensures a final newline is inserted."
+  (let ((begin (point)))
+    (pp object (current-buffer))
+    (unless (bolp) (insert "\n"))
+    (save-excursion
+      (goto-char begin)
+      (indent-sexp))))
+
+(defun ert--insert-infos (result)
+  "Insert `ert-info' infos from RESULT into current buffer.
+
+RESULT must be an `ert-test-result-with-condition'."
+  (check-type result ert-test-result-with-condition)
+  (dolist (info (ert-test-result-with-condition-infos result))
+    (destructuring-bind (prefix . message) info
+      (let ((begin (point))
+            (indentation (make-string (+ (length prefix) 4) ?\s))
+            (end nil))
+        (unwind-protect
+            (progn
+              (insert message "\n")
+              (setq end (copy-marker (point)))
+              (goto-char begin)
+              (insert "    " prefix)
+              (forward-line 1)
+              (while (< (point) end)
+                (insert indentation)
+                (forward-line 1)))
+          (when end (set-marker end nil)))))))
+
+
+;;; Running tests in batch mode.
+
+(defvar ert-batch-backtrace-right-margin 70
+  "*The maximum line length for printing backtraces in `ert-run-tests-batch'.")
+
+;;;###autoload
+(defun ert-run-tests-batch (&optional selector)
+  "Run the tests specified by SELECTOR, printing results to the terminal.
+
+SELECTOR works as described in `ert-select-tests', except if
+SELECTOR is nil, in which case all tests rather than none will be
+run; this makes the command line \"emacs -batch -l my-tests.el -f
+ert-run-tests-batch-and-exit\" useful.
+
+Returns the stats object."
+  (unless selector (setq selector 't))
+  (ert-run-tests
+   selector
+   (lambda (event-type &rest event-args)
+     (ecase event-type
+       (run-started
+        (destructuring-bind (stats) event-args
+          (message "Running %s tests (%s)"
+                   (length (ert--stats-tests stats))
+                   (ert--format-time-iso8601 (ert--stats-start-time stats)))))
+       (run-ended
+        (destructuring-bind (stats abortedp) event-args
+          (let ((unexpected (ert-stats-completed-unexpected stats))
+                (expected-failures (ert--stats-failed-expected stats)))
+            (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n"
+                     (if (not abortedp)
+                         ""
+                       "Aborted: ")
+                     (ert-stats-total stats)
+                     (ert-stats-completed-expected stats)
+                     (if (zerop unexpected)
+                         ""
+                       (format ", %s unexpected" unexpected))
+                     (ert--format-time-iso8601 (ert--stats-end-time stats))
+                     (if (zerop expected-failures)
+                         ""
+                       (format "\n%s expected failures" expected-failures)))
+            (unless (zerop unexpected)
+              (message "%s unexpected results:" unexpected)
+              (loop for test across (ert--stats-tests stats)
+                    for result = (ert-test-most-recent-result test) do
+                    (when (not (ert-test-result-expected-p test result))
+                      (message "%9s  %S"
+                               (ert-string-for-test-result result nil)
+                               (ert-test-name test))))
+              (message "%s" "")))))
+       (test-started
+        )
+       (test-ended
+        (destructuring-bind (stats test result) event-args
+          (unless (ert-test-result-expected-p test result)
+            (etypecase result
+              (ert-test-passed
+               (message "Test %S passed unexpectedly" (ert-test-name test)))
+              (ert-test-result-with-condition
+               (message "Test %S backtrace:" (ert-test-name test))
+               (with-temp-buffer
+                 (ert--print-backtrace (ert-test-result-with-condition-backtrace
+                                        result))
+                 (goto-char (point-min))
+                 (while (not (eobp))
+                   (let ((start (point))
+                         (end (progn (end-of-line) (point))))
+                     (setq end (min end
+                                    (+ start ert-batch-backtrace-right-margin)))
+                     (message "%s" (buffer-substring-no-properties
+                                    start end)))
+                   (forward-line 1)))
+               (with-temp-buffer
+                 (ert--insert-infos result)
+                 (insert "    ")
+                 (let ((print-escape-newlines t)
+                       (print-level 5)
+                       (print-length 10))
+                   (let ((begin (point)))
+                     (ert--pp-with-indentation-and-newline
+                      (ert-test-result-with-condition-condition result))))
+                 (goto-char (1- (point-max)))
+                 (assert (looking-at "\n"))
+                 (delete-char 1)
+                 (message "Test %S condition:" (ert-test-name test))
+                 (message "%s" (buffer-string))))
+              (ert-test-aborted-with-non-local-exit
+               (message "Test %S aborted with non-local exit"
+                        (ert-test-name test)))
+              (ert-test-quit
+               (message "Quit during %S" (ert-test-name test)))))
+          (let* ((max (prin1-to-string (length (ert--stats-tests stats))))
+                 (format-string (concat "%9s  %"
+                                        (prin1-to-string (length max))
+                                        "s/" max "  %S")))
+            (message format-string
+                     (ert-string-for-test-result result
+                                                 (ert-test-result-expected-p
+                                                  test result))
+                     (1+ (ert--stats-test-pos stats test))
+                     (ert-test-name test)))))))))
+
+;;;###autoload
+(defun ert-run-tests-batch-and-exit (&optional selector)
+  "Like `ert-run-tests-batch', but exits Emacs when done.
+
+The exit status will be 0 if all test results were as expected, 1
+on unexpected results, or 2 if the tool detected an error outside
+of the tests (e.g. invalid SELECTOR or bug in the code that runs
+the tests)."
+  (unwind-protect
+      (let ((stats (ert-run-tests-batch selector)))
+        (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1)))
+    (unwind-protect
+        (progn
+          (message "Error running tests")
+          (backtrace))
+      (kill-emacs 2))))
+
+
+;;; Utility functions for load/unload actions.
+
+(defun ert--activate-font-lock-keywords ()
+  "Activate font-lock keywords for some of ERT's symbols."
+  (font-lock-add-keywords
+   nil
+   '(("(\\(\\<ert-deftest\\)\\>\\s *\\(\\sw+\\)?"
+      (1 font-lock-keyword-face nil t)
+      (2 font-lock-function-name-face nil t)))))
+
+(defun* ert--remove-from-list (list-var element &key key test)
+  "Remove ELEMENT from the value of LIST-VAR if present.
+
+This can be used as an inverse of `add-to-list'."
+  (unless key (setq key #'identity))
+  (unless test (setq test #'equal))
+  (setf (symbol-value list-var)
+        (ert--remove* element
+                      (symbol-value list-var)
+                      :key key
+                      :test test)))
+
+
+;;; Some basic interactive functions.
+
+(defun ert-read-test-name (prompt &optional default history
+                                  add-default-to-prompt)
+  "Read the name of a test and return it as a symbol.
+
+Prompt with PROMPT.  If DEFAULT is a valid test name, use it as a
+default.  HISTORY is the history to use; see `completing-read'.
+If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to
+include the default, if any.
+
+Signals an error if no test name was read."
+  (etypecase default
+    (string (let ((symbol (intern-soft default)))
+              (unless (and symbol (ert-test-boundp symbol))
+                (setq default nil))))
+    (symbol (setq default
+                  (if (ert-test-boundp default)
+                      (symbol-name default)
+                    nil)))
+    (ert-test (setq default (ert-test-name default))))
+  (when add-default-to-prompt
+    (setq prompt (if (null default)
+                     (format "%s: " prompt)
+                   (format "%s (default %s): " prompt default))))
+  (let ((input (completing-read prompt obarray #'ert-test-boundp
+                                t nil history default nil)))
+    ;; completing-read returns an empty string if default was nil and
+    ;; the user just hit enter.
+    (let ((sym (intern-soft input)))
+      (if (ert-test-boundp sym)
+          sym
+        (error "Input does not name a test")))))
+
+(defun ert-read-test-name-at-point (prompt)
+  "Read the name of a test and return it as a symbol.
+As a default, use the symbol at point, or the test at point if in
+the ERT results buffer.  Prompt with PROMPT, augmented with the
+default (if any)."
+  (ert-read-test-name prompt (ert-test-at-point) nil t))
+
+(defun ert-find-test-other-window (test-name)
+  "Find, in another window, the definition of TEST-NAME."
+  (interactive (list (ert-read-test-name-at-point "Find test definition: ")))
+  (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window))
+
+(defun ert-delete-test (test-name)
+  "Make the test TEST-NAME unbound.
+
+Nothing more than an interactive interface to `ert-make-test-unbound'."
+  (interactive (list (ert-read-test-name-at-point "Delete test")))
+  (ert-make-test-unbound test-name))
+
+(defun ert-delete-all-tests ()
+  "Make all symbols in `obarray' name no test."
+  (interactive)
+  (when (interactive-p)
+    (unless (y-or-n-p "Delete all tests? ")
+      (error "Aborted")))
+  ;; We can't use `ert-select-tests' here since that gives us only
+  ;; test objects, and going from them back to the test name symbols
+  ;; can fail if the `ert-test' defstruct has been redefined.
+  (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp))
+  t)
+
+
+;;; Display of test progress and results.
+
+;; An entry in the results buffer ewoc.  There is one entry per test.
+(defstruct ert--ewoc-entry
+  (test (assert nil))
+  ;; If the result of this test was expected, its ewoc entry is hidden
+  ;; initially.
+  (hidden-p (assert nil))
+  ;; An ewoc entry may be collapsed to hide details such as the error
+  ;; condition.
+  ;;
+  ;; I'm not sure the ability to expand and collapse entries is still
+  ;; a useful feature.
+  (expanded-p t)
+  ;; By default, the ewoc entry presents the error condition with
+  ;; certain limits on how much to print (`print-level',
+  ;; `print-length').  The user can interactively switch to a set of
+  ;; higher limits.
+  (extended-printer-limits-p nil))
+
+;; Variables local to the results buffer.
+
+;; The ewoc.
+(defvar ert--results-ewoc)
+;; The stats object.
+(defvar ert--results-stats)
+;; A string with one character per test.  Each character represents
+;; the result of the corresponding test.  The string is displayed near
+;; the top of the buffer and serves as a progress bar.
+(defvar ert--results-progress-bar-string)
+;; The position where the progress bar button begins.
+(defvar ert--results-progress-bar-button-begin)
+;; The test result listener that updates the buffer when tests are run.
+(defvar ert--results-listener)
+
+(defun ert-insert-test-name-button (test-name)
+  "Insert a button that links to TEST-NAME."
+  (insert-text-button (format "%S" test-name)
+                      :type 'ert--test-name-button
+                      'ert-test-name test-name))
+
+(defun ert--results-format-expected-unexpected (expected unexpected)
+  "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected."
+  (if (zerop unexpected)
+      (format "%s" expected)
+    (format "%s (%s unexpected)" (+ expected unexpected) unexpected)))
+
+(defun ert--results-update-ewoc-hf (ewoc stats)
+  "Update the header and footer of EWOC to show certain information from STATS.
+
+Also sets `ert--results-progress-bar-button-begin'."
+  (let ((run-count (ert-stats-completed stats))
+        (results-buffer (current-buffer))
+        ;; Need to save buffer-local value.
+        (font-lock font-lock-mode))
+    (ewoc-set-hf
+     ewoc
+     ;; header
+     (with-temp-buffer
+       (insert "Selector: ")
+       (ert--insert-human-readable-selector (ert--stats-selector stats))
+       (insert "\n")
+       (insert
+        (format (concat "Passed: %s\n"
+                        "Failed: %s\n"
+                        "Total:  %s/%s\n\n")
+                (ert--results-format-expected-unexpected
+                 (ert--stats-passed-expected stats)
+                 (ert--stats-passed-unexpected stats))
+                (ert--results-format-expected-unexpected
+                 (ert--stats-failed-expected stats)
+                 (ert--stats-failed-unexpected stats))
+                run-count
+                (ert-stats-total stats)))
+       (insert
+        (format "Started at:   %s\n"
+                (ert--format-time-iso8601 (ert--stats-start-time stats))))
+       ;; FIXME: This is ugly.  Need to properly define invariants of
+       ;; the `stats' data structure.
+       (let ((state (cond ((ert--stats-aborted-p stats) 'aborted)
+                          ((ert--stats-current-test stats) 'running)
+                          ((ert--stats-end-time stats) 'finished)
+                          (t 'preparing))))
+         (ecase state
+           (preparing
+            (insert ""))
+           (aborted
+            (cond ((ert--stats-current-test stats)
+                   (insert "Aborted during test: ")
+                   (ert-insert-test-name-button
+                    (ert-test-name (ert--stats-current-test stats))))
+                  (t
+                   (insert "Aborted."))))
+           (running
+            (assert (ert--stats-current-test stats))
+            (insert "Running test: ")
+            (ert-insert-test-name-button (ert-test-name
+                                          (ert--stats-current-test stats))))
+           (finished
+            (assert (not (ert--stats-current-test stats)))
+            (insert "Finished.")))
+         (insert "\n")
+         (if (ert--stats-end-time stats)
+             (insert
+              (format "%s%s\n"
+                      (if (ert--stats-aborted-p stats)
+                          "Aborted at:   "
+                        "Finished at:  ")
+                      (ert--format-time-iso8601 (ert--stats-end-time stats))))
+           (insert "\n"))
+         (insert "\n"))
+       (let ((progress-bar-string (with-current-buffer results-buffer
+                                    ert--results-progress-bar-string)))
+         (let ((progress-bar-button-begin
+                (insert-text-button progress-bar-string
+                                    :type 'ert--results-progress-bar-button
+                                    'face (or (and font-lock
+                                                   (ert-face-for-stats stats))
+                                              'button))))
+           ;; The header gets copied verbatim to the results buffer,
+           ;; and all positions remain the same, so
+           ;; `progress-bar-button-begin' will be the right position
+           ;; even in the results buffer.
+           (with-current-buffer results-buffer
+             (set (make-local-variable 'ert--results-progress-bar-button-begin)
+                  progress-bar-button-begin))))
+       (insert "\n\n")
+       (buffer-string))
+     ;; footer
+     ;;
+     ;; We actually want an empty footer, but that would trigger a bug
+     ;; in ewoc, sometimes clearing the entire buffer.  (It's possible
+     ;; that this bug has been fixed since this has been tested; we
+     ;; should test it again.)
+     "\n")))
+
+
+(defvar ert-test-run-redisplay-interval-secs .1
+  "How many seconds ERT should wait between redisplays while running tests.
+
+While running tests, ERT shows the current progress, and this variable
+determines how frequently the progress display is updated.")
+
+(defun ert--results-update-stats-display (ewoc stats)
+  "Update EWOC and the mode line to show data from STATS."
+  ;; TODO(ohler): investigate using `make-progress-reporter'.
+  (ert--results-update-ewoc-hf ewoc stats)
+  (force-mode-line-update)
+  (redisplay t)
+  (setf (ert--stats-next-redisplay stats)
+        (+ (float-time) ert-test-run-redisplay-interval-secs)))
+
+(defun ert--results-update-stats-display-maybe (ewoc stats)
+  "Call `ert--results-update-stats-display' if not called recently.
+
+EWOC and STATS are arguments for `ert--results-update-stats-display'."
+  (when (>= (float-time) (ert--stats-next-redisplay stats))
+    (ert--results-update-stats-display ewoc stats)))
+
+(defun ert--tests-running-mode-line-indicator ()
+  "Return a string for the mode line that shows the test run progress."
+  (let* ((stats ert--current-run-stats)
+         (tests-total (ert-stats-total stats))
+         (tests-completed (ert-stats-completed stats)))
+    (if (>= tests-completed tests-total)
+        (format " ERT(%s/%s,finished)" tests-completed tests-total)
+      (format " ERT(%s/%s):%s"
+              (1+ tests-completed)
+              tests-total
+              (if (null (ert--stats-current-test stats))
+                  "?"
+                (format "%S"
+                        (ert-test-name (ert--stats-current-test stats))))))))
+
+(defun ert--make-xrefs-region (begin end)
+  "Attach cross-references to function names between BEGIN and END.
+
+BEGIN and END specify a region in the current buffer."
+  (save-excursion
+    (save-restriction
+      (narrow-to-region begin (point))
+      ;; Inhibit optimization in `debugger-make-xrefs' that would
+      ;; sometimes insert unrelated backtrace info into our buffer.
+      (let ((debugger-previous-backtrace nil))
+        (debugger-make-xrefs)))))
+
+(defun ert--string-first-line (s)
+  "Return the first line of S, or S if it contains no newlines.
+
+The return value does not include the line terminator."
+  (substring s 0 (ert--string-position ?\n s)))
+
+(defun ert-face-for-test-result (expectedp)
+  "Return a face that shows whether a test result was expected or unexpected.
+
+If EXPECTEDP is nil, returns the face for unexpected results; if
+non-nil, returns the face for expected results.."
+  (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected))
+
+(defun ert-face-for-stats (stats)
+  "Return a face that represents STATS."
+  (cond ((ert--stats-aborted-p stats) 'nil)
+        ((plusp (ert-stats-completed-unexpected stats))
+         (ert-face-for-test-result nil))
+        ((eql (ert-stats-completed-expected stats) (ert-stats-total stats))
+         (ert-face-for-test-result t))
+        (t 'nil)))
+
+(defun ert--print-test-for-ewoc (entry)
+  "The ewoc print function for ewoc test entries.  ENTRY is the entry to print."
+  (let* ((test (ert--ewoc-entry-test entry))
+         (stats ert--results-stats)
+         (result (let ((pos (ert--stats-test-pos stats test)))
+                   (assert pos)
+                   (aref (ert--stats-test-results stats) pos)))
+         (hiddenp (ert--ewoc-entry-hidden-p entry))
+         (expandedp (ert--ewoc-entry-expanded-p entry))
+         (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p
+                                     entry)))
+    (cond (hiddenp)
+          (t
+           (let ((expectedp (ert-test-result-expected-p test result)))
+             (insert-text-button (format "%c" (ert-char-for-test-result
+                                               result expectedp))
+                                 :type 'ert--results-expand-collapse-button
+                                 'face (or (and font-lock-mode
+                                                (ert-face-for-test-result
+                                                 expectedp))
+                                           'button)))
+           (insert " ")
+           (ert-insert-test-name-button (ert-test-name test))
+           (insert "\n")
+           (when (and expandedp (not (eql result 'nil)))
+             (when (ert-test-documentation test)
+               (insert "    "
+                       (propertize
+                        (ert--string-first-line (ert-test-documentation test))
+                        'font-lock-face 'font-lock-doc-face)
+                       "\n"))
+             (etypecase result
+               (ert-test-passed
+                (if (ert-test-result-expected-p test result)
+                    (insert "    passed\n")
+                  (insert "    passed unexpectedly\n"))
+                (insert ""))
+               (ert-test-result-with-condition
+                (ert--insert-infos result)
+                (let ((print-escape-newlines t)
+                      (print-level (if extended-printer-limits-p 12 6))
+                      (print-length (if extended-printer-limits-p 100 10)))
+                  (insert "    ")
+                  (let ((begin (point)))
+                    (ert--pp-with-indentation-and-newline
+                     (ert-test-result-with-condition-condition result))
+                    (ert--make-xrefs-region begin (point)))))
+               (ert-test-aborted-with-non-local-exit
+                (insert "    aborted\n"))
+               (ert-test-quit
+                (insert "    quit\n")))
+             (insert "\n")))))
+  nil)
+
+(defun ert--results-font-lock-function (enabledp)
+  "Redraw the ERT results buffer after font-lock-mode was switched on or off.
+
+ENABLEDP is true if font-lock-mode is switched on, false
+otherwise."
+  (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
+  (ewoc-refresh ert--results-ewoc)
+  (font-lock-default-function enabledp))
+
+(defun ert--setup-results-buffer (stats listener buffer-name)
+  "Set up a test results buffer.
+
+STATS is the stats object; LISTENER is the results listener;
+BUFFER-NAME, if non-nil, is the buffer name to use."
+  (unless buffer-name (setq buffer-name "*ert*"))
+  (let ((buffer (get-buffer-create buffer-name)))
+    (with-current-buffer buffer
+      (let ((inhibit-read-only t))
+        (buffer-disable-undo)
+        (erase-buffer)
+        (ert-results-mode)
+        ;; Erase buffer again in case switching out of the previous
+        ;; mode inserted anything.  (This happens e.g. when switching
+        ;; from ert-results-mode to ert-results-mode when
+        ;; font-lock-mode turns itself off in change-major-mode-hook.)
+        (erase-buffer)
+        (set (make-local-variable 'font-lock-function)
+             'ert--results-font-lock-function)
+        (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t)))
+          (set (make-local-variable 'ert--results-ewoc) ewoc)
+          (set (make-local-variable 'ert--results-stats) stats)
+          (set (make-local-variable 'ert--results-progress-bar-string)
+               (make-string (ert-stats-total stats)
+                            (ert-char-for-test-result nil t)))
+          (set (make-local-variable 'ert--results-listener) listener)
+          (loop for test across (ert--stats-tests stats) do
+                (ewoc-enter-last ewoc
+                                 (make-ert--ewoc-entry :test test :hidden-p t)))
+          (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
+          (goto-char (1- (point-max)))
+          buffer)))))
+
+
+(defvar ert--selector-history nil
+  "List of recent test selectors read from terminal.")
+
+;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here?
+;; They are needed only for our automated self-tests at the moment.
+;; Or should there be some other mechanism?
+;;;###autoload
+(defun ert-run-tests-interactively (selector
+                                    &optional output-buffer-name message-fn)
+  "Run the tests specified by SELECTOR and display the results in a buffer.
+
+SELECTOR works as described in `ert-select-tests'.
+OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they
+are used for automated self-tests and specify which buffer to use
+and how to display message."
+  (interactive
+   (list (let ((default (if ert--selector-history
+                            ;; Can't use `first' here as this form is
+                            ;; not compiled, and `first' is not
+                            ;; defined without cl.
+                            (car ert--selector-history)
+                          "t")))
+           (read-from-minibuffer (if (null default)
+                                     "Run tests: "
+                                   (format "Run tests (default %s): " default))
+                                 nil nil t 'ert--selector-history
+                                 default nil))
+         nil))
+  (unless message-fn (setq message-fn 'message))
+  (lexical-let ((output-buffer-name output-buffer-name)
+                buffer
+                listener
+                (message-fn message-fn))
+    (setq listener
+          (lambda (event-type &rest event-args)
+            (ecase event-type
+              (run-started
+               (destructuring-bind (stats) event-args
+                 (setq buffer (ert--setup-results-buffer stats
+                                                         listener
+                                                         output-buffer-name))
+                 (pop-to-buffer buffer)))
+              (run-ended
+               (destructuring-bind (stats abortedp) event-args
+                 (funcall message-fn
+                          "%sRan %s tests, %s results were as expected%s"
+                          (if (not abortedp)
+                              ""
+                            "Aborted: ")
+                          (ert-stats-total stats)
+                          (ert-stats-completed-expected stats)
+                          (let ((unexpected
+                                 (ert-stats-completed-unexpected stats)))
+                            (if (zerop unexpected)
+                                ""
+                              (format ", %s unexpected" unexpected))))
+                 (ert--results-update-stats-display (with-current-buffer buffer
+                                                      ert--results-ewoc)
+                                                    stats)))
+              (test-started
+               (destructuring-bind (stats test) event-args
+                 (with-current-buffer buffer
+                   (let* ((ewoc ert--results-ewoc)
+                          (pos (ert--stats-test-pos stats test))
+                          (node (ewoc-nth ewoc pos)))
+                     (assert node)
+                     (setf (ert--ewoc-entry-test (ewoc-data node)) test)
+                     (aset ert--results-progress-bar-string pos
+                           (ert-char-for-test-result nil t))
+                     (ert--results-update-stats-display-maybe ewoc stats)
+                     (ewoc-invalidate ewoc node)))))
+              (test-ended
+               (destructuring-bind (stats test result) event-args
+                 (with-current-buffer buffer
+                   (let* ((ewoc ert--results-ewoc)
+                          (pos (ert--stats-test-pos stats test))
+                          (node (ewoc-nth ewoc pos)))
+                     (when (ert--ewoc-entry-hidden-p (ewoc-data node))
+                       (setf (ert--ewoc-entry-hidden-p (ewoc-data node))
+                             (ert-test-result-expected-p test result)))
+                     (aset ert--results-progress-bar-string pos
+                           (ert-char-for-test-result result
+                                                     (ert-test-result-expected-p
+                                                      test result)))
+                     (ert--results-update-stats-display-maybe ewoc stats)
+                     (ewoc-invalidate ewoc node))))))))
+    (ert-run-tests
+     selector
+     listener)))
+;;;###autoload
+(defalias 'ert 'ert-run-tests-interactively)
+
+
+;;; Simple view mode for auxiliary information like stack traces or
+;;; messages.  Mainly binds "q" for quit.
+
+(define-derived-mode ert-simple-view-mode special-mode "ERT-View"
+  "Major mode for viewing auxiliary information in ERT.")
+
+;;; Commands and button actions for the results buffer.
+
+(define-derived-mode ert-results-mode special-mode "ERT-Results"
+  "Major mode for viewing results of ERT test runs.")
+
+(loop for (key binding) in
+      '(;; Stuff that's not in the menu.
+        ("\t" forward-button)
+        ([backtab] backward-button)
+        ("j" ert-results-jump-between-summary-and-result)
+        ("L" ert-results-toggle-printer-limits-for-test-at-point)
+        ("n" ert-results-next-test)
+        ("p" ert-results-previous-test)
+        ;; Stuff that is in the menu.
+        ("R" ert-results-rerun-all-tests)
+        ("r" ert-results-rerun-test-at-point)
+        ("d" ert-results-rerun-test-at-point-debugging-errors)
+        ("." ert-results-find-test-at-point-other-window)
+        ("b" ert-results-pop-to-backtrace-for-test-at-point)
+        ("m" ert-results-pop-to-messages-for-test-at-point)
+        ("l" ert-results-pop-to-should-forms-for-test-at-point)
+        ("h" ert-results-describe-test-at-point)
+        ("D" ert-delete-test)
+        ("T" ert-results-pop-to-timings)
+        )
+      do
+      (define-key ert-results-mode-map key binding))
+
+(easy-menu-define ert-results-mode-menu ert-results-mode-map
+  "Menu for `ert-results-mode'."
+  '("ERT Results"
+    ["Re-run all tests" ert-results-rerun-all-tests]
+    "--"
+    ["Re-run test" ert-results-rerun-test-at-point]
+    ["Debug test" ert-results-rerun-test-at-point-debugging-errors]
+    ["Show test definition" ert-results-find-test-at-point-other-window]
+    "--"
+    ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point]
+    ["Show messages" ert-results-pop-to-messages-for-test-at-point]
+    ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point]
+    ["Describe test" ert-results-describe-test-at-point]
+    "--"
+    ["Delete test" ert-delete-test]
+    "--"
+    ["Show execution time of each test" ert-results-pop-to-timings]
+    ))
+
+(define-button-type 'ert--results-progress-bar-button
+  'action #'ert--results-progress-bar-button-action
+  'help-echo "mouse-2, RET: Reveal test result")
+
+(define-button-type 'ert--test-name-button
+  'action #'ert--test-name-button-action
+  'help-echo "mouse-2, RET: Find test definition")
+
+(define-button-type 'ert--results-expand-collapse-button
+  'action #'ert--results-expand-collapse-button-action
+  'help-echo "mouse-2, RET: Expand/collapse test result")
+
+(defun ert--results-test-node-or-null-at-point ()
+  "If point is on a valid ewoc node, return it; return nil otherwise.
+
+To be used in the ERT results buffer."
+  (let* ((ewoc ert--results-ewoc)
+         (node (ewoc-locate ewoc)))
+    ;; `ewoc-locate' will return an arbitrary node when point is on
+    ;; header or footer, or when all nodes are invisible.  So we need
+    ;; to validate its return value here.
+    ;;
+    ;; Update: I'm seeing nil being returned in some cases now,
+    ;; perhaps this has been changed?
+    (if (and node
+             (>= (point) (ewoc-location node))
+             (not (ert--ewoc-entry-hidden-p (ewoc-data node))))
+        node
+      nil)))
+
+(defun ert--results-test-node-at-point ()
+  "If point is on a valid ewoc node, return it; signal an error otherwise.
+
+To be used in the ERT results buffer."
+  (or (ert--results-test-node-or-null-at-point)
+      (error "No test at point")))
+
+(defun ert-results-next-test ()
+  "Move point to the next test.
+
+To be used in the ERT results buffer."
+  (interactive)
+  (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next
+                     "No tests below"))
+
+(defun ert-results-previous-test ()
+  "Move point to the previous test.
+
+To be used in the ERT results buffer."
+  (interactive)
+  (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev
+                     "No tests above"))
+
+(defun ert--results-move (node ewoc-fn error-message)
+  "Move point from NODE to the previous or next node.
+
+EWOC-FN specifies the direction and should be either `ewoc-prev'
+or `ewoc-next'.  If there are no more nodes in that direction, an
+error is signalled with the message ERROR-MESSAGE."
+  (loop
+   (setq node (funcall ewoc-fn ert--results-ewoc node))
+   (when (null node)
+     (error "%s" error-message))
+   (unless (ert--ewoc-entry-hidden-p (ewoc-data node))
+     (goto-char (ewoc-location node))
+     (return))))
+
+(defun ert--results-expand-collapse-button-action (button)
+  "Expand or collapse the test node BUTTON belongs to."
+  (let* ((ewoc ert--results-ewoc)
+         (node (save-excursion
+                 (goto-char (ert--button-action-position))
+                 (ert--results-test-node-at-point)))
+         (entry (ewoc-data node)))
+    (setf (ert--ewoc-entry-expanded-p entry)
+          (not (ert--ewoc-entry-expanded-p entry)))
+    (ewoc-invalidate ewoc node)))
+
+(defun ert-results-find-test-at-point-other-window ()
+  "Find the definition of the test at point in another window.
+
+To be used in the ERT results buffer."
+  (interactive)
+  (let ((name (ert-test-at-point)))
+    (unless name
+      (error "No test at point"))
+    (ert-find-test-other-window name)))
+
+(defun ert--test-name-button-action (button)
+  "Find the definition of the test BUTTON belongs to, in another window."
+  (let ((name (button-get button 'ert-test-name)))
+    (ert-find-test-other-window name)))
+
+(defun ert--ewoc-position (ewoc node)
+  ;; checkdoc-order: nil
+  "Return the position of NODE in EWOC, or nil if NODE is not in EWOC."
+  (loop for i from 0
+        for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here)
+        do (when (eql node node-here)
+             (return i))
+        finally (return nil)))
+
+(defun ert-results-jump-between-summary-and-result ()
+  "Jump back and forth between the test run summary and individual test results.
+
+From an ewoc node, jumps to the character that represents the
+same test in the progress bar, and vice versa.
+
+To be used in the ERT results buffer."
+  ;; Maybe this command isn't actually needed much, but if it is, it
+  ;; seems like an indication that the UI design is not optimal.  If
+  ;; jumping back and forth between a summary at the top of the buffer
+  ;; and the error log in the remainder of the buffer is useful, then
+  ;; the summary apparently needs to be easily accessible from the
+  ;; error log, and perhaps it would be better to have it in a
+  ;; separate buffer to keep it visible.
+  (interactive)
+  (let ((ewoc ert--results-ewoc)
+        (progress-bar-begin ert--results-progress-bar-button-begin))
+    (cond ((ert--results-test-node-or-null-at-point)
+           (let* ((node (ert--results-test-node-at-point))
+                  (pos (ert--ewoc-position ewoc node)))
+             (goto-char (+ progress-bar-begin pos))))
+          ((and (<= progress-bar-begin (point))
+                (< (point) (button-end (button-at progress-bar-begin))))
+           (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin)))
+                  (entry (ewoc-data node)))
+             (when (ert--ewoc-entry-hidden-p entry)
+               (setf (ert--ewoc-entry-hidden-p entry) nil)
+               (ewoc-invalidate ewoc node))
+             (ewoc-goto-node ewoc node)))
+          (t
+           (goto-char progress-bar-begin)))))
+
+(defun ert-test-at-point ()
+  "Return the name of the test at point as a symbol, or nil if none."
+  (or (and (eql major-mode 'ert-results-mode)
+           (let ((test (ert--results-test-at-point-no-redefinition)))
+             (and test (ert-test-name test))))
+      (let* ((thing (thing-at-point 'symbol))
+             (sym (intern-soft thing)))
+        (and (ert-test-boundp sym)
+             sym))))
+
+(defun ert--results-test-at-point-no-redefinition ()
+  "Return the test at point, or nil.
+
+To be used in the ERT results buffer."
+  (assert (eql major-mode 'ert-results-mode))
+  (if (ert--results-test-node-or-null-at-point)
+      (let* ((node (ert--results-test-node-at-point))
+             (test (ert--ewoc-entry-test (ewoc-data node))))
+        test)
+    (let ((progress-bar-begin ert--results-progress-bar-button-begin))
+      (when (and (<= progress-bar-begin (point))
+                 (< (point) (button-end (button-at progress-bar-begin))))
+        (let* ((test-index (- (point) progress-bar-begin))
+               (test (aref (ert--stats-tests ert--results-stats)
+                           test-index)))
+          test)))))
+
+(defun ert--results-test-at-point-allow-redefinition ()
+  "Look up the test at point, and check whether it has been redefined.
+
+To be used in the ERT results buffer.
+
+Returns a list of two elements: the test (or nil) and a symbol
+specifying whether the test has been redefined.
+
+If a new test has been defined with the same name as the test at
+point, replaces the test at point with the new test, and returns
+the new test and the symbol `redefined'.
+
+If the test has been deleted, returns the old test and the symbol
+`deleted'.
+
+If the test is still current, returns the test and the symbol nil.
+
+If there is no test at point, returns a list with two nils."
+  (let ((test (ert--results-test-at-point-no-redefinition)))
+    (cond ((null test)
+           `(nil nil))
+          ((null (ert-test-name test))
+           `(,test nil))
+          (t
+           (let* ((name (ert-test-name test))
+                  (new-test (and (ert-test-boundp name)
+                                 (ert-get-test name))))
+             (cond ((eql test new-test)
+                    `(,test nil))
+                   ((null new-test)
+                    `(,test deleted))
+                   (t
+                    (ert--results-update-after-test-redefinition
+                     (ert--stats-test-pos ert--results-stats test)
+                     new-test)
+                    `(,new-test redefined))))))))
+
+(defun ert--results-update-after-test-redefinition (pos new-test)
+  "Update results buffer after the test at pos POS has been redefined.
+
+Also updates the stats object.  NEW-TEST is the new test
+definition."
+  (let* ((stats ert--results-stats)
+         (ewoc ert--results-ewoc)
+         (node (ewoc-nth ewoc pos))
+         (entry (ewoc-data node)))
+    (ert--stats-set-test-and-result stats pos new-test nil)
+    (setf (ert--ewoc-entry-test entry) new-test
+          (aref ert--results-progress-bar-string pos) (ert-char-for-test-result
+                                                       nil t))
+    (ewoc-invalidate ewoc node))
+  nil)
+
+(defun ert--button-action-position ()
+  "The buffer position where the last button action was triggered."
+  (cond ((integerp last-command-event)
+         (point))
+        ((eventp last-command-event)
+         (posn-point (event-start last-command-event)))
+        (t (assert nil))))
+
+(defun ert--results-progress-bar-button-action (button)
+  "Jump to details for the test represented by the character clicked in BUTTON."
+  (goto-char (ert--button-action-position))
+  (ert-results-jump-between-summary-and-result))
+
+(defun ert-results-rerun-all-tests ()
+  "Re-run all tests, using the same selector.
+
+To be used in the ERT results buffer."
+  (interactive)
+  (assert (eql major-mode 'ert-results-mode))
+  (let ((selector (ert--stats-selector ert--results-stats)))
+    (ert-run-tests-interactively selector (buffer-name))))
+
+(defun ert-results-rerun-test-at-point ()
+  "Re-run the test at point.
+
+To be used in the ERT results buffer."
+  (interactive)
+  (destructuring-bind (test redefinition-state)
+      (ert--results-test-at-point-allow-redefinition)
+    (when (null test)
+      (error "No test at point"))
+    (let* ((stats ert--results-stats)
+           (progress-message (format "Running %stest %S"
+                                     (ecase redefinition-state
+                                       ((nil) "")
+                                       (redefined "new definition of ")
+                                       (deleted "deleted "))
+                                     (ert-test-name test))))
+      ;; Need to save and restore point manually here: When point is on
+      ;; the first visible ewoc entry while the header is updated, point
+      ;; moves to the top of the buffer.  This is undesirable, and a
+      ;; simple `save-excursion' doesn't prevent it.
+      (let ((point (point)))
+        (unwind-protect
+            (unwind-protect
+                (progn
+                  (message "%s..." progress-message)
+                  (ert-run-or-rerun-test stats test
+                                         ert--results-listener))
+              (ert--results-update-stats-display ert--results-ewoc stats)
+              (message "%s...%s"
+                       progress-message
+                       (let ((result (ert-test-most-recent-result test)))
+                         (ert-string-for-test-result
+                          result (ert-test-result-expected-p test result)))))
+          (goto-char point))))))
+
+(defun ert-results-rerun-test-at-point-debugging-errors ()
+  "Re-run the test at point with `ert-debug-on-error' bound to t.
+
+To be used in the ERT results buffer."
+  (interactive)
+  (let ((ert-debug-on-error t))
+    (ert-results-rerun-test-at-point)))
+
+(defun ert-results-pop-to-backtrace-for-test-at-point ()
+  "Display the backtrace for the test at point.
+
+To be used in the ERT results buffer."
+  (interactive)
+  (let* ((test (ert--results-test-at-point-no-redefinition))
+         (stats ert--results-stats)
+         (pos (ert--stats-test-pos stats test))
+         (result (aref (ert--stats-test-results stats) pos)))
+    (etypecase result
+      (ert-test-passed (error "Test passed, no backtrace available"))
+      (ert-test-result-with-condition
+       (let ((backtrace (ert-test-result-with-condition-backtrace result))
+             (buffer (get-buffer-create "*ERT Backtrace*")))
+         (pop-to-buffer buffer)
+         (let ((inhibit-read-only t))
+           (buffer-disable-undo)
+           (erase-buffer)
+           (ert-simple-view-mode)
+           ;; Use unibyte because `debugger-setup-buffer' also does so.
+           (set-buffer-multibyte nil)
+           (setq truncate-lines t)
+           (ert--print-backtrace backtrace)
+           (debugger-make-xrefs)
+           (goto-char (point-min))
+           (insert "Backtrace for test `")
+           (ert-insert-test-name-button (ert-test-name test))
+           (insert "':\n")))))))
+
+(defun ert-results-pop-to-messages-for-test-at-point ()
+  "Display the part of the *Messages* buffer generated during the test at point.
+
+To be used in the ERT results buffer."
+  (interactive)
+  (let* ((test (ert--results-test-at-point-no-redefinition))
+         (stats ert--results-stats)
+         (pos (ert--stats-test-pos stats test))
+         (result (aref (ert--stats-test-results stats) pos)))
+    (let ((buffer (get-buffer-create "*ERT Messages*")))
+      (pop-to-buffer buffer)
+      (let ((inhibit-read-only t))
+        (buffer-disable-undo)
+        (erase-buffer)
+        (ert-simple-view-mode)
+        (insert (ert-test-result-messages result))
+        (goto-char (point-min))
+        (insert "Messages for test `")
+        (ert-insert-test-name-button (ert-test-name test))
+        (insert "':\n")))))
+
+(defun ert-results-pop-to-should-forms-for-test-at-point ()
+  "Display the list of `should' forms executed during the test at point.
+
+To be used in the ERT results buffer."
+  (interactive)
+  (let* ((test (ert--results-test-at-point-no-redefinition))
+         (stats ert--results-stats)
+         (pos (ert--stats-test-pos stats test))
+         (result (aref (ert--stats-test-results stats) pos)))
+    (let ((buffer (get-buffer-create "*ERT list of should forms*")))
+      (pop-to-buffer buffer)
+      (let ((inhibit-read-only t))
+        (buffer-disable-undo)
+        (erase-buffer)
+        (ert-simple-view-mode)
+        (if (null (ert-test-result-should-forms result))
+            (insert "\n(No should forms during this test.)\n")
+          (loop for form-description in (ert-test-result-should-forms result)
+                for i from 1 do
+                (insert "\n")
+                (insert (format "%s: " i))
+                (let ((begin (point)))
+                  (ert--pp-with-indentation-and-newline form-description)
+                  (ert--make-xrefs-region begin (point)))))
+        (goto-char (point-min))
+        (insert "`should' forms executed during test `")
+        (ert-insert-test-name-button (ert-test-name test))
+        (insert "':\n")
+        (insert "\n")
+        (insert (concat "(Values are shallow copies and may have "
+                        "looked different during the test if they\n"
+                        "have been modified destructively.)\n"))
+        (forward-line 1)))))
+
+(defun ert-results-toggle-printer-limits-for-test-at-point ()
+  "Toggle how much of the condition to print for the test at point.
+
+To be used in the ERT results buffer."
+  (interactive)
+  (let* ((ewoc ert--results-ewoc)
+         (node (ert--results-test-node-at-point))
+         (entry (ewoc-data node)))
+    (setf (ert--ewoc-entry-extended-printer-limits-p entry)
+          (not (ert--ewoc-entry-extended-printer-limits-p entry)))
+    (ewoc-invalidate ewoc node)))
+
+(defun ert-results-pop-to-timings ()
+  "Display test timings for the last run.
+
+To be used in the ERT results buffer."
+  (interactive)
+  (let* ((stats ert--results-stats)
+         (start-times (ert--stats-test-start-times stats))
+         (end-times (ert--stats-test-end-times stats))
+         (buffer (get-buffer-create "*ERT timings*"))
+         (data (loop for test across (ert--stats-tests stats)
+                     for start-time across (ert--stats-test-start-times stats)
+                     for end-time across (ert--stats-test-end-times stats)
+                     collect (list test
+                                   (float-time (subtract-time end-time
+                                                              start-time))))))
+    (setq data (sort data (lambda (a b)
+                            (> (second a) (second b)))))
+    (pop-to-buffer buffer)
+    (let ((inhibit-read-only t))
+      (buffer-disable-undo)
+      (erase-buffer)
+      (ert-simple-view-mode)
+      (if (null data)
+          (insert "(No data)\n")
+        (insert (format "%-3s  %8s %8s\n" "" "time" "cumul"))
+        (loop for (test time) in data
+              for cumul-time = time then (+ cumul-time time)
+              for i from 1 do
+              (let ((begin (point)))
+                (insert (format "%3s: %8.3f %8.3f " i time cumul-time))
+                (ert-insert-test-name-button (ert-test-name test))
+                (insert "\n"))))
+      (goto-char (point-min))
+      (insert "Tests by run time (seconds):\n\n")
+      (forward-line 1))))
+
+;;;###autoload
+(defun ert-describe-test (test-or-test-name)
+  "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)."
+  (interactive (list (ert-read-test-name-at-point "Describe test")))
+  (when (< emacs-major-version 24)
+    (error "Requires Emacs 24"))
+  (let (test-name
+        test-definition)
+    (etypecase test-or-test-name
+      (symbol (setq test-name test-or-test-name
+                    test-definition (ert-get-test test-or-test-name)))
+      (ert-test (setq test-name (ert-test-name test-or-test-name)
+                      test-definition test-or-test-name)))
+    (help-setup-xref (list #'ert-describe-test test-or-test-name)
+                     (called-interactively-p 'interactive))
+    (save-excursion
+      (with-help-window (help-buffer)
+        (with-current-buffer (help-buffer)
+          (insert (if test-name (format "%S" test-name) "<anonymous test>"))
+          (insert " is a test")
+          (let ((file-name (and test-name
+                                (symbol-file test-name 'ert-deftest))))
+            (when file-name
+              (insert " defined in `" (file-name-nondirectory file-name) "'")
+              (save-excursion
+                (re-search-backward "`\\([^`']+\\)'" nil t)
+                (help-xref-button 1 'help-function-def test-name file-name)))
+            (insert ".")
+            (fill-region-as-paragraph (point-min) (point))
+            (insert "\n\n")
+            (unless (and (ert-test-boundp test-name)
+                         (eql (ert-get-test test-name) test-definition))
+              (let ((begin (point)))
+                (insert "Note: This test has been redefined or deleted, "
+                        "this documentation refers to an old definition.")
+                (fill-region-as-paragraph begin (point)))
+              (insert "\n\n"))
+            (insert (or (ert-test-documentation test-definition)
+                        "It is not documented.")
+                    "\n")))))))
+
+(defun ert-results-describe-test-at-point ()
+  "Display the documentation of the test at point.
+
+To be used in the ERT results buffer."
+  (interactive)
+  (ert-describe-test (ert--results-test-at-point-no-redefinition)))
+
+
+;;; Actions on load/unload.
+
+(add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp))
+(add-to-list 'minor-mode-alist '(ert--current-run-stats
+                                 (:eval
+                                  (ert--tests-running-mode-line-indicator))))
+(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords)
+
+(defun ert--unload-function ()
+  "Unload function to undo the side-effects of loading ert.el."
+  (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car)
+  (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car)
+  (ert--remove-from-list 'emacs-lisp-mode-hook
+                         'ert--activate-font-lock-keywords)
+  nil)
+
+(defvar ert-unload-hook '())
+(add-hook 'ert-unload-hook 'ert--unload-function)
+
+
+(provide 'ert)
+
+;;; ert.el ends here
diff --git a/lib/goto-chg.el b/lib/goto-chg.el
new file mode 100644
index 0000000..3881706
--- /dev/null
+++ b/lib/goto-chg.el
@@ -0,0 +1,317 @@
+;;; goto-chg.el --- goto last change
+;;--------------------------------------------------------------------
+;;
+;; Copyright (C) 2002-2008, David Andersson
+;;
+;; This program 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 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be
+;; useful, but WITHOUT ANY WARRANTY; without even the implied
+;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.  See the GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public
+;; License along with this program; if not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
+;; MA 02111-1307 USA
+;;
+;;-------------------------------------------------------------------
+;;
+;; Author: David Andersson <l.david.andersson(at)sverige.nu>
+;; Created: 16 May 2002
+;; Version: 1.4
+;;
+;;; Commentary:
+;;
+;; Goto Last Change
+;;
+;; Goto the point of the most recent edit in the buffer.
+;; When repeated, goto the second most recent edit, etc.
+;; Negative argument, C-u -, for reverse direction.
+;; Works by looking into buffer-undo-list to find points of edit.
+;;
+;; You would probably like to bind this command to a key.
+;; For example in your ~/.emacs:
+;;
+;;   (require 'goto-chg)
+;;
+;;   (global-set-key [(control ?.)] 'goto-last-change)
+;;   (global-set-key [(control ?,)] 'goto-last-change-reverse)
+;;
+;; Works with emacs-19.29, 19.31, 20.3, 20.7, 21.1, 21.4 and 22.1.
+;; Works with XEmacs-20.4 and 21.4 (but see todo about `last-command' below)
+;;
+;;--------------------------------------------------------------------
+;; History
+;;
+;; Ver 1.4 2008-09-20 David Andersson
+;;    Improved property change description; Update comments.
+;; Ver 1.3 2007-03-14 David Andersson
+;;    Added `goto-last-change-reverse'
+;; Ver 1.2 2003-04-06 David Andersson
+;;    Don't let repeating error depthen glc-probe-depth.
+;; Ver 1.1 2003-04-06 David Andersson
+;;    Zero arg describe changes. Negative arg go back.
+;;    Autoload. Remove message using nil in stead of an empty string.
+;; Ver 1.0 2002-05-18 David Andersson
+;;    Initial version
+;;
+;;--------------------------------------------------------------------
+;;
+;;todo: Rename "goto-chg.el" -> "gotochange.el" or "goto-chgs" ?
+;;todo: Rename function goto-last-change -> goto-last-edit ?
+;;todo: Rename adjective "-last-" -> "-latest-" or "-most-recent-" ?
+;;todo: There are some, maybe useful, funcs  for region undo 
+;;       in simple.el in emacs 20. Take a look.
+;;todo: Add functionality to visit changed point in text order, not only in
+;;        chronological order. (Naa, highlight-changes-mode does that).
+;;todo: Inverse indication that a change has been saved or not
+;;todo: Highlight the range of text involved in the last change?
+;;todo: Function that goes in reverse direction. Either a function
+;;        'goto-next-change' only callable after 'goto-last-change'
+;;        or enter a minor mode similar to isearch.
+;;todo: See session-jump-to-last-change in session.el?
+;;todo: Unhide invisible text (e.g. outline mode) like isearch do.
+;;todo: XEmacs sets last-command to `t' after an error, so you cannot reverse
+;;        after "No furter change info". Should we bother?
+;;todo: Try distinguish "No further change info" (end of truncated undo list)
+;;        and "No further changes" (end of a complete undo list).
+;;
+;;--------------------------------------------------------------------
+
+;;; Code:
+
+(defvar glc-default-span 8 "*goto-last-change don't visit the same point twice. glc-default-span tells how far around a visited point not to visit again.")
+(defvar glc-current-span 8 "Internal for goto-last-change.\nA copy of glc-default-span or the ARG passed to goto-last-change.")
+(defvar glc-probe-depth 0 "Internal for goto-last-change.\nIt is non-zero between successive goto-last-change.")
+
+;;todo: Find begin and end of line, then use it somewhere
+
+(defun glc-center-ellipsis (str maxlen &optional ellipsis)
+  "Truncate STRING in the middle to length MAXLEN.
+If STRING is max MAXLEN just return the string.
+Optional third argument is the replacement, which defaults to \"...\"."
+  (if (<= (length str) maxlen)
+      str
+    ;; else
+    (let* ((lipsis (or ellipsis "..."))
+	   (i (/ (- maxlen (length lipsis)) 2)))
+      (concat (substring str 0 i)
+	      lipsis 
+	      (substring str (- i))))))
+
+(defun glc-adjust-pos2 (pos p1 p2 adj)
+  ;; Helper function to glc-adjust-pos
+  (cond ((<= pos (- p1 glc-current-span))
+	 pos)
+	((> pos (+ p2 glc-current-span))
+	 (+ pos adj))
+	((zerop glc-current-span)
+	 p1)
+	(t
+	 nil)))
+
+(defun glc-adjust-pos (pos e)
+  "Given POS, a buffer position before the edit E, compute and return
+the \"same\" buffer position after E happened.
+Exception: return nil if POS is closer than `glc-current-span' to the edit E.
+\nInsertion edits before POS returns a larger value.
+Deletion edits before POS returns a smaller value.
+\nThe edit E is an entry from the `buffer-undo-list'. See for details."
+  (cond ((atom e)			; nil==cmd boundary, or, num==changed pos
+	 pos)
+	((numberp (car e))		; (beg . end)==insertion
+	 (glc-adjust-pos2 pos (car e) (car e) (- (cdr e) (car e))))
+;; 	 (cond ((< pos (- (car e) glc-current-span)) pos)
+;; 	       ((> pos (+ (car e) glc-current-span)) (+ pos (- (cdr e) (car e))))
+;; 	       (t nil)))
+	((stringp (car e))		; (string . pos)==deletion
+	 (glc-adjust-pos2 pos (abs (cdr e)) (+ (abs (cdr e)) (length (car e))) (- (length (car e)))))
+;; 	 (cond ((< pos (- (abs (cdr e)) glc-current-span)) pos)
+;; 	       ((> pos (+ (abs (cdr e)) (length (car e)) glc-current-span)) (- pos (length (car e))))
+;; 	       (t nil)))
+	((null (car e))			; (nil prop val beg . end)==prop change
+	 (glc-adjust-pos2 pos (nth 3 e) (nthcdr 4 e) 0))
+;; 	 (cond ((< pos (- (nth 3 e) glc-current-span)) pos)
+;; 	       ((> pos (+ (nthcdr 4 e) glc-current-span)) pos)
+;; 	       (t nil)))
+	(t				; (marker . dist)==marker moved
+	 pos)))
+
+;; If recursive in stead of iterative (while), it tends to fill the call stack.
+;; (Isn't it tail optimized?)
+(defun glc-adjust-list (r)
+  "R is list of edit entries in chronological order.
+Pick the point of the first edit entry and update that point with
+the second, third, etc, edit entries. Return the final updated point,
+or nil if the point was closer than `glc-current-span' to some edit in R.
+\nR is basically a reversed slice from the buffer-undo-list."
+  (if r
+      ;; Get pos
+      (let ((pos (glc-get-pos (car r))))
+	(setq r (cdr r))
+	;; Walk back in reverse list
+	(while (and r pos)
+	  (setq pos (glc-adjust-pos pos (car r))
+		r (cdr r)))
+	pos)
+    ;; else
+    nil))
+
+(defun glc-get-pos (e)
+  "If E represents an edit, return a position value in E, the position
+where the edit took place. Return nil if E represents no real change.
+\nE is a entry in the buffer-undo-list."
+  (cond ((numberp e) e)			; num==changed position
+	((atom e) nil)			; nil==command boundary
+	((numberp (car e)) (cdr e))	; (beg . end)==insertion
+	((stringp (car e)) (abs (cdr e))) ; (string . pos)==deletion
+	((null (car e)) (nthcdr 4 e))	; (nil ...)==text property change
+	((atom (car e)) nil)		; (t ...)==file modification time
+	(t nil)))			; (marker ...)==marker moved
+
+(defun glc-get-descript (e &optional n)
+  "If E represents an edit, return a short string describing E.
+Return nil if E represents no real change.
+\nE is a entry in the buffer-undo-list."
+  (let ((nn (or (format "T-%d: " n) "")))
+    (cond ((numberp e) "New position")	; num==changed position
+	  ((atom e) nil)		; nil==command boundary
+	  ((numberp (car e))		; (beg . end)==insertion
+	   (if (and n (< n 2))
+	       (format "%sInserted %d chars \"%s\"" nn (- (cdr e) (car e)) 
+		       (glc-center-ellipsis (buffer-substring (car e) (cdr e)) 60))
+	     ;; else
+	     ;; An older insert. The inserted text cannot easily be computed.
+	     ;; Just show the char count.
+	     (format "%sInserted %d chars" nn (- (cdr e) (car e)))))
+	  ((stringp (car e))		; (string . pos)==deletion
+	   (format "%sDeleted \"%s\"" nn (glc-center-ellipsis (car e) 60)))
+	  ((null (car e))		; (nil ...)==text property change
+	   (format "%sProperty change" nn))
+	  ((atom (car e)) nil)		; (t ...)==file modification time
+	  (t nil))))			; (marker ...)==marker moved
+
+(defun glc-is-positionable (e)
+  "Return non-nil if E is an insertion, deletion or text property change.
+\nE is a entry in the buffer-undo-list."
+  (and (not (numberp e)) (glc-get-pos e)))
+
+(defun glc-is-filetime (e)
+  "Return t if E indicates a buffer became \"modified\",
+that is, it was previously saved or unchanged. Nil otherwise."
+  (and (listp e) (eq (car e) t)))
+
+;;;###autoload
+(defun goto-last-change (arg)
+"Go to the point where the last edit was made in the current buffer.
+Repeat the command to go to the second last edit, etc.
+A preceding \\[universal-argument] - (minus) will reverse direction for the next command in
+the sequence, to go back to a more recent edit.
+\nIt does not go to the same point twice even if there has been many edits
+there. I call the minimal distance between distinguishable edits \"span\".
+Set variable `glc-default-span' to control how close is \"the same point\".
+Default span is 8.
+The span can be changed temporarily with \\[universal-argument] right before \\[goto-last-change]:
+\\[universal-argument] <NUMBER> set current span to that number,
+\\[universal-argument] (no number) multiplies span by 4, starting with default.
+The so set span remains until it is changed again with \\[universal-argument], or the consecutive
+repetition of this command is ended by any other command.
+\nWhen span is zero (i.e. \\[universal-argument] 0) subsequent \\[goto-last-change] visits each and
+every point of edit and a message shows what change was made there.
+In this case it may go to the same point twice.
+\nThis command uses undo information. If undo is disabled, so is this command.
+At times, when undo information becomes too large, the oldest information is
+discarded. See variable `undo-limit'."
+  (interactive "P")
+  (cond ((not (eq this-command last-command))
+	 ;; Start a glc sequence
+	 ;; Don't go to current point if last command was an obvious edit
+	 ;; (yank or self-insert, but not kill-region). Makes it easier to
+	 ;; jump back and forth when copying seleced lines.
+	 (setq glc-probe-depth (if (memq last-command '(yank self-insert-command)) 1 0)
+	       glc-direction 1
+	       glc-current-span glc-default-span)
+	 (if (< (prefix-numeric-value arg) 0)
+	     (error "Negative arg: Cannot reverse as the first operation"))))
+  (cond ((null buffer-undo-list)
+	 (error "Buffer has not been changed"))
+	((eq buffer-undo-list t)
+	 (error "No change info (undo is disabled)")))
+  (cond ((numberp arg)			; Numeric arg sets span
+	 (setq glc-current-span (abs arg)))
+	((consp arg)			; C-u's multiply previous span by 4
+	 (setq glc-current-span (* (abs (car arg)) glc-default-span))
+	 (message "Current span is %d chars" glc-current-span))) ;todo: keep message with "waiting" and "is saved"
+  (cond ((< (prefix-numeric-value arg) 0)
+	 (setq glc-direction -1))
+	(t
+	 (setq glc-direction 1)))
+  (let (rev				; Reversed (and filtered) undo list
+	pos				; The pos we look for, nil until found
+	(n 0)				; Steps in undo list (length of 'rev')
+	(l buffer-undo-list) 
+	(passed-save-entry (not (buffer-modified-p)))
+	(new-probe-depth glc-probe-depth))
+    ;; Walk back and forth in the buffer-undo-list, each time one step deeper,
+    ;; until we can walk back the whole list with a 'pos' that is not coming
+    ;; too close to another edit.
+    (while (null pos)
+      (setq new-probe-depth (+ new-probe-depth glc-direction))
+      (if (< glc-direction 0)
+	  (setq rev ()
+		n 0
+		l buffer-undo-list
+		passed-save-entry (not (buffer-modified-p))))
+      (if (< new-probe-depth 1)
+	  (error "No later change info"))
+      (if (> n 150)
+	  (message "working..."))
+      ;; Walk forward in buffer-undo-list, glc-probe-depth steps.
+      ;; Build reverse list along the way
+      (while (< n new-probe-depth)
+	(cond ((null l)
+	       ;(setq this-command t)	; Disrupt repeat sequence
+	       (error "No further change info"))
+	      ((glc-is-positionable (car l))
+	       (setq n (1+ n)
+		     rev (cons (car l) rev)))
+	      ((or passed-save-entry (glc-is-filetime (car l)))
+	       (setq passed-save-entry t)))
+	(setq l (cdr l)))
+      ;; Walk back in reverse list, from older to newer edits.
+      ;; Adjusting pos along the way.
+      (setq pos (glc-adjust-list rev)))
+    ;; Found a place not previously visited, in 'pos'.
+    ;; (An error have been issued if nothing (more) found.)
+    (if (> n 150)
+	(message nil))			; remove message "working..."
+    (if (and (= glc-current-span 0) (glc-get-descript (car rev) n))
+	(message "%s" (glc-get-descript (car rev) n))
+      ;; else
+      (if passed-save-entry
+	  (message "(This change is saved)")))
+    (setq glc-probe-depth new-probe-depth)
+    (goto-char pos)))
+
+;; ;;;###autoload
+(defun goto-last-change-reverse (arg)
+  (interactive "P")
+  ;; Negate arg, all kinds
+  (cond ((eq arg nil)  (setq arg '-))
+	((eq arg '-)   (setq arg nil))
+	((listp arg)   (setq arg (list (- (car arg)))))
+	(t (setq arg   (- arg))))
+  ;; Make 'goto-last-change-reverse' look like 'goto-last-change'
+  (cond ((eq last-command this-command)
+	 (setq last-command 'goto-last-change)))
+  (setq this-command 'goto-last-change)
+  ;; Call 'goto-last-change' to do the job
+  (goto-last-change arg))
+
+(provide 'goto-chg)
+
+;;; goto-chg.el ends here
diff --git a/lib/undo-tree.el b/lib/undo-tree.el
new file mode 100644
index 0000000..4edfa9d
--- /dev/null
+++ b/lib/undo-tree.el
@@ -0,0 +1,3075 @@
+
+;;; undo-tree.el --- Treat undo history as a tree
+
+
+;; Copyright (C) 2009-2011 Toby Cubitt
+
+;; Author: Toby Cubitt <toby-undo-tree@dr-qubit.org>
+;; Version: 0.3
+;; Keywords: undo, redo, history, tree
+;; URL: http://www.dr-qubit.org/emacs.php
+;; Git Repository: http://www.dr-qubit.org/git/undo-tree.git
+
+;; This file is NOT part of Emacs.
+;;
+;; This file 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 of the License, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
+;; more details.
+;;
+;; You should have received a copy of the GNU General Public License along
+;; with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Commentary:
+;;
+;; Emacs has a powerful undo system. Unlike the standard undo/redo system in
+;; most software, it allows you to recover *any* past state of a buffer
+;; (whereas the standard undo/redo system can lose past states as soon as you
+;; redo). However, this power comes at a price: many people find Emacs' undo
+;; system confusing and difficult to use, spawning a number of packages that
+;; replace it with the less powerful but more intuitive undo/redo system.
+;;
+;; Both the loss of data with standard undo/redo, and the confusion of Emacs'
+;; undo, stem from trying to treat undo history as a linear sequence of
+;; changes. It's not. The `undo-tree-mode' provided by this package replaces
+;; Emacs' undo system with a system that treats undo history as what it is: a
+;; branching tree of changes. This simple idea allows the more intuitive
+;; behaviour of the standard undo/redo system to be combined with the power of
+;; never losing any history. An added side bonus is that undo history can in
+;; some cases be stored more efficiently, allowing more changes to accumulate
+;; before Emacs starts discarding history.
+;;
+;; The only downside to this more advanced yet simpler undo system is that it
+;; was inspired by Vim. But, after all, most successful religions steal the
+;; best ideas from their competitors!
+;;
+;;
+;; Installation
+;; ============
+;;
+;; This package has only been tested with Emacs versions 22, 23 and CVS. It
+;; will not work without modifications in earlier versions of Emacs.
+;;
+;; To install `undo-tree-mode', make sure this file is saved in a directory in
+;; your `load-path', and add the line:
+;;
+;;   (require 'undo-tree)
+;;
+;; to your .emacs file. Byte-compiling undo-tree.el is recommended (e.g. using
+;; "M-x byte-compile-file" from within emacs).
+;;
+;; If you want to replace the standard Emacs' undo system with the
+;; `undo-tree-mode' system in all buffers, you can enable it globally by
+;; adding:
+;;
+;;   (global-undo-tree-mode)
+;;
+;; to your .emacs file.
+;;
+;;
+;; Quick-Start
+;; ===========
+;;
+;; If you're the kind of person who likes jump in the car and drive, without
+;; bothering to first figure out whether the button on the left dips the
+;; headlights or operates the ejector seat (after all, you'll soon figure it
+;; out when you push it), then here's the minimum you need to know:
+;;
+;; `undo-tree-mode' and `global-undo-tree-mode'
+;;   Enable undo-tree mode (either in the current buffer or globally).
+;;
+;; C-_  C-/  (`undo-tree-undo')
+;;   Undo changes.
+;;
+;; M-_  C-?  (`undo-tree-redo')
+;;   Redo changes.
+;;
+;; `undo-tree-switch-branch'
+;;   Switch undo-tree branch.
+;;   (What does this mean? Better press the button and see!)
+;;
+;; C-x u  (`undo-tree-visualize')
+;;   Visualize the undo tree.
+;;   (Better try pressing this button too!)
+;;
+;; C-x r u  (`undo-tree-save-state-to-register')
+;;   Save current buffer state to register.
+;;
+;; C-x r U  (`undo-tree-restore-state-from-register')
+;;   Restore buffer state from register.
+;;
+;;
+;; In the undo-tree visualizer:
+;;
+;; <up>  p  C-p  (`undo-tree-visualize-undo')
+;;   Undo changes.
+;;
+;; <down>  n  C-n  (`undo-tree-visualize-redo')
+;;   Redo changes.
+;;
+;; <left>  b  C-b  (`undo-tree-visualize-switch-branch-left')
+;;   Switch to previous undo-tree branch.
+;;
+;; <right>  f  C-f  (`undo-tree-visualize-switch-branch-right')
+;;   Switch to next undo-tree branch.
+;;
+;; t  (`undo-tree-visualizer-toggle-timestamps')
+;;   Toggle display of time-stamps.
+;;
+;; q  C-q  (`undo-tree-visualizer-quit')
+;;   Quit undo-tree-visualizer.
+;;
+;; ,  <
+;;   Scroll left.
+;;
+;; .  >
+;;   Scroll right.
+;;
+;; <pgup>
+;;   Scroll up.
+;;
+;; <pgdown>
+;;   Scroll down.
+;;
+;;
+;;
+;; Undo Systems
+;; ============
+;;
+;; To understand the different undo systems, it's easiest to consider an
+;; example. Imagine you make a few edits in a buffer. As you edit, you
+;; accumulate a history of changes, which we might visualize as a string of
+;; past buffer states, growing downwards:
+;;
+;;                                o  (initial buffer state)
+;;                                |
+;;                                |
+;;                                o  (first edit)
+;;                                |
+;;                                |
+;;                                o  (second edit)
+;;                                |
+;;                                |
+;;                                x  (current buffer state)
+;;
+;;
+;; Now imagine that you undo the last two changes. We can visualize this as
+;; rewinding the current state back two steps:
+;;
+;;                                o  (initial buffer state)
+;;                                |
+;;                                |
+;;                                x  (current buffer state)
+;;                                |
+;;                                |
+;;                                o
+;;                                |
+;;                                |
+;;                                o
+;;
+;;
+;; However, this isn't a good representation of what Emacs' undo system
+;; does. Instead, it treats the undos as *new* changes to the buffer, and adds
+;; them to the history:
+;;
+;;                                o  (initial buffer state)
+;;                                |
+;;                                |
+;;                                o  (first edit)
+;;                                |
+;;                                |
+;;                                o  (second edit)
+;;                                |
+;;                                |
+;;                                x  (buffer state before undo)
+;;                                |
+;;                                |
+;;                                o  (first undo)
+;;                                |
+;;                                |
+;;                                x  (second undo)
+;;
+;;
+;; Actually, since the buffer returns to a previous state after an undo,
+;; perhaps a better way to visualize it is to imagine the string of changes
+;; turning back on itself:
+;;
+;;        (initial buffer state)  o
+;;                                |
+;;                                |
+;;                  (first edit)  o  x  (second undo)
+;;                                |  |
+;;                                |  |
+;;                 (second edit)  o  o  (first undo)
+;;                                | /
+;;                                |/
+;;                                o  (buffer state before undo)
+;;
+;; Treating undos as new changes might seem a strange thing to do. But the
+;; advantage becomes clear as soon as we imagine what happens when you edit
+;; the buffer again. Since you've undone a couple of changes, new edits will
+;; branch off from the buffer state that you've rewound to. Conceptually, it
+;; looks like this:
+;;
+;;                                o  (initial buffer state)
+;;                                |
+;;                                |
+;;                                o
+;;                                |\
+;;                                | \
+;;                                o  x  (new edit)
+;;                                |
+;;                                |
+;;                                o
+;;
+;; The standard undo/redo system only lets you go backwards and forwards
+;; linearly. So as soon as you make that new edit, it discards the old
+;; branch. Emacs' undo just keeps adding changes to the end of the string. So
+;; the undo history in the two systems now looks like this:
+;;
+;;            Undo/Redo:                      Emacs' undo
+;;
+;;               o                                o
+;;               |                                |
+;;               |                                |
+;;               o                                o  o
+;;               .\                               |  |\
+;;               . \                              |  | \
+;;               .  x  (new edit)                 o  o  |
+;;   (discarded  .                                | /   |
+;;     branch)   .                                |/    |
+;;               .                                o     |
+;;                                                      |
+;;                                                      |
+;;                                                      x  (new edit)
+;;
+;; Now, what if you change your mind about those undos, and decide you did
+;; like those other changes you'd made after all? With the standard undo/redo
+;; system, you're lost. There's no way to recover them, because that branch
+;; was discarded when you made the new edit.
+;;
+;; However, in Emacs' undo system, those old buffer states are still there in
+;; the undo history. You just have to rewind back through the new edit, and
+;; back through the changes made by the undos, until you reach them. Of
+;; course, since Emacs treats undos (even undos of undos!) as new changes,
+;; you're really weaving backwards and forwards through the history, all the
+;; time adding new changes to the end of the string as you go:
+;;
+;;                       o
+;;                       |
+;;                       |
+;;                       o  o     o  (undo new edit)
+;;                       |  |\    |\
+;;                       |  | \   | \
+;;                       o  o  |  |  o  (undo the undo)
+;;                       | /   |  |  |
+;;                       |/    |  |  |
+;;      (trying to get   o     |  |  x  (undo the undo)
+;;       to this state)        | /
+;;                             |/
+;;                             o
+;;
+;; So far, this is still reasonably intuitive to use. It doesn't behave so
+;; differently to standard undo/redo, except that by going back far enough you
+;; can access changes that would be lost in standard undo/redo.
+;;
+;; However, imagine that after undoing as just described, you decide you
+;; actually want to rewind right back to the initial state. If you're lucky,
+;; and haven't invoked any command since the last undo, you can just keep on
+;; undoing until you get back to the start:
+;;
+;;      (trying to get   o              x  (got there!)
+;;       to this state)  |              |
+;;                       |              |
+;;                       o  o     o     o  (keep undoing)
+;;                       |  |\    |\    |
+;;                       |  | \   | \   |
+;;                       o  o  |  |  o  o  (keep undoing)
+;;                       | /   |  |  | /
+;;                       |/    |  |  |/
+;;      (already undid   o     |  |  o  (got this far)
+;;       to this state)        | /
+;;                             |/
+;;                             o
+;;
+;; But if you're unlucky, and you happen to have moved the point (say) after
+;; getting to the state labelled "got this far", then you've "broken the undo
+;; chain". Hold on to something solid, because things are about to get
+;; hairy. If you try to undo now, Emacs thinks you're trying to undo the
+;; undos! So to get back to the initial state you now have to rewind through
+;; *all* the changes, including the undos you just did:
+;;
+;;      (trying to get   o                          x  (finally got there!)
+;;       to this state)  |                          |
+;;                       |                          |
+;;                       o  o     o     o     o     o
+;;                       |  |\    |\    |\    |\    |
+;;                       |  | \   | \   | \   | \   |
+;;                       o  o  |  |  o  o  o  |  o  o
+;;                       | /   |  |  | /   |  |  | /
+;;                       |/    |  |  |/    |  |  |/
+;;      (already undid   o     |  |  o<.   |  |  o
+;;       to this state)        | /     :   | /
+;;                             |/      :   |/
+;;                             o       :   o
+;;                                     :
+;;                             (got this far, but
+;;                              broke the undo chain)
+;;
+;; Confused?
+;;
+;; In practice you can just hold down the undo key until you reach the buffer
+;; state that you want. But whatever you do, don't move around in the buffer
+;; to *check* that you've got back to where you want! Because you'll break the
+;; undo chain, and then you'll have to traverse the entire string of undos
+;; again, just to get back to the point at which you broke the
+;; chain. Undo-in-region and commands such as `undo-only' help to make using
+;; Emacs' undo a little easier, but nonetheless it remains confusing for many
+;; people.
+;;
+;;
+;; So what does `undo-tree-mode' do? Remember the diagram we drew to represent
+;; the history we've been discussing (make a few edits, undo a couple of them,
+;; and edit again)? The diagram that conceptually represented our undo
+;; history, before we started discussing specific undo systems? It looked like
+;; this:
+;;
+;;                                o  (initial buffer state)
+;;                                |
+;;                                |
+;;                                o
+;;                                |\
+;;                                | \
+;;                                o  x  (current state)
+;;                                |
+;;                                |
+;;                                o
+;;
+;; Well, that's *exactly* what the undo history looks like to
+;; `undo-tree-mode'.  It doesn't discard the old branch (as standard undo/redo
+;; does), nor does it treat undos as new changes to be added to the end of a
+;; linear string of buffer states (as Emacs' undo does). It just keeps track
+;; of the tree of branching changes that make up the entire undo history.
+;;
+;; If you undo from this point, you'll rewind back up the tree to the previous
+;; state:
+;;
+;;                                o
+;;                                |
+;;                                |
+;;                                x  (undo)
+;;                                |\
+;;                                | \
+;;                                o  o
+;;                                |
+;;                                |
+;;                                o
+;;
+;; If you were to undo again, you'd rewind back to the initial state. If on
+;; the other hand you redo the change, you'll end up back at the bottom of the
+;; most recent branch:
+;;
+;;                                o  (undo takes you here)
+;;                                |
+;;                                |
+;;                                o  (start here)
+;;                                |\
+;;                                | \
+;;                                o  x  (redo takes you here)
+;;                                |
+;;                                |
+;;                                o
+;;
+;; So far, this is just like the standard undo/redo system. But what if you
+;; want to return to a buffer state located on a previous branch of the
+;; history? Since `undo-tree-mode' keeps the entire history, you simply need
+;; to tell it to switch to a different branch, and then redo the changes you
+;; want:
+;;
+;;                                o
+;;                                |
+;;                                |
+;;                                o  (start here, but switch
+;;                                |\  to the other branch)
+;;                                | \
+;;                        (redo)  o  o
+;;                                |
+;;                                |
+;;                        (redo)  x
+;;
+;; Now you're on the other branch, if you undo and redo changes you'll stay on
+;; that branch, moving up and down through the buffer states located on that
+;; branch. Until you decide to switch branches again, of course.
+;;
+;; Real undo trees might have multiple branches and sub-branches:
+;;
+;;                                o
+;;                            ____|______
+;;                           /           \
+;;                          o             o
+;;                      ____|__         __|
+;;                     /    |  \       /   \
+;;                    o     o   o     o     x
+;;                    |               |
+;;                   / \             / \
+;;                  o   o           o   o
+;;
+;; Trying to imagine what Emacs' undo would do as you move about such a tree
+;; will likely frazzle your brain circuits! But in `undo-tree-mode', you're
+;; just moving around this undo history tree. Most of the time, you'll
+;; probably only need to stay on the most recent branch, in which case it
+;; behaves like standard undo/redo, and is just as simple to understand. But
+;; if you ever need to recover a buffer state on a different branch, the
+;; possibility of switching between branches and accessing the full undo
+;; history is still there.
+;;
+;;
+;;
+;; The Undo-Tree Visualizer
+;; ========================
+;;
+;; Actually, it gets better. You don't have to imagine all these tree
+;; diagrams, because `undo-tree-mode' includes an undo-tree visualizer which
+;; draws them for you! In fact, it draws even better diagrams: it highlights
+;; the node representing the current buffer state, it highlights the current
+;; branch, and (by hitting "t") you can toggle the display of
+;; time-stamps. (There's one other tiny difference: the visualizer puts the
+;; most recent branch on the left rather than the right.)
+;;
+;; In the visualizer, the usual keys for moving up and down a buffer instead
+;; move up and down the undo history tree (e.g. the up and down arrow keys, or
+;; "C-n" and "C-p"). The state of the "parent" buffer (the buffer whose undo
+;; history you are visualizing) is updated as you move around the undo tree in
+;; the visualizer. If you reach a branch point in the visualizer, the usual
+;; keys for moving forward and backward in a buffer instead switch branch
+;; (e.g. the left and right arrow keys, or "C-f" and "C-b"). And clicking with
+;; the mouse on any node in the visualizer will take you directly to that
+;; node, resetting the state of the parent buffer to the state represented by
+;; that node.
+;;
+;; It can be useful to see how long ago the parent buffer was in the state
+;; represented by a particular node in the visualizer. Hitting "t" in the
+;; visualizer toggles the display of time-stamps for all the nodes. (Note
+;; that, because of the way `undo-tree-mode' works, these time-stamps may be
+;; somewhat later than the true times, especially if it's been a long time
+;; since you last undid any changes.)
+;;
+;; Finally, hitting "q" will quit the visualizer, leaving the parent buffer in
+;; whatever state you ended at.
+;;
+;;
+;;
+;; Undo-in-Region
+;; ==============
+;;
+;; Emacs allows a very useful and powerful method of undoing only selected
+;; changes: when a region is active, only changes that affect the text within
+;; that region will are undone. With the standard Emacs undo system, changes
+;; produced by undoing-in-region naturally get added onto the end of the
+;; linear undo history:
+;;
+;;                       o
+;;                       |
+;;                       |  x  (second undo-in-region)
+;;                       o  |
+;;                       |  |
+;;                       |  o  (first undo-in-region)
+;;                       o  |
+;;                       | /
+;;                       |/
+;;                       o
+;;
+;; You can of course redo these undos-in-region as usual, by undoing the
+;; undos:
+;;
+;;                       o
+;;                       |
+;;                       |  o_
+;;                       o  | \
+;;                       |  |  |
+;;                       |  o  o  (undo the undo-in-region)
+;;                       o  |  |
+;;                       | /   |
+;;                       |/    |
+;;                       o     x  (undo the undo-in-region)
+;;
+;;
+;; In `undo-tree-mode', undo-in-region works similarly: when there's an active
+;; region, undoing only undoes changes that affect that region. However, the
+;; way these undos-in-region are recorded in the undo history is quite
+;; different. In `undo-tree-mode', undo-in-region creates a new branch in the
+;; undo history. The new branch consists of an undo step that undoes some of
+;; the changes that affect the current region, and another step that undoes
+;; the remaining changes needed to rejoin the previous undo history.
+;;
+;;      Previous undo history                Undo-in-region
+;;
+;;               o                                o
+;;               |                                |
+;;               |                                |
+;;               o                                o
+;;               |                                |\
+;;               |                                | \
+;;               o                                o  x  (undo-in-region)
+;;               |                                |  |
+;;               |                                |  |
+;;               x                                o  o
+;;
+;; As long as you don't change the active region after undoing-in-region,
+;; continuing to undo-in-region extends the new branch, pulling more changes
+;; that affect the current region into an undo step immediately above your
+;; current location in the undo tree, and pushing the point at which the new
+;; branch is attached further up the tree:
+;;
+;;      First undo-in-region                 Second undo-in-region
+;;
+;;               o                                o
+;;               |                                |\
+;;               |                                | \
+;;               o                                o  x  (undo-in-region)
+;;               |\                               |  |
+;;               | \                              |  |
+;;               o  x                             o  o
+;;               |  |                             |  |
+;;               |  |                             |  |
+;;               o  o                             o  o
+;;
+;; Redoing takes you back down the undo tree, as usual (as long as you haven't
+;; changed the active region after undoing-in-region, it doesn't matter if it
+;; is still active):
+;;
+;;                       o
+;;			 |\
+;;			 | \
+;;			 o  o
+;;			 |  |
+;;			 |  |
+;;			 o  o  (redo)
+;;			 |  |
+;;			 |  |
+;;			 o  x  (redo)
+;;
+;;
+;; What about redo-in-region? Obviously, this only makes sense if you have
+;; already undone some changes, so that there are some changes to redo!
+;; Redoing-in-region splits off a new branch of the undo history below your
+;; current location in the undo tree. This time, the new branch consists of a
+;; redo step that redoes some of the redo changes that affect the current
+;; region, followed by all the remaining redo changes.
+;;
+;;      Previous undo history                Redo-in-region
+;;
+;;               o                                o
+;;               |                                |
+;;               |                                |
+;;               x                                o
+;;               |                                |\
+;;               |                                | \
+;;               o                                o  x  (redo-in-region)
+;;               |                                |  |
+;;               |                                |  |
+;;               o                                o  o
+;;
+;; As long as you don't change the active region after redoing-in-region,
+;; continuing to redo-in-region extends the new branch, pulling more redo
+;; changes into a redo step immediately below your current location in the
+;; undo tree.
+;;
+;;      First redo-in-region                 Second redo-in-region
+;;
+;;          o                                     o
+;;          |                                     |
+;;          |                                     |
+;;          o                                     o
+;;          |\                                    |\
+;;          | \                                   | \
+;;          o  x  (redo-in-region)                o  o
+;;          |  |                                  |  |
+;;          |  |                                  |  |
+;;          o  o                                  o  x  (redo-in-region)
+;;                                                   |
+;;                                                   |
+;;                                                   o
+;;
+;; Note that undo-in-region and redo-in-region only ever add new changes to
+;; the undo tree, they *never* modify existing undo history. So you can always
+;; return to previous buffer states by switching to a previous branch of the
+;; tree.
+
+
+
+;;; Change Log:
+;;
+;; Version 0.3
+;; * implemented undo-in-region
+;; * fixed bugs in `undo-list-transfer-to-tree' and
+;;   `undo-list-rebuild-from-tree' which caused errors when undo history was
+;;   empty or disabled
+;; * defun `region-active-p' if not already defined, for compatibility with
+;;   older Emacsen
+;;
+;; Version 0.2.1
+;; * modified `undo-tree-node' defstruct and macros to allow arbitrary
+;;   meta-data to be stored in a plist associated with a node, and
+;;   reimplemented storage of visualizer data on top of this
+;; * display registers storing undo-tree state in visualizer
+;; * implemented keyboard selection in visualizer
+;; * rebuild `buffer-undo-list' from tree when disabling `undo-tree-mode'
+;;
+;; Version 0.2
+;; * added support for marker undo entries
+;;
+;; Version 0.1.7
+;; * pass null argument to `kill-buffer' call in `undo-tree-visualizer-quit',
+;;   since the argument's not optional in earlier Emacs versions
+;; * added match for "No further redo information" to
+;;   `debug-ignored-errors' to prevent debugger being called on this error
+;; * made `undo-tree-visualizer-quit' select the window displaying the
+;;   visualizer's parent buffer, or switch to the parent buffer if no window
+;;   is displaying it
+;; * fixed bug in `undo-tree-switch-branch'
+;; * general code tidying and reorganisation
+;; * fixed bugs in history-discarding logic
+;; * fixed bug in `undo-tree-insert' triggered by `undo-tree-visualizer-set'
+;;   by ensuring mark is deactivated
+;;
+;; Version 0.1.6
+;; * added `undo-tree-mode-lighter' customization option to allow the
+;;   mode-line lighter to be changed
+;; * bug-fix in `undo-tree-discard-node'
+;; * added `undo-tree-save-state-to-register' and
+;;   `undo-tree-restore-state-from-register' commands and keybindings for
+;;   saving/restoring undo-tree states using registers
+;;
+;; Version 0.1.5
+;; * modified `undo-tree-visualize' to mark the visualizer window as
+;;   soft-dedicated, and changed `undo-tree-visualizer-quit' to use
+;;   `kill-buffer', so that the visualizer window is deleted along with its
+;;   buffer if the visualizer buffer was displayed in a new window, but not if
+;;   it was displayed in an existing window.
+;;
+;; Version 0.1.4
+;; * modified `undo-tree-undo' and `undo-tree-redo' to always replace
+;;   redo/undo entries with new ones generated by `primitive-undo', as the new
+;;   changesets will restore the point more reliably
+;;
+;; Version 0.1.3
+;; * fixed `undo-tree-visualizer-quit' to remove `after-change-functions'
+;;   hook there, rather than in `undo-tree-kill-visualizer'
+;;
+;; Version 0.1.2
+;; * fixed keybindings
+;; * renamed `undo-tree-visualizer-switch-previous-branch' and
+;;   `undo-tree-visualizer-switch-next-branch' to
+;;   `undo-tree-visualizer-switch-branch-left' and
+;;   `undo-tree-visualizer-switch-branch-right'
+;;
+;; Version 0.1.1
+;; * prevented `undo-tree-kill-visualizer' from killing visualizer when
+;;   undoing/redoing from the visualizer, which completely broke the
+;;   visualizer!
+;; * changed one redo binding, so that at least one set of undo/redo bindings
+;;   works in a terminal
+;; * bound vertical scrolling commands in `undo-tree-visualizer-map', in case
+;;   they aren't bound globally
+;; * added missing :group argument to `defface's
+;;
+;; Version 0.1
+;; * initial release
+
+
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+;; `characterp' isn't defined in Emacs versions <= 22
+(unless (fboundp 'characterp)
+  (defalias 'characterp 'char-valid-p))
+
+;; `region-active-p' isn't defined in Emacs versions <= 22
+(unless (fboundp 'region-active-p)
+  (defun region-active-p () (and transient-mark-mode mark-active)))
+
+
+
+;;; =====================================================================
+;;;              Global variables and customization options
+
+(defvar buffer-undo-tree nil
+  "Tree of undo entries in current buffer.")
+(make-variable-buffer-local 'buffer-undo-tree)
+
+
+(defgroup undo-tree nil
+  "Tree undo/redo."
+  :group 'undo)
+
+(defcustom undo-tree-mode-lighter " Undo-Tree"
+  "Lighter displayed in mode line
+when `undo-tree-mode' is enabled."
+  :group 'undo-tree
+  :type 'string)
+
+(defcustom undo-tree-visualizer-spacing 3
+  "Horizontal spacing in undo-tree visualization.
+Must be a postivie odd integer."
+  :group 'undo-tree
+  :type '(integer
+          :match (lambda (w n) (and (integerp n) (> n 0) (= (mod n 2) 1)))))
+(make-variable-buffer-local 'undo-tree-visualizer-spacing)
+
+(defvar undo-tree-map nil
+  "Keymap used in undo-tree-mode.")
+
+
+(defface undo-tree-visualizer-default-face
+  '((((class color)) :foreground "gray"))
+  "*Face used to draw undo-tree in visualizer."
+  :group 'undo-tree)
+
+(defface undo-tree-visualizer-current-face
+  '((((class color)) :foreground "red"))
+  "*Face used to highlight current undo-tree node in visualizer."
+  :group 'undo-tree)
+
+(defface undo-tree-visualizer-active-branch-face
+  '((((class color) (background dark))
+     (:foreground "white" :weight bold))
+    (((class color) (background light))
+     (:foreground "black" :weight bold)))
+  "*Face used to highlight active undo-tree branch
+in visualizer."
+  :group 'undo-tree)
+
+(defface undo-tree-visualizer-register-face
+  '((((class color)) :foreground "yellow"))
+  "*Face used to highlight undo-tree nodes saved to a register
+in visualizer."
+  :group 'undo-tree)
+
+(defvar undo-tree-visualizer-map nil
+  "Keymap used in undo-tree visualizer.")
+
+(defvar undo-tree-visualizer-selection-map nil
+  "Keymap used in undo-tree visualizer selection mode.")
+
+
+(defvar undo-tree-visualizer-parent-buffer nil
+  "Parent buffer in visualizer.")
+(make-variable-buffer-local 'undo-tree-visualizer-parent-buffer)
+
+(defvar undo-tree-visualizer-timestamps nil
+  "Non-nil when visualizer is displaying time-stamps.")
+(make-variable-buffer-local 'undo-tree-visualizer-timestamps)
+
+(defconst undo-tree-visualizer-buffer-name " *undo-tree*")
+
+;; prevent debugger being called on "No further redo information"
+(add-to-list 'debug-ignored-errors "^No further redo information")
+
+
+
+
+;;; =================================================================
+;;;                     Setup default keymaps
+
+(unless undo-tree-map
+  (setq undo-tree-map (make-sparse-keymap))
+  ;; remap `undo' and `undo-only' to `undo-tree-undo'
+  (define-key undo-tree-map [remap undo] 'undo-tree-undo)
+  (define-key undo-tree-map [remap undo-only] 'undo-tree-undo)
+  ;; bind standard undo bindings (since these match redo counterparts)
+  (define-key undo-tree-map (kbd "C-/") 'undo-tree-undo)
+  (define-key undo-tree-map "\C-_" 'undo-tree-undo)
+  ;; redo doesn't exist normally, so define our own keybindings
+  (define-key undo-tree-map (kbd "C-?") 'undo-tree-redo)
+  (define-key undo-tree-map (kbd "M-_") 'undo-tree-redo)
+  ;; just in case something has defined `redo'...
+  (define-key undo-tree-map [remap redo] 'undo-tree-redo)
+  ;; we use "C-x u" for the undo-tree visualizer
+  (define-key undo-tree-map (kbd "\C-x u") 'undo-tree-visualize)
+  ;; bind register commands
+  (define-key undo-tree-map (kbd "C-x r u")
+    'undo-tree-save-state-to-register)
+  (define-key undo-tree-map (kbd "C-x r U")
+    'undo-tree-restore-state-from-register))
+
+
+(unless undo-tree-visualizer-map
+  (setq undo-tree-visualizer-map (make-keymap))
+  ;; vertical motion keys undo/redo
+  (define-key undo-tree-visualizer-map [remap previous-line]
+    'undo-tree-visualize-undo)
+  (define-key undo-tree-visualizer-map [remap next-line]
+    'undo-tree-visualize-redo)
+  (define-key undo-tree-visualizer-map [up]
+    'undo-tree-visualize-undo)
+  (define-key undo-tree-visualizer-map "p"
+    'undo-tree-visualize-undo)
+  (define-key undo-tree-visualizer-map "\C-p"
+    'undo-tree-visualize-undo)
+  (define-key undo-tree-visualizer-map [down]
+    'undo-tree-visualize-redo)
+  (define-key undo-tree-visualizer-map "n"
+    'undo-tree-visualize-redo)
+  (define-key undo-tree-visualizer-map "\C-n"
+    'undo-tree-visualize-redo)
+  ;; horizontal motion keys switch branch
+  (define-key undo-tree-visualizer-map [remap forward-char]
+    'undo-tree-visualize-switch-branch-right)
+  (define-key undo-tree-visualizer-map [remap backward-char]
+    'undo-tree-visualize-switch-branch-left)
+  (define-key undo-tree-visualizer-map [right]
+    'undo-tree-visualize-switch-branch-right)
+  (define-key undo-tree-visualizer-map "f"
+    'undo-tree-visualize-switch-branch-right)
+  (define-key undo-tree-visualizer-map "\C-f"
+    'undo-tree-visualize-switch-branch-right)
+  (define-key undo-tree-visualizer-map [left]
+    'undo-tree-visualize-switch-branch-left)
+  (define-key undo-tree-visualizer-map "b"
+    'undo-tree-visualize-switch-branch-left)
+  (define-key undo-tree-visualizer-map "\C-b"
+    'undo-tree-visualize-switch-branch-left)
+  ;; mouse sets buffer state to node at click
+  (define-key undo-tree-visualizer-map [mouse-1]
+    'undo-tree-visualizer-mouse-set)
+  ;; toggle timestamps
+  (define-key undo-tree-visualizer-map "t"
+    'undo-tree-visualizer-toggle-timestamps)
+  ;; selection mode
+  (define-key undo-tree-visualizer-map "s"
+    'undo-tree-visualizer-selection-mode)
+  ;; horizontal scrolling may be needed if the tree is very wide
+  (define-key undo-tree-visualizer-map ","
+    'undo-tree-visualizer-scroll-left)
+  (define-key undo-tree-visualizer-map "."
+    'undo-tree-visualizer-scroll-right)
+  (define-key undo-tree-visualizer-map "<"
+    'undo-tree-visualizer-scroll-left)
+  (define-key undo-tree-visualizer-map ">"
+    'undo-tree-visualizer-scroll-right)
+  ;; vertical scrolling may be needed if the tree is very tall
+  (define-key undo-tree-visualizer-map [next] 'scroll-up)
+  (define-key undo-tree-visualizer-map [prior] 'scroll-down)
+  ;; quit visualizer
+  (define-key undo-tree-visualizer-map "q"
+    'undo-tree-visualizer-quit)
+  (define-key undo-tree-visualizer-map "\C-q"
+    'undo-tree-visualizer-quit))
+
+
+(unless undo-tree-visualizer-selection-map
+  (setq undo-tree-visualizer-selection-map (make-keymap))
+  ;; vertical motion keys move up and down tree
+  (define-key undo-tree-visualizer-selection-map [remap previous-line]
+    'undo-tree-visualizer-select-previous)
+  (define-key undo-tree-visualizer-selection-map [remap next-line]
+    'undo-tree-visualizer-select-next)
+  (define-key undo-tree-visualizer-selection-map [up]
+    'undo-tree-visualizer-select-previous)
+  (define-key undo-tree-visualizer-selection-map "p"
+    'undo-tree-visualizer-select-previous)
+  (define-key undo-tree-visualizer-selection-map "\C-p"
+    'undo-tree-visualizer-select-previous)
+  (define-key undo-tree-visualizer-selection-map [down]
+    'undo-tree-visualizer-select-next)
+  (define-key undo-tree-visualizer-selection-map "n"
+    'undo-tree-visualizer-select-next)
+  (define-key undo-tree-visualizer-selection-map "\C-n"
+    'undo-tree-visualizer-select-next)
+  ;; vertical scroll keys move up and down quickly
+  (define-key undo-tree-visualizer-selection-map [next]
+    (lambda () (interactive) (undo-tree-visualizer-select-next 10)))
+  (define-key undo-tree-visualizer-selection-map [prior]
+    (lambda () (interactive) (undo-tree-visualizer-select-previous 10)))
+  ;; horizontal motion keys move to left and right siblings
+  (define-key undo-tree-visualizer-selection-map [remap forward-char]
+    'undo-tree-visualizer-select-right)
+  (define-key undo-tree-visualizer-selection-map [remap backward-char]
+    'undo-tree-visualizer-select-left)
+  (define-key undo-tree-visualizer-selection-map [right]
+    'undo-tree-visualizer-select-right)
+  (define-key undo-tree-visualizer-selection-map "f"
+    'undo-tree-visualizer-select-right)
+  (define-key undo-tree-visualizer-selection-map "\C-f"
+    'undo-tree-visualizer-select-right)
+  (define-key undo-tree-visualizer-selection-map [left]
+    'undo-tree-visualizer-select-left)
+  (define-key undo-tree-visualizer-selection-map "b"
+    'undo-tree-visualizer-select-left)
+  (define-key undo-tree-visualizer-selection-map "\C-b"
+    'undo-tree-visualizer-select-left)
+  ;; horizontal scroll keys move left or right quickly
+  (define-key undo-tree-visualizer-selection-map ","
+    (lambda () (interactive) (undo-tree-visualizer-select-left 10)))
+  (define-key undo-tree-visualizer-selection-map "."
+    (lambda () (interactive) (undo-tree-visualizer-select-right 10)))
+  (define-key undo-tree-visualizer-selection-map "<"
+    (lambda () (interactive) (undo-tree-visualizer-select-left 10)))
+  (define-key undo-tree-visualizer-selection-map ">"
+    (lambda () (interactive) (undo-tree-visualizer-select-right 10)))
+  ;; mouse or <enter> sets buffer state to node at point/click
+  (define-key undo-tree-visualizer-selection-map "\r"
+    'undo-tree-visualizer-set)
+  (define-key undo-tree-visualizer-selection-map [mouse-1]
+    'undo-tree-visualizer-mouse-set)
+  ;; toggle timestamps
+  (define-key undo-tree-visualizer-selection-map "t"
+    'undo-tree-visualizer-toggle-timestamps)
+  ;; quit visualizer selection mode
+  (define-key undo-tree-visualizer-selection-map "s"
+    'undo-tree-visualizer-mode)
+  ;; quit visualizer
+  (define-key undo-tree-visualizer-selection-map "q"
+    'undo-tree-visualizer-quit)
+  (define-key undo-tree-visualizer-selection-map "\C-q"
+    'undo-tree-visualizer-quit))
+
+
+
+
+;;; =====================================================================
+;;;                     Undo-tree data structure
+
+(defstruct
+  (undo-tree
+   :named
+   (:constructor nil)
+   (:constructor make-undo-tree
+                 (&aux
+                  (root (make-undo-tree-node nil nil))
+                  (current root)
+                  (size 0)
+		  (object-pool (make-hash-table :test 'eq :weakness 'value))))
+   (:copier nil))
+  root current size object-pool)
+
+
+
+(defstruct
+  (undo-tree-node
+   (:type vector)   ; create unnamed struct
+   (:constructor nil)
+   (:constructor make-undo-tree-node
+                 (previous undo
+		  &optional redo
+                  &aux
+                  (timestamp (current-time))
+                  (branch 0)))
+   (:constructor make-undo-tree-node-backwards
+                 (next-node undo
+		  &optional redo
+                  &aux
+                  (next (list next-node))
+                  (timestamp (current-time))
+                  (branch 0)))
+   (:copier nil))
+  previous next undo redo timestamp branch meta-data)
+
+
+(defmacro undo-tree-node-p (n)
+  (let ((len (length (make-undo-tree-node nil nil))))
+    `(and (vectorp ,n) (= (length ,n) ,len))))
+
+
+
+(defstruct
+  (undo-tree-region-data
+   (:type vector)   ; create unnamed struct
+   (:constructor nil)
+   (:constructor make-undo-tree-region-data
+		 (&optional undo-beginning undo-end
+			     redo-beginning redo-end))
+   (:constructor make-undo-tree-undo-region-data
+		 (undo-beginning undo-end))
+   (:constructor make-undo-tree-redo-region-data
+		 (redo-beginning redo-end))
+   (:copier nil))
+  undo-beginning undo-end redo-beginning redo-end)
+
+
+(defmacro undo-tree-region-data-p (r)
+  (let ((len (length (make-undo-tree-region-data))))
+    `(and (vectorp ,r) (= (length ,r) ,len))))
+
+(defmacro undo-tree-node-clear-region-data (node)
+  `(setf (undo-tree-node-meta-data ,node)
+	 (delq nil
+	       (delq :region
+		     (plist-put (undo-tree-node-meta-data ,node)
+				:region nil)))))
+
+
+(defmacro undo-tree-node-undo-beginning (node)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (when (undo-tree-region-data-p r)
+       (undo-tree-region-data-undo-beginning r))))
+
+(defmacro undo-tree-node-undo-end (node)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (when (undo-tree-region-data-p r)
+       (undo-tree-region-data-undo-end r))))
+
+(defmacro undo-tree-node-redo-beginning (node)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (when (undo-tree-region-data-p r)
+       (undo-tree-region-data-redo-beginning r))))
+
+(defmacro undo-tree-node-redo-end (node)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (when (undo-tree-region-data-p r)
+       (undo-tree-region-data-redo-end r))))
+
+
+(defsetf undo-tree-node-undo-beginning (node) (val)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (unless (undo-tree-region-data-p r)
+       (setf (undo-tree-node-meta-data ,node)
+	     (plist-put (undo-tree-node-meta-data ,node) :region
+			(setq r (make-undo-tree-region-data)))))
+     (setf (undo-tree-region-data-undo-beginning r) ,val)))
+
+(defsetf undo-tree-node-undo-end (node) (val)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (unless (undo-tree-region-data-p r)
+       (setf (undo-tree-node-meta-data ,node)
+	     (plist-put (undo-tree-node-meta-data ,node) :region
+			(setq r (make-undo-tree-region-data)))))
+     (setf (undo-tree-region-data-undo-end r) ,val)))
+
+(defsetf undo-tree-node-redo-beginning (node) (val)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (unless (undo-tree-region-data-p r)
+       (setf (undo-tree-node-meta-data ,node)
+	     (plist-put (undo-tree-node-meta-data ,node) :region
+			(setq r (make-undo-tree-region-data)))))
+     (setf (undo-tree-region-data-redo-beginning r) ,val)))
+
+(defsetf undo-tree-node-redo-end (node) (val)
+  `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region)))
+     (unless (undo-tree-region-data-p r)
+       (setf (undo-tree-node-meta-data ,node)
+	     (plist-put (undo-tree-node-meta-data ,node) :region
+			(setq r (make-undo-tree-region-data)))))
+     (setf (undo-tree-region-data-redo-end r) ,val)))
+
+
+
+(defstruct
+  (undo-tree-visualizer-data
+   (:type vector)   ; create unnamed struct
+   (:constructor nil)
+   (:constructor make-undo-tree-visualizer-data
+		 (&optional lwidth cwidth rwidth marker))
+   (:copier nil))
+  lwidth cwidth rwidth marker)
+
+
+(defmacro undo-tree-visualizer-data-p (v)
+  (let ((len (length (make-undo-tree-visualizer-data))))
+    `(and (vectorp ,v) (= (length ,v) ,len))))
+
+(defmacro undo-tree-node-clear-visualizer-data (node)
+  `(setf (undo-tree-node-meta-data ,node)
+	 (delq nil
+	       (delq :visualizer
+		     (plist-put (undo-tree-node-meta-data ,node)
+				:visualizer nil)))))
+
+
+(defmacro undo-tree-node-lwidth (node)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (when (undo-tree-visualizer-data-p v)
+       (undo-tree-visualizer-data-lwidth v))))
+
+(defmacro undo-tree-node-cwidth (node)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (when (undo-tree-visualizer-data-p v)
+       (undo-tree-visualizer-data-cwidth v))))
+
+(defmacro undo-tree-node-rwidth (node)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (when (undo-tree-visualizer-data-p v)
+       (undo-tree-visualizer-data-rwidth v))))
+
+(defmacro undo-tree-node-marker (node)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (when (undo-tree-visualizer-data-p v)
+       (undo-tree-visualizer-data-marker v))))
+
+
+(defsetf undo-tree-node-lwidth (node) (val)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (unless (undo-tree-visualizer-data-p v)
+       (setf (undo-tree-node-meta-data ,node)
+	     (plist-put (undo-tree-node-meta-data ,node) :visualizer
+			(setq v (make-undo-tree-visualizer-data)))))
+     (setf (undo-tree-visualizer-data-lwidth v) ,val)))
+
+(defsetf undo-tree-node-cwidth (node) (val)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (unless (undo-tree-visualizer-data-p v)
+       (setf (undo-tree-node-meta-data ,node)
+	     (plist-put (undo-tree-node-meta-data ,node) :visualizer
+			(setq v (make-undo-tree-visualizer-data)))))
+     (setf (undo-tree-visualizer-data-cwidth v) ,val)))
+
+(defsetf undo-tree-node-rwidth (node) (val)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (unless (undo-tree-visualizer-data-p v)
+       (setf (undo-tree-node-meta-data ,node)
+	     (plist-put (undo-tree-node-meta-data ,node) :visualizer
+			(setq v (make-undo-tree-visualizer-data)))))
+     (setf (undo-tree-visualizer-data-rwidth v) ,val)))
+
+(defsetf undo-tree-node-marker (node) (val)
+  `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer)))
+     (unless (undo-tree-visualizer-data-p v)
+       (setf (undo-tree-node-meta-data ,node)
+	     (plist-put (undo-tree-node-meta-data ,node) :visualizer
+			(setq v (make-undo-tree-visualizer-data)))))
+     (setf (undo-tree-visualizer-data-marker v) ,val)))
+
+
+
+(defmacro undo-tree-node-register (node)
+  `(plist-get (undo-tree-node-meta-data ,node) :register))
+
+(defsetf undo-tree-node-register (node) (val)
+  `(setf (undo-tree-node-meta-data ,node)
+	 (plist-put (undo-tree-node-meta-data ,node) :register ,val)))
+
+
+
+
+;;; =====================================================================
+;;;              Basic undo-tree data structure functions
+
+(defun undo-tree-grow (undo)
+  "Add an UNDO node to current branch of `buffer-undo-tree'."
+  (let* ((current (undo-tree-current buffer-undo-tree))
+         (new (make-undo-tree-node current undo)))
+    (push new (undo-tree-node-next current))
+    (setf (undo-tree-current buffer-undo-tree) new)))
+
+
+(defun undo-tree-grow-backwards (node undo &optional redo)
+  "Add new node *above* undo-tree NODE, and return new node.
+Note that this will overwrite NODE's \"previous\" link, so should
+only be used on a detached NODE, never on nodes that are already
+part of `buffer-undo-tree'."
+  (let ((new (make-undo-tree-node-backwards node undo redo)))
+    (setf (undo-tree-node-previous node) new)
+    new))
+
+
+(defun undo-tree-splice-node (node splice)
+  "Splice NODE into undo tree, below node SPLICE.
+Note that this will overwrite NODE's \"next\" and \"previous\"
+links, so should only be used on a detached NODE, never on nodes
+that are already part of `buffer-undo-tree'."
+  (setf (undo-tree-node-next node) (undo-tree-node-next splice)
+	(undo-tree-node-branch node) (undo-tree-node-branch splice)
+	(undo-tree-node-previous node) splice
+	(undo-tree-node-next splice) (list node)
+	(undo-tree-node-branch splice) 0)
+  (dolist (n (undo-tree-node-next node))
+    (setf (undo-tree-node-previous n) node)))
+
+
+(defun undo-tree-snip-node (node)
+  "Snip NODE out of undo tree."
+  (let* ((parent (undo-tree-node-previous node))
+	 position p)
+    ;; if NODE is only child, replace parent's next links with NODE's
+    (if (= (length (undo-tree-node-next parent)) 0)
+	(setf (undo-tree-node-next parent) (undo-tree-node-next node)
+	      (undo-tree-node-branch parent) (undo-tree-node-branch node))
+      ;; otherwise...
+      (setq position (undo-tree-position node (undo-tree-node-next parent)))
+      (cond
+       ;; if active branch used do go via NODE, set parent's branch to active
+       ;; branch of NODE
+       ((= (undo-tree-node-branch parent) position)
+	(setf (undo-tree-node-branch parent)
+	      (+ position (undo-tree-node-branch node))))
+       ;; if active branch didn't go via NODE, update parent's branch to point
+       ;; to same node as before
+       ((> (undo-tree-node-branch parent) position)
+	(incf (undo-tree-node-branch parent)
+	      (1- (length (undo-tree-node-next node))))))
+      ;; replace NODE in parent's next list with NODE's entire next list
+      (if (= position 0)
+	  (setf (undo-tree-node-next parent)
+		(nconc (undo-tree-node-next node)
+		       (cdr (undo-tree-node-next parent))))
+	(setq p (nthcdr (1- position) (undo-tree-node-next parent)))
+	(setcdr p (nconc (undo-tree-node-next node) (cddr p)))))
+    ;; update previous links of NODE's children
+    (dolist (n (undo-tree-node-next node))
+      (setf (undo-tree-node-previous n) parent))))
+
+
+(defun undo-tree-mapc (--undo-tree-mapc-function-- undo-tree)
+  ;; Apply FUNCTION to each node in UNDO-TREE.
+  (let ((stack (list (undo-tree-root undo-tree)))
+        node)
+    (while stack
+      (setq node (pop stack))
+      (funcall --undo-tree-mapc-function-- node)
+      (setq stack (append (undo-tree-node-next node) stack)))))
+
+
+(defmacro undo-tree-num-branches ()
+  "Return number of branches at current undo tree node."
+  '(length (undo-tree-node-next (undo-tree-current buffer-undo-tree))))
+
+
+(defun undo-tree-position (node list)
+  "Find the first occurrence of NODE in LIST.
+Return the index of the matching item, or nil of not found.
+Comparison is done with 'eq."
+  (let ((i 0))
+    (catch 'found
+      (while (progn
+               (when (eq node (car list)) (throw 'found i))
+               (incf i)
+               (setq list (cdr list))))
+      nil)))
+
+
+(defvar *undo-tree-id-counter* 0)
+(make-variable-buffer-local '*undo-tree-id-counter*)
+
+(defmacro undo-tree-generate-id ()
+  ;; Generate a new, unique id (uninterned symbol).
+  ;; The name is made by appending a number to "undo-tree-id".
+  ;; (Copied from CL package `gensym'.)
+  `(let ((num (prog1 *undo-tree-id-counter* (incf *undo-tree-id-counter*))))
+     (make-symbol (format "undo-tree-id%d" num))))
+
+
+
+
+;;; =====================================================================
+;;;    Utility functions for handling `buffer-undo-list' and changesets
+
+(defmacro undo-list-marker-elt-p (elt)
+  `(markerp (car-safe ,elt)))
+
+(defmacro undo-list-GCd-marker-elt-p (elt)
+  `(and (symbolp (car-safe ,elt)) (numberp (cdr-safe ,elt))))
+
+
+(defun undo-tree-move-GC-elts-to-pool (elt)
+  ;; Move elements that can be garbage-collected into `buffer-undo-tree'
+  ;; object pool, substituting a unique id that can be used to retrieve them
+  ;; later. (Only markers require this treatment currently.)
+  (when (undo-list-marker-elt-p elt)
+    (let ((id (undo-tree-generate-id)))
+      (puthash id (car elt) (undo-tree-object-pool buffer-undo-tree))
+      (setcar elt id))))
+
+
+(defun undo-tree-restore-GC-elts-from-pool (elt)
+  ;; Replace object id's in ELT with corresponding objects from
+  ;; `buffer-undo-tree' object pool and return modified ELT, or return nil if
+  ;; any object in ELT has been garbage-collected.
+  (if (undo-list-GCd-marker-elt-p elt)
+      (when (setcar elt (gethash (car elt)
+				 (undo-tree-object-pool buffer-undo-tree)))
+	elt)
+    elt))
+
+
+(defun undo-list-clean-GCd-elts (undo-list)
+  ;; Remove object id's from UNDO-LIST that refer to elements that have been
+  ;; garbage-collected. UNDO-LIST is modified by side-effect.
+  (while (undo-list-GCd-marker-elt-p (car undo-list))
+    (unless (gethash (caar undo-list)
+		     (undo-tree-object-pool buffer-undo-tree))
+      (setq undo-list (cdr undo-list))))
+  (let ((p undo-list))
+    (while (cdr p)
+      (when (and (undo-list-GCd-marker-elt-p (cadr p))
+		 (null (gethash (car (cadr p))
+				(undo-tree-object-pool buffer-undo-tree))))
+	(setcdr p (cddr p)))
+      (setq p (cdr p))))
+  undo-list)
+
+
+(defun undo-list-pop-changeset ()
+  ;; Pop changeset from `buffer-undo-list'.
+  ;; discard undo boundaries at head of list
+  (while (null (car buffer-undo-list))
+    (setq buffer-undo-list (cdr buffer-undo-list)))
+  ;; pop elements up to next undo boundary
+  (unless (eq (car buffer-undo-list) 'undo-tree-canary)
+    (let* ((changeset (list (pop buffer-undo-list)))
+           (p changeset))
+      (while (progn
+	       (undo-tree-move-GC-elts-to-pool (car p))
+	       (car buffer-undo-list))
+        (setcdr p (list (pop buffer-undo-list)))
+	(setq p (cdr p)))
+      changeset)))
+
+
+(defun undo-tree-copy-list (undo-list)
+  ;; Return a deep copy of first changeset in `undo-list'. Object id's are
+  ;; replaced by corresponding objects from `buffer-undo-tree' object-pool.
+  (when undo-list
+    (let (copy p)
+      ;; if first element contains an object id, replace it with object from
+      ;; pool, discarding element entirely if it's been GC'd
+      (while (null copy)
+	(setq copy
+	      (undo-tree-restore-GC-elts-from-pool (pop undo-list))))
+      (setq copy (list copy)
+	    p copy)
+      ;; copy remaining elements, replacing object id's with objects from
+      ;; pool, or discarding them entirely if they've been GC'd
+      (while undo-list
+	(when (setcdr p (undo-tree-restore-GC-elts-from-pool
+			 (undo-copy-list-1 (pop undo-list))))
+	  (setcdr p (list (cdr p)))
+	  (setq p (cdr p))))
+      copy)))
+
+
+
+(defun undo-list-transfer-to-tree ()
+  ;; Transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'.
+
+  ;; if `buffer-undo-tree' is empty, create initial undo-tree
+  (when (null buffer-undo-tree) (setq buffer-undo-tree (make-undo-tree)))
+  ;; make sure there's a canary at end of `buffer-undo-list'
+  (if (null buffer-undo-list)
+      (setq buffer-undo-list '(nil undo-tree-canary))
+    (let ((elt (last buffer-undo-list)))
+      (unless (eq (car elt) 'undo-tree-canary)
+	(setcdr elt '(nil undo-tree-canary)))))
+
+  (unless (eq (cadr buffer-undo-list) 'undo-tree-canary)
+    ;; create new node from first changeset in `buffer-undo-list', save old
+    ;; `buffer-undo-tree' current node, and make new node the current node
+    (let* ((node (make-undo-tree-node nil (undo-list-pop-changeset)))
+	   (splice (undo-tree-current buffer-undo-tree))
+	   (size (undo-list-byte-size (undo-tree-node-undo node))))
+      (setf (undo-tree-current buffer-undo-tree) node)
+      ;; grow tree fragment backwards using `buffer-undo-list' changesets
+      (while (and buffer-undo-list
+		  (not (eq (cadr buffer-undo-list) 'undo-tree-canary)))
+	(setq node
+	      (undo-tree-grow-backwards node (undo-list-pop-changeset)))
+	(incf size (undo-list-byte-size (undo-tree-node-undo node))))
+      ;; if no undo history has been discarded from `buffer-undo-list' since
+      ;; last transfer, splice new tree fragment onto end of old
+      ;; `buffer-undo-tree' current node
+      (if (eq (cadr buffer-undo-list) 'undo-tree-canary)
+	  (progn
+	    (setf (undo-tree-node-previous node) splice)
+	    (push node (undo-tree-node-next splice))
+	    (setf (undo-tree-node-branch splice) 0)
+	    (incf (undo-tree-size buffer-undo-tree) size))
+	;; if undo history has been discarded, replace entire
+	;; `buffer-undo-tree' with new tree fragment
+	(setq node (undo-tree-grow-backwards node nil))
+	(setf (undo-tree-root buffer-undo-tree) node)
+	(setq buffer-undo-list '(nil undo-tree-canary))
+	(setf (undo-tree-size buffer-undo-tree) size)))
+    ;; discard undo history if necessary
+    (undo-tree-discard-history)))
+
+
+(defun undo-list-byte-size (undo-list)
+  ;; Return size (in bytes) of UNDO-LIST
+  (let ((size 0) (p undo-list))
+    (while p
+      (incf size 8)  ; cons cells use up 8 bytes
+      (when (and (consp (car p)) (stringp (caar p)))
+        (incf size (string-bytes (caar p))))
+      (setq p (cdr p)))
+    size))
+
+
+
+(defun undo-list-rebuild-from-tree ()
+  "Rebuild `buffer-undo-list' from information in `buffer-undo-tree'."
+  (unless (eq buffer-undo-list t)
+    (undo-list-transfer-to-tree)
+    (setq buffer-undo-list nil)
+    (when buffer-undo-tree
+      (let ((stack (list (list (undo-tree-root buffer-undo-tree)))))
+	(push (sort (mapcar 'identity (undo-tree-node-next (caar stack)))
+		    (lambda (a b)
+		      (time-less-p (undo-tree-node-timestamp a)
+				   (undo-tree-node-timestamp b))))
+	      stack)
+	;; Traverse tree in depth-and-oldest-first order, but add undo records
+	;; on the way down, and redo records on the way up.
+	(while (or (car stack)
+		   (not (eq (car (nth 1 stack))
+			    (undo-tree-current buffer-undo-tree))))
+	  (if (car stack)
+	      (progn
+		(setq buffer-undo-list
+		      (append (undo-tree-node-undo (caar stack))
+			      buffer-undo-list))
+		(undo-boundary)
+		(push (sort (mapcar 'identity
+				    (undo-tree-node-next (caar stack)))
+			    (lambda (a b)
+			      (time-less-p (undo-tree-node-timestamp a)
+					   (undo-tree-node-timestamp b))))
+		      stack))
+	    (pop stack)
+	    (setq buffer-undo-list
+		  (append (undo-tree-node-redo (caar stack))
+			  buffer-undo-list))
+	    (undo-boundary)
+	    (pop (car stack))))))))
+
+
+
+
+;;; =====================================================================
+;;;                  History discarding functions
+
+(defun undo-tree-oldest-leaf (node)
+  ;; Return oldest leaf node below NODE.
+  (while (undo-tree-node-next node)
+    (setq node
+          (car (sort (mapcar 'identity (undo-tree-node-next node))
+                     (lambda (a b)
+                       (time-less-p (undo-tree-node-timestamp a)
+                                    (undo-tree-node-timestamp b)))))))
+  node)
+
+
+(defun undo-tree-discard-node (node)
+  ;; Discard NODE from `buffer-undo-tree', and return next in line for
+  ;; discarding.
+
+  ;; don't discard current node
+  (unless (eq node (undo-tree-current buffer-undo-tree))
+
+    ;; discarding root node...
+    (if (eq node (undo-tree-root buffer-undo-tree))
+        (cond
+         ;; should always discard branches before root
+         ((> (length (undo-tree-node-next node)) 1)
+          (error "Trying to discard undo-tree root which still\
+ has multiple branches"))
+         ;; don't discard root if current node is only child
+         ((eq (car (undo-tree-node-next node))
+              (undo-tree-current buffer-undo-tree))
+	  nil)
+	 ;; discard root
+         (t
+          ;; make child of root into new root
+          (setq node (setf (undo-tree-root buffer-undo-tree)
+                           (car (undo-tree-node-next node))))
+	  ;; update undo-tree size
+	  (decf (undo-tree-size buffer-undo-tree)
+		(+ (undo-list-byte-size (undo-tree-node-undo node))
+		   (undo-list-byte-size (undo-tree-node-redo node))))
+	  ;; discard new root's undo data
+	  (setf (undo-tree-node-undo node) nil
+		(undo-tree-node-redo node) nil)
+          ;; if new root has branches, or new root is current node, next node
+          ;; to discard is oldest leaf, otherwise it's new root
+          (if (or (> (length (undo-tree-node-next node)) 1)
+                  (eq (car (undo-tree-node-next node))
+                      (undo-tree-current buffer-undo-tree)))
+              (undo-tree-oldest-leaf node)
+            node)))
+
+      ;; discarding leaf node...
+      (let* ((parent (undo-tree-node-previous node))
+             (current (nth (undo-tree-node-branch parent)
+                           (undo-tree-node-next parent))))
+	;; update undo-tree size
+	(decf (undo-tree-size buffer-undo-tree)
+	      (+ (undo-list-byte-size (undo-tree-node-undo node))
+		 (undo-list-byte-size (undo-tree-node-redo node))))
+        (setf (undo-tree-node-next parent)
+                (delq node (undo-tree-node-next parent))
+              (undo-tree-node-branch parent)
+                (undo-tree-position current (undo-tree-node-next parent)))
+        ;; if parent has branches, or parent is current node, next node to
+        ;; discard is oldest leaf, otherwise it's parent
+        (if (or (eq parent (undo-tree-current buffer-undo-tree))
+                (and (undo-tree-node-next parent)
+                     (or (not (eq parent (undo-tree-root buffer-undo-tree)))
+                         (> (length (undo-tree-node-next parent)) 1))))
+            (undo-tree-oldest-leaf parent)
+          parent)))))
+
+
+
+(defun undo-tree-discard-history ()
+  "Discard undo history until we're within memory usage limits
+set by `undo-limit', `undo-strong-limit' and `undo-outer-limit'."
+
+  (when (> (undo-tree-size buffer-undo-tree) undo-limit)
+    ;; if there are no branches off root, first node to discard is root;
+    ;; otherwise it's leaf node at botom of oldest branch
+    (let ((node (if (> (length (undo-tree-node-next
+                                (undo-tree-root buffer-undo-tree))) 1)
+                    (undo-tree-oldest-leaf (undo-tree-root buffer-undo-tree))
+                  (undo-tree-root buffer-undo-tree))))
+
+      ;; discard nodes until memory use is within `undo-strong-limit'
+      (while (and node
+                  (> (undo-tree-size buffer-undo-tree) undo-strong-limit))
+        (setq node (undo-tree-discard-node node)))
+
+      ;; discard nodes until next node to discard would bring memory use
+      ;; within `undo-limit'
+      (while (and node
+		  ;; check first if last discard has brought us within
+		  ;; `undo-limit', in case we can avoid more expensive
+		  ;; `undo-strong-limit' calculation
+		  ;; Note: this assumes undo-strong-limit > undo-limit;
+		  ;;       if not, effectively undo-strong-limit = undo-limit
+		  (> (undo-tree-size buffer-undo-tree) undo-limit)
+                  (> (- (undo-tree-size buffer-undo-tree)
+			;; if next node to discard is root, the memory we
+			;; free-up comes from discarding changesets from its
+			;; only child...
+			(if (eq node (undo-tree-root buffer-undo-tree))
+			    (+ (undo-list-byte-size
+				(undo-tree-node-undo
+				 (car (undo-tree-node-next node))))
+			       (undo-list-byte-size
+				(undo-tree-node-redo
+				 (car (undo-tree-node-next node)))))
+			  ;; ...otherwise, it comes from discarding changesets
+			  ;; from along with the node itself
+			  (+ (undo-list-byte-size (undo-tree-node-undo node))
+			     (undo-list-byte-size (undo-tree-node-redo node)))
+			  ))
+                     undo-limit))
+        (setq node (undo-tree-discard-node node)))
+
+      ;; if we're still over the `undo-outer-limit', discard entire history
+      (when (> (undo-tree-size buffer-undo-tree) undo-outer-limit)
+        ;; query first if `undo-ask-before-discard' is set
+        (if undo-ask-before-discard
+            (when (yes-or-no-p
+                   (format
+                    "Buffer `%s' undo info is %d bytes long;  discard it? "
+                    (buffer-name) (undo-tree-size buffer-undo-tree)))
+              (setq buffer-undo-tree nil))
+          ;; otherwise, discard and display warning
+          (display-warning
+           '(undo discard-info)
+           (concat
+            (format "Buffer `%s' undo info was %d bytes long.\n"
+                    (buffer-name) (undo-tree-size buffer-undo-tree))
+            "The undo info was discarded because it exceeded\
+ `undo-outer-limit'.
+
+This is normal if you executed a command that made a huge change
+to the buffer. In that case, to prevent similar problems in the
+future, set `undo-outer-limit' to a value that is large enough to
+cover the maximum size of normal changes you expect a single
+command to make, but not so large that it might exceed the
+maximum memory allotted to Emacs.
+
+If you did not execute any such command, the situation is
+probably due to a bug and you should report it.
+
+You can disable the popping up of this buffer by adding the entry
+\(undo discard-info) to the user option `warning-suppress-types',
+which is defined in the `warnings' library.\n")
+           :warning)
+          (setq buffer-undo-tree nil)))
+      )))
+
+
+
+
+;;; =====================================================================
+;;;                 Visualizer-related functions
+
+(defun undo-tree-compute-widths (undo-tree)
+  "Recursively compute widths for all UNDO-TREE's nodes."
+  (let ((stack (list (undo-tree-root undo-tree)))
+        res)
+    (while stack
+      ;; try to compute widths for node at top of stack
+      (if (undo-tree-node-p
+           (setq res (undo-tree-node-compute-widths (car stack))))
+          ;; if computation fails, it returns a node whose widths still need
+          ;; computing, which we push onto the stack
+          (push res stack)
+        ;; otherwise, store widths and remove it from stack
+        (setf (undo-tree-node-lwidth (car stack)) (aref res 0)
+              (undo-tree-node-cwidth (car stack)) (aref res 1)
+              (undo-tree-node-rwidth (car stack)) (aref res 2))
+        (pop stack)))))
+
+
+(defun undo-tree-node-compute-widths (node)
+  ;; Compute NODE's left-, centre-, and right-subtree widths. Returns widths
+  ;; (in a vector) if successful. Otherwise, returns a node whose widths need
+  ;; calculating before NODE's can be calculated.
+  (let ((num-children (length (undo-tree-node-next node)))
+        (lwidth 0) (cwidth 0) (rwidth 0)
+        p w)
+    (catch 'need-widths
+      (cond
+       ;; leaf nodes have 0 width
+       ((= 0 num-children)
+        (setf cwidth 1
+              (undo-tree-node-lwidth node) 0
+              (undo-tree-node-cwidth node) 1
+              (undo-tree-node-rwidth node) 0))
+
+       ;; odd number of children
+       ((= (mod num-children 2) 1)
+        (setq p (undo-tree-node-next node))
+        ;; compute left-width
+        (dotimes (i (/ num-children 2))
+          (if (undo-tree-node-lwidth (car p))
+              (incf lwidth (+ (undo-tree-node-lwidth (car p))
+                              (undo-tree-node-cwidth (car p))
+                              (undo-tree-node-rwidth (car p))))
+            ;; if child's widths haven't been computed, return that child
+            (throw 'need-widths (car p)))
+          (setq p (cdr p)))
+        (if (undo-tree-node-lwidth (car p))
+            (incf lwidth (undo-tree-node-lwidth (car p)))
+          (throw 'need-widths (car p)))
+        ;; centre-width is inherited from middle child
+        (setf cwidth (undo-tree-node-cwidth (car p)))
+        ;; compute right-width
+        (incf rwidth (undo-tree-node-rwidth (car p)))
+        (setq p (cdr p))
+        (dotimes (i (/ num-children 2))
+          (if (undo-tree-node-lwidth (car p))
+              (incf rwidth (+ (undo-tree-node-lwidth (car p))
+                              (undo-tree-node-cwidth (car p))
+                              (undo-tree-node-rwidth (car p))))
+            (throw 'need-widths (car p)))
+          (setq p (cdr p))))
+
+       ;; even number of children
+       (t
+        (setq p (undo-tree-node-next node))
+        ;; compute left-width
+        (dotimes (i (/ num-children 2))
+          (if (undo-tree-node-lwidth (car p))
+              (incf lwidth (+ (undo-tree-node-lwidth (car p))
+                              (undo-tree-node-cwidth (car p))
+                              (undo-tree-node-rwidth (car p))))
+            (throw 'need-widths (car p)))
+          (setq p (cdr p)))
+        ;; centre-width is 0 when number of children is even
+        (setq cwidth 0)
+        ;; compute right-width
+        (dotimes (i (/ num-children 2))
+          (if (undo-tree-node-lwidth (car p))
+              (incf rwidth (+ (undo-tree-node-lwidth (car p))
+                              (undo-tree-node-cwidth (car p))
+                              (undo-tree-node-rwidth (car p))))
+            (throw 'need-widths (car p)))
+          (setq p (cdr p)))))
+
+      ;; return left-, centre- and right-widths
+      (vector lwidth cwidth rwidth))))
+
+
+(defun undo-tree-clear-visualizer-data (undo-tree)
+  ;; Clear visualizer data from UNDO-TREE.
+  (undo-tree-mapc
+   (lambda (node) (undo-tree-node-clear-visualizer-data node))
+   undo-tree))
+
+
+
+
+;;; =====================================================================
+;;;                     Undo-in-region functions
+
+(defun undo-tree-pull-undo-in-region-branch (start end)
+  ;; Pull out entries from undo changesets to create a new undo-in-region
+  ;; branch, which undoes changeset entries lying between START and END first,
+  ;; followed by remaining entries from the changesets, before rejoining the
+  ;; existing undo tree history. Repeated calls will, if appropriate, extend
+  ;; the current undo-in-region branch rather than creating a new one.
+
+  ;; if we're just reverting the last redo-in-region, we don't need to
+  ;; manipulate the undo tree at all
+  (if (undo-tree-reverting-redo-in-region-p start end)
+      t  ; return t to indicate success
+
+    ;; We build the `region-changeset' and `delta-list' lists forwards, using
+    ;; pointers `r' and `d' to the penultimate element of the list. So that we
+    ;; don't have to treat the first element differently, we prepend a dummy
+    ;; leading nil to the lists, and have the pointers point to that
+    ;; initially.
+    ;; Note: using '(nil) instead of (list nil) in the `let*' results in
+    ;;       bizarre errors when the code is byte-compiled, where parts of the
+    ;;       lists appear to survive across different calls to this function.
+    ;;       An obscure byte-compiler bug, perhaps?
+    (let* ((region-changeset (list nil))
+	   (r region-changeset)
+	   (delta-list (list nil))
+	   (d delta-list)
+	   (node (undo-tree-current buffer-undo-tree))
+	   (repeated-undo-in-region
+	    (undo-tree-repeated-undo-in-region-p start end))
+	   undo-adjusted-markers  ; `undo-elt-in-region' expects this
+	   fragment splice original-fragment original-splice original-current
+	   got-visible-elt undo-list elt)
+
+      ;; --- initialisation ---
+      (cond
+       ;; if this is a repeated undo in the same region, start pulling changes
+       ;; from NODE at which undo-in-region branch iss attached, and detatch
+       ;; the branch, using it as initial FRAGMENT of branch being constructed
+       (repeated-undo-in-region
+	(setq original-current node
+	      fragment (car (undo-tree-node-next node))
+	      splice node)
+	;; undo up to node at which undo-in-region branch is attached
+	;; (recognizable as first node with more than one branch)
+	(let ((mark-active nil))
+	  (while (= (length (undo-tree-node-next node)) 1)
+	    (undo-tree-undo)
+	    (setq fragment node
+		  node (undo-tree-current buffer-undo-tree))))
+	(when (eq splice node) (setq splice nil))
+	;; detatch undo-in-region branch
+	(setf (undo-tree-node-next node)
+	      (delq fragment (undo-tree-node-next node))
+	      (undo-tree-node-previous fragment) nil
+	      original-fragment fragment
+	      original-splice node))
+
+       ;; if this is a new undo-in-region, initial FRAGMENT is a copy of all
+       ;; nodes below the current one in the active branch
+       ((undo-tree-node-next node)
+	(setq fragment (make-undo-tree-node nil nil)
+	      splice fragment)
+	(while (setq node (nth (undo-tree-node-branch node)
+			       (undo-tree-node-next node)))
+	  (push (make-undo-tree-node
+		 splice
+		 (undo-copy-list (undo-tree-node-undo node))
+		 (undo-copy-list (undo-tree-node-redo node)))
+		(undo-tree-node-next splice))
+	  (setq splice (car (undo-tree-node-next splice))))
+	(setq fragment (car (undo-tree-node-next fragment))
+	      splice nil
+	      node (undo-tree-current buffer-undo-tree))))
+
+
+      ;; --- pull undo-in-region elements into branch ---
+      ;; work backwards up tree, pulling out undo elements within region until
+      ;; we've got one that undoes a visible change (insertion or deletion)
+      (catch 'abort
+	(while (and (not got-visible-elt) node (undo-tree-node-undo node))
+	  ;; we cons a dummy nil element on the front of the changeset so that
+	  ;; we can conveniently remove the first (real) element from the
+	  ;; changeset if we need to; the leading nil is removed once we're
+	  ;; done with this changeset
+	  (setq undo-list (cons nil (undo-copy-list (undo-tree-node-undo node)))
+		elt (cadr undo-list))
+	  (if fragment
+	      (progn
+		(setq fragment (undo-tree-grow-backwards fragment undo-list))
+		(unless splice (setq splice fragment)))
+	    (setq fragment (make-undo-tree-node nil undo-list))
+	    (setq splice fragment))
+
+	  (while elt
+	    (cond
+	     ;; keep elements within region
+	     ((undo-elt-in-region elt start end)
+	      ;; set flag if kept element is visible (insertion or deletion)
+	      (when (and (consp elt)
+			 (or (stringp (car elt)) (integerp (car elt))))
+		(setq got-visible-elt t))
+	      ;; adjust buffer positions in elements previously undone before
+	      ;; kept element, as kept element will now be undone first
+	      (undo-tree-adjust-elements-to-elt splice elt)
+	      ;; move kept element to undo-in-region changeset, adjusting its
+	      ;; buffer position as it will now be undone first
+	      (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list))))
+	      (setq r (cdr r))
+	      (setcdr undo-list (cddr undo-list)))
+
+	     ;; discard "was unmodified" elements
+	     ;; FIXME: deal properly with these
+	     ((and (consp elt) (eq (car elt) t))
+	      (setcdr undo-list (cddr undo-list)))
+
+	     ;; if element crosses region, we can't pull any more elements
+	     ((undo-elt-crosses-region elt start end)
+	      ;; if we've found a visible element, it must be earlier in
+	      ;; current node's changeset; stop pulling elements (null
+	      ;; `undo-list' and non-nil `got-visible-elt' cause loop to exit)
+	      (if got-visible-elt
+		  (setq undo-list nil)
+		;; if we haven't found a visible element yet, pulling
+		;; undo-in-region branch has failed
+		(setq region-changeset nil)
+		(throw 'abort t)))
+
+	     ;; if rejecting element, add its delta (if any) to the list
+	     (t
+	      (let ((delta (undo-delta elt)))
+		(when (/= 0 (cdr delta))
+		  (setcdr d (list delta))
+		  (setq d (cdr d))))
+	      (setq undo-list (cdr undo-list))))
+
+	    ;; process next element of current changeset
+	    (setq elt (cadr undo-list)))
+
+	  ;; if there are remaining elements in changeset, remove dummy nil
+	  ;; from front
+	  (if (cadr (undo-tree-node-undo fragment))
+	      (pop (undo-tree-node-undo fragment))
+	    ;; otherwise, if we've kept all elements in changeset, discard
+	    ;; empty changeset
+	    (when (eq splice fragment) (setq splice nil))
+	    (setq fragment (car (undo-tree-node-next fragment))))
+	  ;; process changeset from next node up the tree
+	  (setq node (undo-tree-node-previous node))))
+
+      ;; pop dummy nil from front of `region-changeset'
+      (pop region-changeset)
+
+
+      ;; --- integrate branch into tree ---
+      ;; if no undo-in-region elements were found, restore undo tree
+      (if (null region-changeset)
+	  (when original-current
+	    (push original-fragment (undo-tree-node-next original-splice))
+	    (setf (undo-tree-node-branch original-splice) 0
+		  (undo-tree-node-previous original-fragment) original-splice)
+	    (let ((mark-active nil))
+	      (while (not (eq (undo-tree-current buffer-undo-tree)
+			      original-current))
+		(undo-tree-redo)))
+	    nil)  ; return nil to indicate failure
+
+	;; otherwise...
+	;; need to undo up to node where new branch will be attached, to
+	;; ensure redo entries are populated, and then redo back to where we
+	;; started
+	(let ((mark-active nil)
+	      (current (undo-tree-current buffer-undo-tree)))
+	  (while (not (eq (undo-tree-current buffer-undo-tree) node))
+	    (undo-tree-undo))
+	  (while (not (eq (undo-tree-current buffer-undo-tree) current))
+	    (undo-tree-redo)))
+
+	(cond
+	 ;; if there's no remaining fragment, just create undo-in-region node
+	 ;; and attach it to parent of last node from which elements were
+	 ;; pulled
+	 ((null fragment)
+	  (setq fragment (make-undo-tree-node node region-changeset))
+	  (push fragment (undo-tree-node-next node))
+	  (setf (undo-tree-node-branch node) 0)
+	  ;; set current node to undo-in-region node
+	  (setf (undo-tree-current buffer-undo-tree) fragment))
+
+	 ;; if no splice point has been set, add undo-in-region node to top of
+	 ;; fragment and attach it to parent of last node from which elements
+	 ;; were pulled
+	 ((null splice)
+	  (setq fragment (undo-tree-grow-backwards fragment region-changeset))
+	  (push fragment (undo-tree-node-next node))
+	  (setf (undo-tree-node-branch node) 0
+		(undo-tree-node-previous fragment) node)
+	  ;; set current node to undo-in-region node
+	  (setf (undo-tree-current buffer-undo-tree) fragment))
+
+	 ;; if fragment contains nodes, attach fragment to parent of last node
+	 ;; from which elements were pulled, and splice in undo-in-region node
+	 (t
+	  (setf (undo-tree-node-previous fragment) node)
+	  (push fragment (undo-tree-node-next node))
+	  (setf (undo-tree-node-branch node) 0)
+	  ;; if this is a repeated undo-in-region, then we've left the current
+	  ;; node at the original splice-point; we need to set the current
+	  ;; node to the equivalent node on the undo-in-region branch and redo
+	  ;; back to where we started
+	  (when repeated-undo-in-region
+	    (setf (undo-tree-current buffer-undo-tree)
+		  (undo-tree-node-previous original-fragment))
+	    (let ((mark-active nil))
+	      (while (not (eq (undo-tree-current buffer-undo-tree) splice))
+		(undo-tree-redo nil 'preserve-undo))))
+	  ;; splice new undo-in-region node into fragment
+	  (setq node (make-undo-tree-node nil region-changeset))
+	  (undo-tree-splice-node node splice)
+	  ;; set current node to undo-in-region node
+	  (setf (undo-tree-current buffer-undo-tree) node)))
+
+	;; update undo-tree size
+	(setq node (undo-tree-node-previous fragment))
+	(while (progn
+		 (and (setq node (car (undo-tree-node-next node)))
+		      (not (eq node original-fragment))
+		      (incf (undo-tree-size buffer-undo-tree)
+			    (undo-list-byte-size (undo-tree-node-undo node)))
+		      (when (undo-tree-node-redo node)
+			(incf (undo-tree-size buffer-undo-tree)
+			      (undo-list-byte-size (undo-tree-node-redo node))))
+		      )))
+	t)  ; indicate undo-in-region branch was successfully pulled
+      )))
+
+
+
+(defun undo-tree-pull-redo-in-region-branch (start end)
+  ;; Pull out entries from redo changesets to create a new redo-in-region
+  ;; branch, which redoes changeset entries lying between START and END first,
+  ;; followed by remaining entries from the changesets. Repeated calls will,
+  ;; if appropriate, extend the current redo-in-region branch rather than
+  ;; creating a new one.
+
+  ;; if we're just reverting the last undo-in-region, we don't need to
+  ;; manipulate the undo tree at all
+  (if (undo-tree-reverting-undo-in-region-p start end)
+      t  ; return t to indicate success
+
+    ;; We build the `region-changeset' and `delta-list' lists forwards, using
+    ;; pointers `r' and `d' to the penultimate element of the list. So that we
+    ;; don't have to treat the first element differently, we prepend a dummy
+    ;; leading nil to the lists, and have the pointers point to that
+    ;; initially.
+    ;; Note: using '(nil) instead of (list nil) in the `let*' causes bizarre
+    ;;       errors when the code is byte-compiled, where parts of the lists
+    ;;       appear to survive across different calls to this function.  An
+    ;;       obscure byte-compiler bug, perhaps?
+    (let* ((region-changeset (list nil))
+	   (r region-changeset)
+	   (delta-list (list nil))
+	   (d delta-list)
+	   (node (undo-tree-current buffer-undo-tree))
+	   (repeated-redo-in-region
+	    (undo-tree-repeated-redo-in-region-p start end))
+	   undo-adjusted-markers  ; `undo-elt-in-region' expects this
+	   fragment splice got-visible-elt redo-list elt)
+
+      ;; --- inisitalisation ---
+      (cond
+       ;; if this is a repeated redo-in-region, detach fragment below current
+       ;; node
+       (repeated-redo-in-region
+	(when (setq fragment (car (undo-tree-node-next node)))
+	  (setf (undo-tree-node-previous fragment) nil
+		(undo-tree-node-next node)
+		(delq fragment (undo-tree-node-next node)))))
+       ;; if this is a new redo-in-region, initial fragment is a copy of all
+       ;; nodes below the current one in the active branch
+       ((undo-tree-node-next node)
+	(setq fragment (make-undo-tree-node nil nil)
+	      splice fragment)
+	(while (setq node (nth (undo-tree-node-branch node)
+			       (undo-tree-node-next node)))
+	  (push (make-undo-tree-node
+		 splice nil
+		 (undo-copy-list (undo-tree-node-redo node)))
+		(undo-tree-node-next splice))
+	  (setq splice (car (undo-tree-node-next splice))))
+	(setq fragment (car (undo-tree-node-next fragment)))))
+
+
+      ;; --- pull redo-in-region elements into branch ---
+      ;; work down fragment, pulling out redo elements within region until
+      ;; we've got one that redoes a visible change (insertion or deletion)
+      (setq node fragment)
+      (catch 'abort
+	(while (and (not got-visible-elt) node (undo-tree-node-redo node))
+	  ;; we cons a dummy nil element on the front of the changeset so that
+	  ;; we can conveniently remove the first (real) element from the
+	  ;; changeset if we need to; the leading nil is removed once we're
+	  ;; done with this changeset
+	  (setq redo-list (push nil (undo-tree-node-redo node))
+		elt (cadr redo-list))
+	  (while elt
+	    (cond
+	     ;; keep elements within region
+	     ((undo-elt-in-region elt start end)
+	      ;; set flag if kept element is visible (insertion or deletion)
+	      (when (and (consp elt)
+			 (or (stringp (car elt)) (integerp (car elt))))
+		(setq got-visible-elt t))
+	      ;; adjust buffer positions in elements previously redone before
+	      ;; kept element, as kept element will now be redone first
+	      (undo-tree-adjust-elements-to-elt fragment elt t)
+	      ;; move kept element to redo-in-region changeset, adjusting its
+	      ;; buffer position as it will now be redone first
+	      (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list) -1)))
+	      (setq r (cdr r))
+	      (setcdr redo-list (cddr redo-list)))
+
+	     ;; discard "was unmodified" elements
+	     ;; FIXME: deal properly with these
+	     ((and (consp elt) (eq (car elt) t))
+	      (setcdr redo-list (cddr redo-list)))
+
+	     ;; if element crosses region, we can't pull any more elements
+	     ((undo-elt-crosses-region elt start end)
+	      ;; if we've found a visible element, it must be earlier in
+	      ;; current node's changeset; stop pulling elements (null
+	      ;; `redo-list' and non-nil `got-visible-elt' cause loop to exit)
+	      (if got-visible-elt
+		  (setq redo-list nil)
+		;; if we haven't found a visible element yet, pulling
+		;; redo-in-region branch has failed
+		(setq region-changeset nil)
+		(throw 'abort t)))
+
+	     ;; if rejecting element, add its delta (if any) to the list
+	     (t
+	      (let ((delta (undo-delta elt)))
+		(when (/= 0 (cdr delta))
+		  (setcdr d (list delta))
+		  (setq d (cdr d))))
+	      (setq redo-list (cdr redo-list))))
+
+	    ;; process next element of current changeset
+	    (setq elt (cadr redo-list)))
+
+	  ;; if there are remaining elements in changeset, remove dummy nil
+	  ;; from front
+	  (if (cadr (undo-tree-node-redo node))
+	      (pop (undo-tree-node-undo node))
+	    ;; otherwise, if we've kept all elements in changeset, discard
+	    ;; empty changeset
+	    (if (eq fragment node)
+		(setq fragment (car (undo-tree-node-next fragment)))
+	      (undo-tree-snip-node node)))
+	  ;; process changeset from next node in fragment
+	  (setq node (car (undo-tree-node-next node)))))
+
+      ;; pop dummy nil from front of `region-changeset'
+      (pop region-changeset)
+
+
+      ;; --- integrate branch into tree ---
+      (setq node (undo-tree-current buffer-undo-tree))
+      ;; if no redo-in-region elements were found, restore undo tree
+      (if (null (car region-changeset))
+	  (when (and repeated-redo-in-region fragment)
+	    (push fragment (undo-tree-node-next node))
+	    (setf (undo-tree-node-branch node) 0
+		  (undo-tree-node-previous fragment) node)
+	    nil)  ; return nil to indicate failure
+
+	;; otherwise, add redo-in-region node to top of fragment, and attach
+	;; it below current node
+	(setq fragment
+	      (if fragment
+		  (undo-tree-grow-backwards fragment nil region-changeset)
+		(make-undo-tree-node nil nil region-changeset)))
+	(push fragment (undo-tree-node-next node))
+	(setf (undo-tree-node-branch node) 0
+	      (undo-tree-node-previous fragment) node)
+	;; update undo-tree size
+	(unless repeated-redo-in-region
+	  (setq node fragment)
+	  (while (progn
+		   (and (setq node (car (undo-tree-node-next node)))
+			(incf (undo-tree-size buffer-undo-tree)
+			      (undo-list-byte-size
+			       (undo-tree-node-redo node)))))))
+	(incf (undo-tree-size buffer-undo-tree)
+	      (undo-list-byte-size (undo-tree-node-redo fragment)))
+	t)  ; indicate undo-in-region branch was successfully pulled
+      )))
+
+
+
+(defun undo-tree-adjust-elements-to-elt (node undo-elt &optional below)
+  "Adjust buffer positions of undo elements, starting at NODE's
+and going up the tree (or down the active branch if BELOW is
+non-nil) and through the nodes' undo elements until we reach
+UNDO-ELT.  UNDO-ELT must appear somewhere in the undo changeset
+of either NODE itself or some node above it in the tree."
+  (let ((delta (list (undo-delta undo-elt)))
+	(undo-list (undo-tree-node-undo node)))
+    ;; adjust elements until we reach UNDO-ELT
+    (while (and (car undo-list)
+		(not (eq (car undo-list) undo-elt)))
+      (setcar undo-list
+	      (undo-tree-apply-deltas (car undo-list) delta -1))
+      ;; move to next undo element in list, or to next node if we've run out
+      ;; of elements
+      (unless (car (setq undo-list (cdr undo-list)))
+	(if below
+	    (setq node (nth (undo-tree-node-branch node)
+			    (undo-tree-node-next node)))
+	  (setq node (undo-tree-node-previous node)))
+	(setq undo-list (undo-tree-node-undo node))))))
+
+
+
+(defun undo-tree-apply-deltas (undo-elt deltas &optional sgn)
+  ;; Apply DELTAS in order to UNDO-ELT, multiplying deltas by SGN
+  ;; (only useful value for SGN is -1).
+  (let (position offset)
+    (dolist (delta deltas)
+      (setq position (car delta)
+	    offset (* (cdr delta) (or sgn 1)))
+      (cond
+       ;; POSITION
+       ((integerp undo-elt)
+	(when (>= undo-elt position)
+	  (setq undo-elt (- undo-elt offset))))
+       ;; nil (or any other atom)
+       ((atom undo-elt))
+       ;; (TEXT . POSITION)
+       ((stringp (car undo-elt))
+	(let ((text-pos (abs (cdr undo-elt)))
+	      (point-at-end (< (cdr undo-elt) 0)))
+	  (if (>= text-pos position)
+	      (setcdr undo-elt (* (if point-at-end -1 1)
+				  (- text-pos offset))))))
+       ;; (BEGIN . END)
+       ((integerp (car undo-elt))
+	(when (>= (car undo-elt) position)
+	  (setcar undo-elt (- (car undo-elt) offset))
+	  (setcdr undo-elt (- (cdr undo-elt) offset))))
+       ;; (nil PROPERTY VALUE BEG . END)
+       ((null (car undo-elt))
+	(let ((tail (nthcdr 3 undo-elt)))
+	  (when (>= (car tail) position)
+	    (setcar tail (- (car tail) offset))
+	    (setcdr tail (- (cdr tail) offset)))))
+       ))
+    undo-elt))
+
+
+
+(defun undo-tree-repeated-undo-in-region-p (start end)
+  ;; Return non-nil if undo-in-region between START and END is a repeated
+  ;; undo-in-region
+  (let ((node (undo-tree-current buffer-undo-tree)))
+    (and (setq node
+	       (nth (undo-tree-node-branch node) (undo-tree-node-next node)))
+	 (eq (undo-tree-node-undo-beginning node) start)
+	 (eq (undo-tree-node-undo-end node) end))))
+
+
+(defun undo-tree-repeated-redo-in-region-p (start end)
+  ;; Return non-nil if undo-in-region between START and END is a repeated
+  ;; undo-in-region
+  (let ((node (undo-tree-current buffer-undo-tree)))
+    (and (eq (undo-tree-node-redo-beginning node) start)
+	 (eq (undo-tree-node-redo-end node) end))))
+
+
+;; Return non-nil if undo-in-region between START and END is simply
+;; reverting the last redo-in-region
+(defalias 'undo-tree-reverting-undo-in-region-p
+  'undo-tree-repeated-undo-in-region-p)
+
+
+;; Return non-nil if redo-in-region between START and END is simply
+;; reverting the last undo-in-region
+(defalias 'undo-tree-reverting-redo-in-region-p
+  'undo-tree-repeated-redo-in-region-p)
+
+
+
+
+;;; =====================================================================
+;;;                        Undo-tree commands
+
+(define-minor-mode undo-tree-mode
+  "Toggle undo-tree mode.
+With no argument, this command toggles the mode.
+A positive prefix argument turns the mode on.
+A negative prefix argument turns it off.
+
+Undo-tree-mode replaces Emacs' standard undo feature with a more
+powerful yet easier to use version, that treats the undo history
+as what it is: a tree.
+
+The following keys are available in `undo-tree-mode':
+
+  \\{undo-tree-map}
+
+Within the undo-tree visualizer, the following keys are available:
+
+  \\{undo-tree-visualizer-map}"
+
+  nil                       ; init value
+  undo-tree-mode-lighter    ; lighter
+  undo-tree-map             ; keymap
+  ;; if disabling `undo-tree-mode', rebuild `buffer-undo-list' from tree so
+  ;; Emacs undo can work
+  (unless undo-tree-mode
+    (undo-list-rebuild-from-tree)
+    (setq buffer-undo-tree nil)))
+
+
+(defun turn-on-undo-tree-mode ()
+  "Enable undo-tree-mode."
+  (undo-tree-mode 1))
+
+
+(define-globalized-minor-mode global-undo-tree-mode
+  undo-tree-mode turn-on-undo-tree-mode)
+
+
+
+(defun undo-tree-undo (&optional arg preserve-redo)
+  "Undo changes.
+Repeat this command to undo more changes.
+A numeric ARG serves as a repeat count.
+
+In Transient Mark mode when the mark is active, only undo changes
+within the current region. Similarly, when not in Transient Mark
+mode, just \\[universal-argument] as an argument limits undo to
+changes within the current region.
+
+A non-nil PRESERVE-REDO causes the existing redo record to be
+preserved, rather than replacing it with the new one generated by
+undoing."
+  (interactive "*P")
+  ;; throw error if undo is disabled in buffer
+  (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
+
+  (let ((undo-in-progress t)
+	(undo-in-region (or (region-active-p) (and arg (not (numberp arg)))))
+	pos current)
+    ;; transfer entries accumulated in `buffer-undo-list' to
+    ;; `buffer-undo-tree'
+    (undo-list-transfer-to-tree)
+
+    (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1))
+      ;; check if at top of undo tree
+      (unless (undo-tree-node-previous (undo-tree-current buffer-undo-tree))
+	(error "No further undo information"))
+
+      ;; if region is active, or a non-numeric prefix argument was supplied,
+      ;; try to pull out a new branch of changes affecting the region
+      (when (and undo-in-region
+		 (not (undo-tree-pull-undo-in-region-branch
+		       (region-beginning) (region-end))))
+	(error "No further undo information for region"))
+
+      ;; remove any GC'd elements from node's undo list
+      (setq current (undo-tree-current buffer-undo-tree))
+      (decf (undo-tree-size buffer-undo-tree)
+	    (undo-list-byte-size (undo-tree-node-undo current)))
+      (setf (undo-tree-node-undo current)
+	    (undo-list-clean-GCd-elts (undo-tree-node-undo current)))
+      (incf (undo-tree-size buffer-undo-tree)
+	    (undo-list-byte-size (undo-tree-node-undo current)))
+      ;; undo one record from undo tree
+      (when undo-in-region
+	(setq pos (set-marker (make-marker) (point)))
+	(set-marker-insertion-type pos t))
+      (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-undo current)))
+      (undo-boundary)
+
+      ;; if preserving old redo record, discard new redo entries that
+      ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd
+      ;; elements from node's redo list
+      (if preserve-redo
+	  (progn
+	    (undo-list-pop-changeset)
+	    (decf (undo-tree-size buffer-undo-tree)
+		  (undo-list-byte-size (undo-tree-node-redo current)))
+	    (setf (undo-tree-node-redo current)
+		  (undo-list-clean-GCd-elts (undo-tree-node-redo current)))
+	    (incf (undo-tree-size buffer-undo-tree)
+		  (undo-list-byte-size (undo-tree-node-redo current))))
+	;; otherwise, record redo entries that `primitive-undo' has added to
+	;; `buffer-undo-list' in current node's redo record, replacing
+	;; existing entry if one already exists
+	(when (undo-tree-node-redo current)
+	  (decf (undo-tree-size buffer-undo-tree)
+		(undo-list-byte-size (undo-tree-node-redo current))))
+	(setf (undo-tree-node-redo current) (undo-list-pop-changeset))
+	(incf (undo-tree-size buffer-undo-tree)
+	      (undo-list-byte-size (undo-tree-node-redo current))))
+
+      ;; rewind current node and update timestamp
+      (setf (undo-tree-current buffer-undo-tree)
+	    (undo-tree-node-previous (undo-tree-current buffer-undo-tree))
+	    (undo-tree-node-timestamp (undo-tree-current buffer-undo-tree))
+	    (current-time))
+
+      ;; if undoing-in-region, record current node, region and direction so we
+      ;; can tell if undo-in-region is repeated, and re-activate mark if in
+      ;; `transient-mark-mode'; if not, erase any leftover data
+      (if (not undo-in-region)
+	  (undo-tree-node-clear-region-data current)
+	(goto-char pos)
+	;; note: we deliberately want to store the region information in the
+	;; node *below* the now current one
+	(setf (undo-tree-node-undo-beginning current) (region-beginning)
+	      (undo-tree-node-undo-end current) (region-end))
+	(set-marker pos nil)))
+
+    ;; undo deactivates mark unless undoing-in-region
+    (setq deactivate-mark (not undo-in-region))
+    ;; inform user if at branch point
+    (when (> (undo-tree-num-branches) 1) (message "Undo branch point!"))))
+
+
+
+(defun undo-tree-redo (&optional arg preserve-undo)
+  "Redo changes. A numeric ARG serves as a repeat count.
+
+In Transient Mark mode when the mark is active, only redo changes
+within the current region. Similarly, when not in Transient Mark
+mode, just \\[universal-argument] as an argument limits redo to
+changes within the current region.
+
+A non-nil PRESERVE-UNDO causes the existing undo record to be
+preserved, rather than replacing it with the new one generated by
+redoing."
+  (interactive "p")
+  ;; throw error if undo is disabled in buffer
+  (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
+
+  (let ((undo-in-progress t)
+	(redo-in-region (or (region-active-p) (and arg (not (numberp arg)))))
+	pos current)
+    ;; transfer entries accumulated in `buffer-undo-list' to
+    ;; `buffer-undo-tree'
+    (undo-list-transfer-to-tree)
+
+    (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1))
+      ;; check if at bottom of undo tree
+      (when (null (undo-tree-node-next (undo-tree-current buffer-undo-tree)))
+	(error "No further redo information"))
+
+      ;; if region is active, or a non-numeric prefix argument was supplied,
+      ;; try to pull out a new branch of changes affecting the region
+      (when (and redo-in-region
+		 (not (undo-tree-pull-redo-in-region-branch
+		       (region-beginning) (region-end))))
+	(error "No further redo information for region"))
+
+      ;; advance current node
+      (setq current (undo-tree-current buffer-undo-tree)
+	    current (setf (undo-tree-current buffer-undo-tree)
+			  (nth (undo-tree-node-branch current)
+			       (undo-tree-node-next current))))
+      ;; remove any GC'd elements from node's redo list
+      (decf (undo-tree-size buffer-undo-tree)
+	    (undo-list-byte-size (undo-tree-node-redo current)))
+      (setf (undo-tree-node-redo current)
+	    (undo-list-clean-GCd-elts (undo-tree-node-redo current)))
+      (incf (undo-tree-size buffer-undo-tree)
+	    (undo-list-byte-size (undo-tree-node-redo current)))
+      ;; redo one record from undo tree
+      (when redo-in-region
+	(setq pos (set-marker (make-marker) (point)))
+	(set-marker-insertion-type pos t))
+      (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-redo current)))
+      (undo-boundary)
+
+      ;; if preserving old undo record, discard new undo entries that
+      ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd
+      ;; elements from node's redo list
+      (if preserve-undo
+	  (progn
+	    (undo-list-pop-changeset)
+	    (decf (undo-tree-size buffer-undo-tree)
+		  (undo-list-byte-size (undo-tree-node-undo current)))
+	    (setf (undo-tree-node-undo current)
+		  (undo-list-clean-GCd-elts (undo-tree-node-undo current)))
+	    (incf (undo-tree-size buffer-undo-tree)
+		  (undo-list-byte-size (undo-tree-node-undo current))))
+	;; otherwise, record undo entries that `primitive-undo' has added to
+	;; `buffer-undo-list' in current node's undo record, replacing
+	;; existing entry if one already exists
+	(when (undo-tree-node-undo current)
+	  (decf (undo-tree-size buffer-undo-tree)
+		(undo-list-byte-size (undo-tree-node-undo current))))
+	(setf (undo-tree-node-undo current) (undo-list-pop-changeset))
+	(incf (undo-tree-size buffer-undo-tree)
+	      (undo-list-byte-size (undo-tree-node-undo current))))
+
+      ;; update timestamp
+      (setf (undo-tree-node-timestamp current) (current-time))
+
+      ;; if redoing-in-region, record current node, region and direction so we
+      ;; can tell if redo-in-region is repeated, and re-activate mark if in
+      ;; `transient-mark-mode'
+      (if (not redo-in-region)
+	  (undo-tree-node-clear-region-data current)
+	(goto-char pos)
+	(setf (undo-tree-node-redo-beginning current) (region-beginning)
+	      (undo-tree-node-redo-end current) (region-end))
+	(set-marker pos nil)))
+
+    ;; redo deactivates the mark unless redoing-in-region
+    (setq deactivate-mark (not redo-in-region))
+    ;; inform user if at branch point
+    (when (> (undo-tree-num-branches) 1) (message "Undo branch point!"))))
+
+
+
+(defun undo-tree-switch-branch (branch)
+  "Switch to a different BRANCH of the undo tree.
+This will affect which branch to descend when *redoing* changes
+using `undo-tree-redo'."
+  (interactive (list (or (and prefix-arg (prefix-numeric-value prefix-arg))
+                         (and (not (eq buffer-undo-list t))
+			      (or (undo-list-transfer-to-tree) t)
+                              (> (undo-tree-num-branches) 1)
+                              (read-number
+                               (format "Branch (0-%d): "
+                                       (1- (undo-tree-num-branches))))))))
+  ;; throw error if undo is disabled in buffer
+  (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
+  ;; sanity check branch number
+  (when (<= (undo-tree-num-branches) 1) (error "Not at undo branch point"))
+  (when (or (< branch 0) (> branch (1- (undo-tree-num-branches))))
+    (error "Invalid branch number"))
+  ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
+  (undo-list-transfer-to-tree)
+  ;; switch branch
+  (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree))
+	branch))
+
+
+(defun undo-tree-set (node)
+  ;; Set buffer to state corresponding to NODE. Returns intersection point
+  ;; between path back from current node and path back from selected NODE.
+  (let ((path (make-hash-table :test 'eq))
+        (n node))
+    (puthash (undo-tree-root buffer-undo-tree) t path)
+    ;; build list of nodes leading back from selected node to root, updating
+    ;; branches as we go to point down to selected node
+    (while (progn
+             (puthash n t path)
+             (when (undo-tree-node-previous n)
+               (setf (undo-tree-node-branch (undo-tree-node-previous n))
+                     (undo-tree-position
+                      n (undo-tree-node-next (undo-tree-node-previous n))))
+               (setq n (undo-tree-node-previous n)))))
+    ;; work backwards from current node until we intersect path back from
+    ;; selected node
+    (setq n (undo-tree-current buffer-undo-tree))
+    (while (not (gethash n path))
+      (setq n (undo-tree-node-previous n)))
+    ;; ascend tree until intersection node
+    (while (not (eq (undo-tree-current buffer-undo-tree) n))
+      (undo-tree-undo))
+    ;; descend tree until selected node
+    (while (not (eq (undo-tree-current buffer-undo-tree) node))
+      (undo-tree-redo))
+    n))  ; return intersection node
+
+
+
+(defun undo-tree-save-state-to-register (register)
+  "Store current undo-tree state to REGISTER.
+The saved state can be restored using
+`undo-tree-restore-state-from-register'.
+Argument is a character, naming the register."
+  (interactive "cUndo-tree state to register: ")
+  ;; throw error if undo is disabled in buffer
+  (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
+  ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
+  (undo-list-transfer-to-tree)
+  ;; save current node to REGISTER
+  (set-register register (undo-tree-current buffer-undo-tree))
+  ;; record REGISTER in current node, for visualizer
+  (setf (undo-tree-node-register (undo-tree-current buffer-undo-tree))
+	register))
+
+
+
+(defun undo-tree-restore-state-from-register (register)
+  "Restore undo-tree state from REGISTER.
+The state must be saved using `undo-tree-save-state-to-register'.
+Argument is a character, naming the register."
+  (interactive "cRestore undo-tree state from register: ")
+  ;; throw error if undo is disabled in buffer, or if register doesn't contain
+  ;; an undo-tree node
+  (let ((node (get-register register)))
+    (cond
+     ((eq buffer-undo-list t)
+      (error "No undo information in this buffer"))
+     ((not (undo-tree-node-p node))
+      (error "Register doesn't contain undo-tree state")))
+    ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
+    (undo-list-transfer-to-tree)
+    ;; restore buffer state corresponding to saved node
+    (undo-tree-set node)))
+
+
+
+
+;;; =====================================================================
+;;;                       Undo-tree visualizer
+
+(defun undo-tree-visualize ()
+  "Visualize the current buffer's undo tree."
+  (interactive)
+  (deactivate-mark)
+  ;; throw error if undo is disabled in buffer
+  (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
+  ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'
+  (undo-list-transfer-to-tree)
+  ;; add hook to kill visualizer buffer if original buffer is changed
+  (add-hook 'before-change-functions 'undo-tree-kill-visualizer nil t)
+  ;; prepare *undo-tree* buffer, then draw tree in it
+  (let ((undo-tree buffer-undo-tree)
+        (buff (current-buffer))
+	(display-buffer-mark-dedicated 'soft))
+    (switch-to-buffer-other-window undo-tree-visualizer-buffer-name)
+    (undo-tree-visualizer-mode)
+    (setq undo-tree-visualizer-parent-buffer buff)
+    (setq buffer-undo-tree undo-tree)
+    (setq buffer-read-only nil)
+    (undo-tree-draw-tree undo-tree)
+    (setq buffer-read-only t)))
+
+
+(defun undo-tree-kill-visualizer (&rest dummy)
+  ;; Kill visualizer. Added to `before-change-functions' hook of original
+  ;; buffer when visualizer is invoked.
+  (unless undo-in-progress
+    (unwind-protect
+	(with-current-buffer undo-tree-visualizer-buffer-name
+	  (undo-tree-visualizer-quit)))))
+
+
+
+(defun undo-tree-draw-tree (undo-tree)
+  ;; Draw UNDO-TREE in current buffer.
+  (erase-buffer)
+  (undo-tree-move-down 1)      ; top margin
+  (undo-tree-clear-visualizer-data undo-tree)
+  (undo-tree-compute-widths undo-tree)
+  (undo-tree-move-forward
+   (max (/ (window-width) 2)
+        (+ (undo-tree-node-char-lwidth (undo-tree-root undo-tree))
+           ;; add space for left part of left-most time-stamp
+           (if undo-tree-visualizer-timestamps 4 0)
+           2)))                ; left margin
+  ;; draw undo-tree
+  (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face)
+        (stack (list (undo-tree-root undo-tree)))
+        (n (undo-tree-root undo-tree)))
+    ;; link root node to its representation in visualizer
+    (unless (markerp (undo-tree-node-marker n))
+      (setf (undo-tree-node-marker n) (make-marker))
+      (set-marker-insertion-type (undo-tree-node-marker n) nil))
+    (move-marker (undo-tree-node-marker n) (point))
+    ;; draw nodes from stack until stack is empty
+    (while stack
+      (setq n (pop stack))
+      (goto-char (undo-tree-node-marker n))
+      (setq n (undo-tree-draw-subtree n nil))
+      (setq stack (append stack n))))
+  ;; highlight active branch
+  (goto-char (undo-tree-node-marker (undo-tree-root undo-tree)))
+  (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
+    (undo-tree-highlight-active-branch (undo-tree-root undo-tree)))
+  ;; highlight current node
+  (undo-tree-draw-node (undo-tree-current undo-tree) 'current))
+
+
+(defun undo-tree-highlight-active-branch (node)
+  ;; Draw highlighted active branch below NODE in current buffer.
+  (let ((stack (list node)))
+    ;; link node to its representation in visualizer
+    (unless (markerp (undo-tree-node-marker node))
+      (setf (undo-tree-node-marker node) (make-marker))
+      (set-marker-insertion-type (undo-tree-node-marker node) nil))
+    (move-marker (undo-tree-node-marker node) (point))
+    ;; draw active branch
+    (while stack
+      (setq node (pop stack))
+      (goto-char (undo-tree-node-marker node))
+      (setq node (undo-tree-draw-subtree node 'active))
+      (setq stack (append stack node)))))
+
+
+(defun undo-tree-draw-node (node &optional current)
+  ;; Draw symbol representing NODE in visualizer.
+  (goto-char (undo-tree-node-marker node))
+  ;; if displaying timestamps, represent node by timestamp
+  (if undo-tree-visualizer-timestamps
+      (progn
+        (backward-char 4)
+        (if current (undo-tree-insert ?*) (undo-tree-insert ? ))
+        (undo-tree-insert
+         (undo-tree-timestamp-to-string (undo-tree-node-timestamp node)))
+        (backward-char 5)
+        (move-marker (undo-tree-node-marker node) (point))
+        (put-text-property (- (point) 3) (+ (point) 5)
+                           'undo-tree-node node))
+    ;; represent node by differentl symbols, depending on whether it's the
+    ;; current node or is saved in a register
+    (let ((register (undo-tree-node-register node)))
+      (cond
+       (current
+	(let ((undo-tree-insert-face
+	       (cons 'undo-tree-visualizer-current-face
+		     (and (boundp 'undo-tree-insert-face)
+			  (or (and (consp undo-tree-insert-face)
+				   undo-tree-insert-face)
+			      (list undo-tree-insert-face))))))
+	  (undo-tree-insert ?x)))
+       ((and register (eq node (get-register register)))
+	(let ((undo-tree-insert-face
+	       (cons 'undo-tree-visualizer-register-face
+		     (and (boundp 'undo-tree-insert-face)
+			  (or (and (consp undo-tree-insert-face)
+				   undo-tree-insert-face)
+			      (list undo-tree-insert-face))))))
+	  (undo-tree-insert register)))
+       (t (undo-tree-insert ?o))))
+    (backward-char 1)
+    (put-text-property (point) (1+ (point)) 'undo-tree-node node)))
+
+
+(defun undo-tree-draw-subtree (node &optional active-branch)
+  ;; Draw subtree rooted at NODE. The subtree will start from point.
+  ;; If ACTIVE-BRANCH is non-nil, just draw active branch below NODE.
+  ;; If TIMESTAP is non-nil, draw time-stamps instead of "o" at nodes.
+  (let ((num-children (length (undo-tree-node-next node)))
+        node-list pos trunk-pos n)
+    ;; draw node itself
+    (undo-tree-draw-node node)
+
+    (cond
+     ;; if we're at a leaf node, we're done
+     ((= num-children 0))
+
+     ;; if node has only one child, draw it (not strictly necessary to deal
+     ;; with this case separately, but as it's by far the most common case
+     ;; this makes the code clearer and more efficient)
+     ((= num-children 1)
+      (undo-tree-move-down 1)
+      (undo-tree-insert ?|)
+      (backward-char 1)
+      (undo-tree-move-down 1)
+      (undo-tree-insert ?|)
+      (backward-char 1)
+      (undo-tree-move-down 1)
+      (setq n (car (undo-tree-node-next node)))
+      ;; link next node to its representation in visualizer
+      (unless (markerp (undo-tree-node-marker n))
+        (setf (undo-tree-node-marker n) (make-marker))
+        (set-marker-insertion-type (undo-tree-node-marker n) nil))
+      (move-marker (undo-tree-node-marker n) (point))
+      ;; add next node to list of nodes to draw next
+      (push n node-list))
+
+     ;; if node had multiple children, draw branches
+     (t
+      (undo-tree-move-down 1)
+      (undo-tree-insert ?|)
+      (backward-char 1)
+      (setq trunk-pos (point))
+      ;; left subtrees
+      (backward-char
+       (- (undo-tree-node-char-lwidth node)
+          (undo-tree-node-char-lwidth
+           (car (undo-tree-node-next node)))))
+      (setq pos (point))
+      (setq n (cons nil (undo-tree-node-next node)))
+      (dotimes (i (/ num-children 2))
+        (setq n (cdr n))
+        (when (or (null active-branch)
+                  (eq (car n)
+                      (nth (undo-tree-node-branch node)
+                           (undo-tree-node-next node))))
+          (undo-tree-move-forward 2)
+          (undo-tree-insert ?_ (- trunk-pos pos 2))
+          (goto-char pos)
+          (undo-tree-move-forward 1)
+          (undo-tree-move-down 1)
+          (undo-tree-insert ?/)
+          (backward-char 2)
+          (undo-tree-move-down 1)
+          ;; link node to its representation in visualizer
+          (unless (markerp (undo-tree-node-marker (car n)))
+            (setf (undo-tree-node-marker (car n)) (make-marker))
+            (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
+          (move-marker (undo-tree-node-marker (car n)) (point))
+          ;; add node to list of nodes to draw next
+          (push (car n) node-list))
+        (goto-char pos)
+        (undo-tree-move-forward
+         (+ (undo-tree-node-char-rwidth (car n))
+            (undo-tree-node-char-lwidth (cadr n))
+            undo-tree-visualizer-spacing 1))
+        (setq pos (point)))
+      ;; middle subtree (only when number of children is odd)
+      (when (= (mod num-children 2) 1)
+        (setq n (cdr n))
+        (when (or (null active-branch)
+                  (eq (car n)
+                      (nth (undo-tree-node-branch node)
+                           (undo-tree-node-next node))))
+          (undo-tree-move-down 1)
+          (undo-tree-insert ?|)
+          (backward-char 1)
+          (undo-tree-move-down 1)
+          ;; link node to its representation in visualizer
+          (unless (markerp (undo-tree-node-marker (car n)))
+            (setf (undo-tree-node-marker (car n)) (make-marker))
+            (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
+          (move-marker (undo-tree-node-marker (car n)) (point))
+          ;; add node to list of nodes to draw next
+          (push (car n) node-list))
+        (goto-char pos)
+        (undo-tree-move-forward
+         (+ (undo-tree-node-char-rwidth (car n))
+            (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0)
+            undo-tree-visualizer-spacing 1))
+        (setq pos (point)))
+      ;; right subtrees
+      (incf trunk-pos)
+      (dotimes (i (/ num-children 2))
+        (setq n (cdr n))
+        (when (or (null active-branch)
+                  (eq (car n)
+                      (nth (undo-tree-node-branch node)
+                           (undo-tree-node-next node))))
+          (goto-char trunk-pos)
+          (undo-tree-insert ?_ (- pos trunk-pos 1))
+          (goto-char pos)
+          (backward-char 1)
+          (undo-tree-move-down 1)
+          (undo-tree-insert ?\\)
+          (undo-tree-move-down 1)
+          ;; link node to its representation in visualizer
+          (unless (markerp (undo-tree-node-marker (car n)))
+            (setf (undo-tree-node-marker (car n)) (make-marker))
+            (set-marker-insertion-type (undo-tree-node-marker (car n)) nil))
+          (move-marker (undo-tree-node-marker (car n)) (point))
+          ;; add node to list of nodes to draw next
+          (push (car n) node-list))
+        (when (cdr n)
+          (goto-char pos)
+          (undo-tree-move-forward
+           (+ (undo-tree-node-char-rwidth (car n))
+              (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0)
+              undo-tree-visualizer-spacing 1))
+          (setq pos (point))))
+      ))
+    ;; return list of nodes to draw next
+    (nreverse node-list)))
+
+
+
+(defun undo-tree-node-char-lwidth (node)
+  ;; Return left-width of NODE measured in characters.
+  (if (= (length (undo-tree-node-next node)) 0) 0
+    (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-lwidth node))
+       (if (= (undo-tree-node-cwidth node) 0)
+           (1+ (/ undo-tree-visualizer-spacing 2)) 0))))
+
+
+(defun undo-tree-node-char-rwidth (node)
+  ;; Return right-width of NODE measured in characters.
+  (if (= (length (undo-tree-node-next node)) 0) 0
+    (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-rwidth node))
+       (if (= (undo-tree-node-cwidth node) 0)
+           (1+ (/ undo-tree-visualizer-spacing 2)) 0))))
+
+
+(defun undo-tree-insert (str &optional arg)
+  ;; Insert character or string STR ARG times, overwriting, and using
+  ;; `undo-tree-insert-face'.
+  (unless arg (setq arg 1))
+  (when (characterp str)
+    (setq str (make-string arg str))
+    (setq arg 1))
+  (dotimes (i arg) (insert str))
+  (setq arg (* arg (length str)))
+  (undo-tree-move-forward arg)
+  ;; make sure mark isn't active, otherwise `backward-delete-char' might
+  ;; delete region instead of single char if transient-mark-mode is enabled
+  (setq mark-active nil)
+  (backward-delete-char arg)
+  (when (boundp 'undo-tree-insert-face)
+    (put-text-property (- (point) arg) (point) 'face undo-tree-insert-face)))
+
+
+(defun undo-tree-move-down (&optional arg)
+  ;; Move down, extending buffer if necessary.
+  (let ((row (line-number-at-pos))
+        (col (current-column))
+        line)
+    (unless arg (setq arg 1))
+    (forward-line arg)
+    (setq line (line-number-at-pos))
+    ;; if buffer doesn't have enough lines, add some
+    (when (/= line (+ row arg))
+      (insert (make-string (- arg (- line row)) ?\n)))
+    (undo-tree-move-forward col)))
+
+
+(defun undo-tree-move-forward (&optional arg)
+  ;; Move forward, extending buffer if necessary.
+  (unless arg (setq arg 1))
+  (let ((n (- (line-end-position) (point))))
+    (if (> n arg)
+        (forward-char arg)
+      (end-of-line)
+      (insert (make-string (- arg n) ? )))))
+
+
+(defun undo-tree-timestamp-to-string (timestamp)
+  ;; Convert TIMESTAMP to hh:mm:ss string.
+  (let ((time (decode-time timestamp)))
+    (format "%02d:%02d:%02d" (nth 2 time) (nth 1 time) (nth 0 time))))
+
+
+
+
+;;; =====================================================================
+;;;                    Visualizer mode commands
+
+(defun undo-tree-visualizer-mode ()
+  "Major mode used in undo-tree visualizer.
+
+The undo-tree visualizer can only be invoked from a buffer in
+which `undo-tree-mode' is enabled. The visualizer displays the
+undo history tree graphically, and allows you to browse around
+the undo history, undoing or redoing the corresponding changes in
+the parent buffer.
+
+Within the undo-tree visualizer, the following keys are available:
+
+  \\{undo-tree-visualizer-map}"
+  (interactive)
+  (setq major-mode 'undo-tree-visualizer-mode)
+  (setq mode-name "undo-tree-visualizer-mode")
+  (use-local-map undo-tree-visualizer-map)
+  (setq truncate-lines t)
+  (setq cursor-type nil)
+  (setq buffer-read-only t))
+
+
+
+(defun undo-tree-visualize-undo (&optional arg)
+  "Undo changes. A numeric ARG serves as a repeat count."
+  (interactive "p")
+  (setq buffer-read-only nil)
+  (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
+    (undo-tree-draw-node (undo-tree-current buffer-undo-tree)))
+  (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer)
+  (deactivate-mark)
+  (unwind-protect
+      (undo-tree-undo arg)
+    (switch-to-buffer-other-window undo-tree-visualizer-buffer-name)
+    (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current)
+    (setq buffer-read-only t)))
+
+
+(defun undo-tree-visualize-redo (&optional arg)
+  "Redo changes. A numeric ARG serves as a repeat count."
+  (interactive "p")
+  (setq buffer-read-only nil)
+  (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
+    (undo-tree-draw-node (undo-tree-current buffer-undo-tree)))
+  (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer)
+  (deactivate-mark)
+  (unwind-protect
+      (undo-tree-redo arg)
+    (switch-to-buffer-other-window undo-tree-visualizer-buffer-name)
+    (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
+    (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current)
+    (setq buffer-read-only t)))
+
+
+(defun undo-tree-visualize-switch-branch-right (arg)
+  "Switch to next branch of the undo tree.
+This will affect which branch to descend when *redoing* changes
+using `undo-tree-redo' or `undo-tree-visualizer-redo'."
+  (interactive "p")
+  ;; un-highlight old active branch below current node
+  (setq buffer-read-only nil)
+  (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
+  (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face))
+    (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree)))
+  ;; increment branch
+  (let ((branch (undo-tree-node-branch (undo-tree-current buffer-undo-tree))))
+  (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree))
+        (cond
+         ((>= (+ branch arg) (undo-tree-num-branches))
+          (1- (undo-tree-num-branches)))
+         ((<= (+ branch arg) 0) 0)
+         (t (+ branch arg))))
+  ;; highlight new active branch below current node
+  (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree)))
+  (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face))
+    (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree)))
+  ;; re-highlight current node
+  (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current)
+  (setq buffer-read-only t)))
+
+
+(defun undo-tree-visualize-switch-branch-left (arg)
+  "Switch to previous branch of the undo tree.
+This will affect which branch to descend when *redoing* changes
+using `undo-tree-redo' or `undo-tree-visualizer-redo'."
+  (interactive "p")
+  (undo-tree-visualize-switch-branch-right (- arg)))
+
+
+(defun undo-tree-visualizer-quit ()
+  "Quit the undo-tree visualizer."
+  (interactive)
+  (undo-tree-clear-visualizer-data buffer-undo-tree)
+  ;; remove kill visualizer hook from parent buffer
+  (unwind-protect
+      (with-current-buffer undo-tree-visualizer-parent-buffer
+	(remove-hook 'before-change-functions 'undo-tree-kill-visualizer t))
+    (let ((parent undo-tree-visualizer-parent-buffer)
+	  window)
+      (kill-buffer nil)
+      (if (setq window (get-buffer-window parent))
+	  (select-window window)
+	(switch-to-buffer parent)))))
+
+
+(defun undo-tree-visualizer-set (&optional pos)
+  "Set buffer to state corresponding to undo tree node
+at POS, or point if POS is nil."
+  (interactive)
+  (unless pos (setq pos (point)))
+  (let ((node (get-text-property pos 'undo-tree-node)))
+    (when node
+      ;; set parent buffer to state corresponding to node at POS
+      (set-buffer undo-tree-visualizer-parent-buffer)
+      (undo-tree-set node)
+      (set-buffer undo-tree-visualizer-buffer-name)
+      (setq buffer-read-only nil)
+      ;; re-draw undo tree
+      (undo-tree-draw-tree buffer-undo-tree)
+      (setq buffer-read-only t))))
+
+
+(defun undo-tree-visualizer-mouse-set (pos)
+  "Set buffer to state corresponding to undo tree node
+at mouse event POS."
+  (interactive "@e")
+  (undo-tree-visualizer-set (event-start (nth 1 pos))))
+
+
+(defun undo-tree-visualizer-toggle-timestamps ()
+  "Toggle display of time-stamps."
+  (interactive)
+  (setq undo-tree-visualizer-spacing
+        (if (setq undo-tree-visualizer-timestamps
+                  (not undo-tree-visualizer-timestamps))
+            ;; need sufficient space if TIMESTAMP is set
+            (max 9 (default-value 'undo-tree-visualizer-spacing))
+          (default-value 'undo-tree-visualizer-spacing)))
+  ;; redraw tree
+  (setq buffer-read-only nil)
+  (undo-tree-draw-tree buffer-undo-tree)
+  (setq buffer-read-only t))
+
+
+(defun undo-tree-visualizer-scroll-left (&optional arg)
+  (interactive "p")
+  (scroll-right (or arg 1) t))
+
+
+(defun undo-tree-visualizer-scroll-right (&optional arg)
+  (interactive "p")
+  (scroll-left (or arg 1) t))
+
+
+
+
+;;; =====================================================================
+;;;                    Visualizer selection mode
+
+(defun undo-tree-visualizer-selection-mode ()
+  "Major mode used to select nodes in undo-tree visualizer."
+  (interactive)
+  (setq major-mode 'undo-tree-visualizer-selection-mode)
+  (setq mode-name "undo-tree-visualizer-selection-mode")
+  (use-local-map undo-tree-visualizer-selection-map)
+  (setq cursor-type 'box))
+
+
+(defun undo-tree-visualizer-select-previous (&optional arg)
+  "Move to previous node."
+  (interactive "p")
+  (let ((node (get-text-property (point) 'undo-tree-node)))
+    (catch 'top
+      (dotimes (i arg)
+	(unless (undo-tree-node-previous node) (throw 'top t))
+	(setq node (undo-tree-node-previous node))))
+    (goto-char (undo-tree-node-marker node))))
+
+
+(defun undo-tree-visualizer-select-next (&optional arg)
+  "Move to next node."
+  (interactive "p")
+  (let ((node (get-text-property (point) 'undo-tree-node)))
+    (catch 'bottom
+      (dotimes (i arg)
+	(unless (nth (undo-tree-node-branch node) (undo-tree-node-next node))
+	  (throw 'bottom t))
+	(setq node
+	      (nth (undo-tree-node-branch node) (undo-tree-node-next node)))))
+    (goto-char (undo-tree-node-marker node))))
+
+
+(defun undo-tree-visualizer-select-right (&optional arg)
+  "Move right to a sibling node."
+  (interactive "p")
+  (let ((pos (point))
+	(end (line-end-position))
+	node)
+    (catch 'end
+      (dotimes (i arg)
+	(while (not node)
+	  (forward-char)
+	  (setq node (get-text-property (point) 'undo-tree-node))
+	  (when (= (point) end) (throw 'end t)))))
+    (goto-char (if node (undo-tree-node-marker node) pos))))
+
+
+(defun undo-tree-visualizer-select-left (&optional arg)
+  "Move left to a sibling node."
+  (interactive "p")
+  (let ((pos (point))
+	(beg (line-beginning-position))
+	node)
+    (catch 'beg
+      (dotimes (i arg)
+	(while (not node)
+	  (backward-char)
+	  (setq node (get-text-property (point) 'undo-tree-node))
+	  (when (= (point) beg) (throw 'beg t)))))
+    (goto-char (if node (undo-tree-node-marker node) pos))))
+
+
+
+(provide 'undo-tree)
+
+;;; undo-tree.el ends here