* bug#25351: Patch for bug#25351: 26.0.50; Testcover doesn't work on code that creates simple lists and modifies them
2017-01-04 3:06 bug#25351: 26.0.50; Testcover doesn't work on code that creates simple lists and modifies them Gemini Lasswell
@ 2017-09-26 21:04 ` Gemini Lasswell
2017-10-08 23:53 ` Gemini Lasswell
0 siblings, 1 reply; 3+ messages in thread
From: Gemini Lasswell @ 2017-09-26 21:04 UTC (permalink / raw)
To: 25351
[-- Attachment #1: Type: text/plain, Size: 786 bytes --]
Here is a patch which fixes this bug by making a copy of the result of
the first evaluation of a form to compare with the results of
subsequent evaluations.
This patch is based on the two patches I sent yesterday to bug#25316.
Because Testcover may encounter circular structures in the code it
instruments, I wrote a modified version of copy-tree which can handle
circular structures. It's possibly generally useful enough to belong
in subr.el alongside copy-tree instead of being an internal Testcover
function, but I will submit that idea as a separate wishlist item.
There isn't currently a version of `equal' which works for circular
structures, so Testcover's handling of them is not fully implemented,
but it now avoids stopping the code under coverage with an error
message.
[-- Attachment #2: 0001-Stop-Testcover-from-producing-spurious-1value-errors.patch --]
[-- Type: text/plain, Size: 7565 bytes --]
From 6545b936c2f458f6dbe437e6dec6acc4277d33fd Mon Sep 17 00:00:00 2001
From: Gemini Lasswell <gazally@runbox.com>
Date: Tue, 26 Sep 2017 08:14:23 -0700
Subject: [PATCH] Stop Testcover from producing spurious 1value errors
(bug#25351)
Fix bug#25351 by copying results of form evaluations for later
comparison.
* lisp/emacs-lisp/testcover.el (testcover-after): Copy the result
of a form's first evaluation and compare subsequent evaluations to
the copy. Improve the error message used when a form's value
changes.
(testcover--copy-object, testcover--copy-object1): New functions.
* test/lisp/emacs-lisp/testcover-resources/testcases.el
(by-value-vs-by-reference-bug-25351): Remove expected failure tag.
(circular-lists-bug-24402): Add another circular list case.
---
lisp/emacs-lisp/testcover.el | 95 ++++++++++++++++------
.../emacs-lisp/testcover-resources/testcases.el | 15 +++-
2 files changed, 81 insertions(+), 29 deletions(-)
diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el
index d9c0d085e5..b9eca67427 100644
--- a/lisp/emacs-lisp/testcover.el
+++ b/lisp/emacs-lisp/testcover.el
@@ -49,11 +49,10 @@
;; function being called is capable of returning in other cases.
;; Problems:
-;; * To detect different values, we store the form's result in a vector and
-;; compare the next result using `equal'. We don't copy the form's
-;; result, so if caller alters it (`setcar', etc.) we'll think the next
-;; call has the same value! Also, equal thinks two strings are the same
-;; if they differ only in properties.
+;; * `equal', which is used to compare the results of repeatedly executing
+;; a form, has a couple of shortcomings. It considers strings to be the same
+;; if they only differ in properties, and it raises an error when asked to
+;; compare circular lists.
;; * Because we have only a "1value" class and no "always nil" class, we have
;; to treat as potentially 1-valued any `and' whose last term is 1-valued,
;; in case the last term is always nil. Example:
@@ -259,26 +258,25 @@ testcover-after
AFTER-INDEX is the form's index into the code-coverage
vector. Return VALUE."
(let ((old-result (aref testcover-vector after-index)))
- (cond
- ((eq 'unknown old-result)
- (aset testcover-vector after-index value))
- ((eq 'maybe old-result)
- (aset testcover-vector after-index 'ok-coverage))
- ((eq '1value old-result)
- (aset testcover-vector after-index
- (cons old-result value)))
- ((and (eq (car-safe old-result) '1value)
- (not (condition-case ()
- (equal (cdr old-result) value)
- ;; TODO: Actually check circular lists for equality.
- (circular-list t))))
- (error "Value of form marked with `1value' does vary: %s" value))
- ;; Test if a different result.
- ((not (condition-case ()
- (equal value old-result)
- ;; TODO: Actually check circular lists for equality.
- (circular-list nil)))
- (aset testcover-vector after-index 'ok-coverage))))
+ (cond
+ ((eq 'unknown old-result)
+ (aset testcover-vector after-index (testcover--copy-object value)))
+ ((eq 'maybe old-result)
+ (aset testcover-vector after-index 'ok-coverage))
+ ((eq '1value old-result)
+ (aset testcover-vector after-index
+ (cons old-result (testcover--copy-object value))))
+ ((and (eq (car-safe old-result) '1value)
+ (not (condition-case ()
+ (equal (cdr old-result) value)
+ (circular-list t))))
+ (error "Value of form expected to be constant does vary, from %s to %s"
+ old-result value))
+ ;; Test if a different result.
+ ((not (condition-case ()
+ (equal value old-result)
+ (circular-list nil)))
+ (aset testcover-vector after-index 'ok-coverage))))
value)
;; Add these behaviors to Edebug.
@@ -286,6 +284,53 @@ testcover-after
(push '(testcover testcover-enter testcover-before testcover-after)
edebug-behavior-alist))
+(defun testcover--copy-object (obj)
+ "Make a copy of OBJ.
+If OBJ is a cons cell, copy both its car and its cdr.
+Contrast to `copy-tree' which does the same but fails on circular
+structures, and `copy-sequence', which copies only along the
+cdrs. Copy vectors as well as conses."
+ (let ((ht (make-hash-table :test 'eq)))
+ (testcover--copy-object1 obj t ht)))
+
+(defun testcover--copy-object1 (obj vecp hash-table)
+ "Make a copy of OBJ, using a HASH-TABLE of objects already copied.
+If OBJ is a cons cell, this recursively copies its car and
+iteratively copies its cdr. When VECP is non-nil, copy
+vectors as well as conses."
+ (if (and (atom obj) (or (not vecp) (not (vectorp obj))))
+ obj
+ (let ((copy (gethash obj hash-table nil)))
+ (unless copy
+ (cond
+ ((consp obj)
+ (let* ((rest obj) current)
+ (setq copy (cons nil nil)
+ current copy)
+ (while
+ (progn
+ (puthash rest current hash-table)
+ (setf (car current)
+ (testcover--copy-object1 (car rest) vecp hash-table))
+ (setq rest (cdr rest))
+ (cond
+ ((atom rest)
+ (setf (cdr current)
+ (testcover--copy-object1 rest vecp hash-table))
+ nil)
+ ((gethash rest hash-table nil)
+ (setf (cdr current) (gethash rest hash-table nil))
+ nil)
+ (t (setq current
+ (setf (cdr current) (cons nil nil)))))))))
+ (t ; (and vecp (vectorp obj)) is true due to test in if above.
+ (setq copy (copy-sequence obj))
+ (puthash obj copy hash-table)
+ (dotimes (i (length copy))
+ (aset copy i
+ (testcover--copy-object1 (aref copy i) vecp hash-table))))))
+ copy)))
+
;;;=========================================================================
;;; Display the coverage data as color splotches on your code.
;;;=========================================================================
diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el
index 61a457ac36..e4bc3fdb5a 100644
--- a/test/lisp/emacs-lisp/testcover-resources/testcases.el
+++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el
@@ -357,7 +357,6 @@ testcover-testcase-baz
;; ==== by-value-vs-by-reference-bug-25351 ====
"An object created by a 1value expression may be modified by other code."
-:expected-result :failed
;; ====
(defun testcover-testcase-ab ()
(list 'a 'b))
@@ -483,10 +482,18 @@ testcover-testcase-how-do-i-know-you
"Testcover captures and ignores circular list errors."
;; ====
(defun testcover-testcase-cyc1 (a)
- (let ((ls (make-list 10 a%%%)))
- (nconc ls ls)
- ls))
+ (let ((ls (make-list 10 a%%%)%%%))
+ (nconc ls%%% ls%%%)
+ ls)) ; The lack of a mark here is due to an ignored circular list error.
(testcover-testcase-cyc1 1)
(testcover-testcase-cyc1 1)
+(defun testcover-testcase-cyc2 (a b)
+ (let ((ls1 (make-list 10 a%%%)%%%)
+ (ls2 (make-list 10 b)))
+ (nconc ls2 ls2)
+ (nconc ls1%%% ls2)
+ ls1))
+(testcover-testcase-cyc2 1 2)
+(testcover-testcase-cyc2 1 4)
;; testcases.el ends here.
--
2.14.1
^ permalink raw reply related [flat|nested] 3+ messages in thread