[Emacs-diffs] master 3c2e8ef 3/3: Stop Testcover from producing spurious 1value errors

[Gemini Lasswell]

branch: master
commit 3c2e8eff8cc9a4a535f473b3e150cb056d8f891d
Author: Gemini Lasswell <address@hidden>
Commit: Gemini Lasswell <address@hidden>

    Stop Testcover from producing spurious 1value errors
    
    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 320c43b..3628968 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 @@ BEFORE-INDEX is the form's index into the code-coverage 
vector."
 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 @@ vector.  Return VALUE."
   (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 d8b8192..6a9612d 100644
--- a/test/lisp/emacs-lisp/testcover-resources/testcases.el
+++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el
@@ -357,7 +357,6 @@
 
 ;; ==== 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))
@@ -491,10 +490,18 @@ regarding the odd-looking coverage result for the quoted 
form."
 "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.