Added fast path to ERT explanation of `equal'.

* emacs-lisp/ert.el (ert--explain-equal): New function.
(ert--explain-equal-rec): Renamed from `ert--explain-not-equal'.
All callers changed.
(ert--explain-equal-including-properties): Renamed from
`ert--explain-not-equal-including-properties'.  All callers
changed.
* automated/ert-tests.el (ert-test-explain-not-equal-keymaps):
New test.

4 files changed, 59 insertions, 30 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index b4b7525872b..9602bf20af6 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,14 @@
 2011-03-03  Christian Ohler  <ohler@gnu.org>
 
+        * emacs-lisp/ert.el (ert--explain-equal): New function.
+        (ert--explain-equal-rec): Renamed from `ert--explain-not-equal'.
+        All callers changed.
+        (ert--explain-equal-including-properties): Renamed from
+        `ert--explain-not-equal-including-properties'.  All callers
+        changed.
+
+2011-03-03  Christian Ohler  <ohler@gnu.org>
+
         * emacs-lisp/ert.el (ert--stats-set-test-and-result)
         (ert-char-for-test-result, ert-string-for-test-result)
         (ert-run-tests-batch, ert--print-test-for-ewoc):
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 9767ae7549e..5bd8fd01b1e 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -219,7 +219,7 @@ 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-not-equal-including-properties a b)))
+  (not (ert--explain-equal-including-properties a b)))
 
 
 ;;; Defining and locating tests.
@@ -571,16 +571,15 @@ failed."
    (when (and (not firstp) (eq fast slow)) (return nil))))
 
 (defun ert--explain-format-atom (x)
-  "Format the atom X for `ert--explain-not-equal'."
+  "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-not-equal (a b)
-  "Explainer function for `equal'.
+(defun ert--explain-equal-rec (a b)
+  "Returns a programmer-readable explanation of why A and B are not `equal'.
 
-Returns a programmer-readable explanation of why A and B are not
-`equal', or nil if they are."
+Returns nil if they are."
   (if (not (equal (type-of a) (type-of b)))
       `(different-types ,a ,b)
     (etypecase a
@@ -598,13 +597,13 @@ Returns a programmer-readable explanation of why A and B are not
                  (loop for i from 0
                        for ai in a
                        for bi in b
-                       for xi = (ert--explain-not-equal ai bi)
+                       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-not-equal (car a) (car b))))
+             (let ((car-x (ert--explain-equal-rec (car a) (car b))))
                (if car-x
                    `(car ,car-x)
-                 (let ((cdr-x (ert--explain-not-equal (cdr a) (cdr b))))
+                 (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b))))
                    (if cdr-x
                        `(cdr ,cdr-x)
                      (assert (equal a b) t)
@@ -618,7 +617,7 @@ Returns a programmer-readable explanation of why A and B are not
                (loop for i from 0
                      for ai across a
                      for bi across b
-                     for xi = (ert--explain-not-equal ai bi)
+                     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))
@@ -627,7 +626,15 @@ Returns a programmer-readable explanation of why A and B are not
                   `(different-atoms ,(ert--explain-format-atom a)
                                     ,(ert--explain-format-atom b)))
               nil)))))
-(put 'equal 'ert-explainer 'ert--explain-not-equal)
+
+(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."
@@ -658,8 +665,8 @@ key/value pairs in each list does not matter."
                    (value-b (plist-get b key)))
                (assert (not (equal value-a value-b)) t)
                `(different-properties-for-key
-                 ,key ,(ert--explain-not-equal-including-properties value-a
-                                                                    value-b)))))
+                 ,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
@@ -681,13 +688,16 @@ If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix."
           (t
            (substring s 0 len)))))
 
-(defun ert--explain-not-equal-including-properties (a b)
+;; 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-not-equal a b)
+      (ert--explain-equal a b)
     (assert (stringp a) t)
     (assert (stringp b) t)
     (assert (eql (length a) (length b)) t)
@@ -713,7 +723,7 @@ Returns a programmer-readable explanation of why A and B are not
           )))
 (put 'ert-equal-including-properties
      'ert-explainer
-     'ert--explain-not-equal-including-properties)
+     'ert--explain-equal-including-properties)
 
 
 ;;; Implementation of `ert-info'.
diff --git a/test/ChangeLog b/test/ChangeLog
index dbfc6c6cefe..8b7feaddf62 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,8 @@
+2011-03-03  Christian Ohler  <ohler@gnu.org>
+
+        * automated/ert-tests.el (ert-test-explain-not-equal-keymaps):
+        New test.
+
 2011-02-20  Ulf Jasper  <ulf.jasper@web.de>
 
         * automated/icalendar-tests.el: Move from icalendar-testsuite.el;
diff --git a/test/automated/ert-tests.el b/test/automated/ert-tests.el
index b6d70dee7e2..cea994f64b8 100644
--- a/test/automated/ert-tests.el
+++ b/test/automated/ert-tests.el
@@ -796,27 +796,32 @@ This macro is used to test if macroexpansion in `should' works."
   (should (equal (ert--string-first-line "foo\nbar") "foo"))
   (should (equal (ert--string-first-line " foo\nbar\nbaz\n") " foo")))
 
-(ert-deftest ert-test-explain-not-equal ()
-  (should (equal (ert--explain-not-equal nil 'foo)
+(ert-deftest ert-test-explain-equal ()
+  (should (equal (ert--explain-equal nil 'foo)
                  '(different-atoms nil foo)))
-  (should (equal (ert--explain-not-equal '(a a) '(a b))
+  (should (equal (ert--explain-equal '(a a) '(a b))
                  '(list-elt 1 (different-atoms a b))))
-  (should (equal (ert--explain-not-equal '(1 48) '(1 49))
+  (should (equal (ert--explain-equal '(1 48) '(1 49))
                  '(list-elt 1 (different-atoms (48 "#x30" "?0")
                                                (49 "#x31" "?1")))))
-  (should (equal (ert--explain-not-equal 'nil '(a))
+  (should (equal (ert--explain-equal 'nil '(a))
                  '(different-types nil (a))))
-  (should (equal (ert--explain-not-equal '(a b c) '(a b c d))
+  (should (equal (ert--explain-equal '(a b c) '(a b c d))
                  '(proper-lists-of-different-length 3 4 (a b c) (a b c d)
                                                     first-mismatch-at 3)))
   (let ((sym (make-symbol "a")))
-    (should (equal (ert--explain-not-equal 'a sym)
+    (should (equal (ert--explain-equal 'a sym)
                    `(different-symbols-with-the-same-name a ,sym)))))
 
-(ert-deftest ert-test-explain-not-equal-improper-list ()
-  (should (equal (ert--explain-not-equal '(a . b) '(a . c))
+(ert-deftest ert-test-explain-equal-improper-list ()
+  (should (equal (ert--explain-equal '(a . b) '(a . c))
                  '(cdr (different-atoms b c)))))
 
+(ert-deftest ert-test-explain-equal-keymaps ()
+  ;; This used to be very slow.
+  (should (equal (make-keymap) (make-keymap)))
+  (should (equal (make-sparse-keymap) (make-sparse-keymap))))
+
 (ert-deftest ert-test-significant-plist-keys ()
   (should (equal (ert--significant-plist-keys '()) '()))
   (should (equal (ert--significant-plist-keys '(a b c d e f c g p q r nil s t))
@@ -852,21 +857,21 @@ This macro is used to test if macroexpansion in `should' works."
   (should (equal (ert--abbreviate-string "bar" 1 t) "r"))
   (should (equal (ert--abbreviate-string "bar" 0 t) "")))
 
-(ert-deftest ert-test-explain-not-equal-string-properties ()
+(ert-deftest ert-test-explain-equal-string-properties ()
   (should
-   (equal (ert--explain-not-equal-including-properties #("foo" 0 1 (a b))
-                                                       "foo")
+   (equal (ert--explain-equal-including-properties #("foo" 0 1 (a b))
+                                                   "foo")
           '(char 0 "f"
                  (different-properties-for-key a (different-atoms b nil))
                  context-before ""
                  context-after "oo")))
-  (should (equal (ert--explain-not-equal-including-properties
+  (should (equal (ert--explain-equal-including-properties
                   #("foo" 1 3 (a b))
                   #("goo" 0 1 (c d)))
                  '(array-elt 0 (different-atoms (?f "#x66" "?f")
                                                 (?g "#x67" "?g")))))
   (should
-   (equal (ert--explain-not-equal-including-properties
+   (equal (ert--explain-equal-including-properties
            #("foo" 0 1 (a b c d) 1 3 (a b))
            #("foo" 0 1 (c d a b) 1 2 (a foo)))
           '(char 1 "o" (different-properties-for-key a (different-atoms b foo))