bug#25351: 26.0.50; Testcover doesn't work on code that creates simple lists and modifies them

bug#25351: 26.0.50; Testcover doesn't work on code that creates simple lists and modifies them

[Gemini Lasswell]

Testcover marks forms which have only returned a single value while under
code coverage with a tan splotch to indicate insufficient test coverage,
It also identifies forms which will only ever return a single value and
suppresses the splotch on those. During the coverage run, it saves a
reference to the return value of those single value forms, and the next
time the form is evaluated, it uses `equal' to determine if the value
has changed, and if it has, Testcover reports an error.

The problem with this is that it is a common idiom to create a data
structure using an expression that always returns the same thing, and
then modify it later. Since Testcover keeps a reference not a copy, it
ends up with a reference to a modified object, which fails the
comparison with the next return value of the same expression.

For example:

(defun my-blank-record ()
  (list (list 'name) (list 'age)))

(defun my-make-record (name age)
  (let ((rec (my-blank-record)))
    (setf (cdr (assq 'name rec)) name)
    (setf (cdr (assq 'age rec)) age)
    rec))

(my-make-record "Jack" 10)
(my-make-record "Jill" 12)

To reproduce this problem, save the above code in a file called bug.el,
and then:

M-x testcover-start RET bug.el RET

The result will be testcover-1value's "Value of form marked with
‘1value’ does vary" error.

bug#25351: Patch for bug#25351: 26.0.50; Testcover doesn't work on code that creates simple lists and modifies them

[Gemini Lasswell]

[-- 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

bug#25351: Patch for bug#25351: 26.0.50; Testcover doesn't work on code that creates simple lists and modifies them

[Gemini Lasswell]

I've pushed this patch to master.