From: Christian Ohler Date: Thu, 3 Mar 2011 09:01:51 +0000 (-0700) Subject: Added fast path to ERT explanation of `equal'. X-Git-Tag: emacs-pretest-24.0.90~104^2~275^2~674^2~57^2 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=de69c0a8d1ff21a0bd5663a555e47285aa1c70e1;p=emacs.git 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. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b4b7525872b..9602bf20af6 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,12 @@ +2011-03-03 Christian Ohler + + * 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 * emacs-lisp/ert.el (ert--stats-set-test-and-result) 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 + + * automated/ert-tests.el (ert-test-explain-not-equal-keymaps): + New test. + 2011-02-20 Ulf Jasper * 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))