mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-24 07:20:37 +00:00
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.
This commit is contained in:
Christian Ohler
parent
7c0d14414f
commit
de69c0a8d1
@ -1,3 +1,12 @@
|
||||
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)
|
||||
|
||||
@ -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'.
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user