>From 6545b936c2f458f6dbe437e6dec6acc4277d33fd Mon Sep 17 00:00:00 2001 From: Gemini Lasswell 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