[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] /srv/bzr/emacs/trunk r103500: Merged an ERT fix and a spee
From: |
Christian Ohler |
Subject: |
[Emacs-diffs] /srv/bzr/emacs/trunk r103500: Merged an ERT fix and a speedup. |
Date: |
Thu, 03 Mar 2011 02:10:19 -0700 |
User-agent: |
Bazaar (2.0.3) |
------------------------------------------------------------
revno: 103500 [merge]
committer: Christian Ohler <address@hidden>
branch nick: trunk
timestamp: Thu 2011-03-03 02:10:19 -0700
message:
Merged an ERT fix and a speedup.
modified:
lisp/ChangeLog
lisp/emacs-lisp/ert.el
test/ChangeLog
test/automated/ert-tests.el
=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog 2011-03-03 08:19:34 +0000
+++ b/lisp/ChangeLog 2011-03-03 09:10:19 +0000
@@ -1,3 +1,19 @@
+2011-03-03 Christian Ohler <address@hidden>
+
+ * 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 <address@hidden>
+
+ * 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):
+ Handle `ert-test-quit'.
+
2011-03-03 David Abrahams <address@hidden> (tiny change)
* vc/ediff-init.el (ediff-use-faces, ediff-highlight-all-diffs):
=== modified file 'lisp/emacs-lisp/ert.el'
--- a/lisp/emacs-lisp/ert.el 2011-02-18 04:20:36 +0000
+++ b/lisp/emacs-lisp/ert.el 2011-03-03 09:01:51 +0000
@@ -219,7 +219,7 @@
;; 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 @@
(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 @@
(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 @@
(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 @@
`(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 @@
(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 @@
(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 @@
)))
(put 'ert-equal-including-properties
'ert-explainer
- 'ert--explain-not-equal-including-properties)
+ 'ert--explain-equal-including-properties)
;;; Implementation of `ert-info'.
@@ -1244,12 +1254,14 @@
(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-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-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.
@@ -1342,7 +1354,8 @@
(ert-test-passed ".P")
(ert-test-failed "fF")
(null "--")
- (ert-test-aborted-with-non-local-exit "aA"))))
+ (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)
@@ -1353,7 +1366,8 @@
(ert-test-passed '("passed" "PASSED"))
(ert-test-failed '("failed" "FAILED"))
(null '("unknown" "UNKNOWN"))
- (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED")))))
+ (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)
@@ -1478,7 +1492,9 @@
(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-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))
@@ -1853,7 +1869,9 @@
(ert-test-result-with-condition-condition result))
(ert--make-xrefs-region begin (point)))))
(ert-test-aborted-with-non-local-exit
- (insert " aborted\n")))
+ (insert " aborted\n"))
+ (ert-test-quit
+ (insert " quit\n")))
(insert "\n")))))
nil)
=== modified file 'test/ChangeLog'
--- a/test/ChangeLog 2011-02-20 14:35:58 +0000
+++ b/test/ChangeLog 2011-03-03 09:01:51 +0000
@@ -1,3 +1,8 @@
+2011-03-03 Christian Ohler <address@hidden>
+
+ * automated/ert-tests.el (ert-test-explain-not-equal-keymaps):
+ New test.
+
2011-02-20 Ulf Jasper <address@hidden>
* automated/icalendar-tests.el: Move from icalendar-testsuite.el;
=== modified file 'test/automated/ert-tests.el'
--- a/test/automated/ert-tests.el 2011-01-25 04:08:28 +0000
+++ b/test/automated/ert-tests.el 2011-03-03 09:01:51 +0000
@@ -796,27 +796,32 @@
(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 @@
(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))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] /srv/bzr/emacs/trunk r103500: Merged an ERT fix and a speedup.,
Christian Ohler <=