Ensure that forms marked with `1value' actually always return the same value.

1 files changed, 34 insertions, 21 deletions

diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el
index 4d668a78678..547e2cbd32d 100644
--- a/lisp/emacs-lisp/testcover.el
+++ b/lisp/emacs-lisp/testcover.el
@@ -171,14 +171,13 @@ call to one of the `testcover-1value-functions'."
 ;;; Add instrumentation to your module
 ;;;=========================================================================
 
-;;;###autoload
 (defun testcover-start (filename &optional byte-compile)
   "Uses edebug to instrument all macros and functions in FILENAME, then
 changes the instrumentation from edebug to testcover--much faster, no
 problems with type-ahead or post-command-hook, etc.  If BYTE-COMPILE is
 non-nil, byte-compiles each function after instrumenting."
   (interactive "f")
-  (let ((buf             (find-file filename))
+  (let ((buf                (find-file filename))
 	(load-read-function 'testcover-read)
 	(edebug-all-defs t))
     (setq edebug-form-data                       nil
@@ -210,7 +209,8 @@ non-nil, byte-compiles each function after instrumenting."
   "Reinstruments FORM to use testcover instead of edebug.  This function
 modifies the list that FORM points to.  Result is non-nil if FORM will
 always return the same value."
-  (let ((fun (car-safe form)))
+  (let ((fun (car-safe form))
+	id)
     (cond
      ((not fun) ;Atom
       (or (not (symbolp form))
@@ -234,10 +234,10 @@ always return the same value."
       (testcover-reinstrument (cadr form)))
      ((memq fun testcover-compose-functions)
       ;;1-valued if all arguments are
-      (setq fun t)
-      (mapc #'(lambda (x) (setq fun (or (testcover-reinstrument x) fun)))
+      (setq id t)
+      (mapc #'(lambda (x) (setq id (or (testcover-reinstrument x) id)))
 	    (cdr form))
-      fun)
+      id)
      ((eq fun 'edebug-enter)
       ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS))
       ;;  => (testcover-enter 'SYM #'(lambda nil FORMS))
@@ -250,17 +250,22 @@ always return the same value."
       ;; => (testcover-after YYY FORM), mark XXX as ok-coverage
       (unless (eq (cadr form) 0)
 	(aset testcover-vector (cadr (cadr form)) 'ok-coverage))
-      (setq fun (nth 2 form))
+      (setq id (nth 2 form))
       (setcdr form (nthcdr 2 form))
-      (if (not (memq (car-safe (nth 2 form)) testcover-noreturn-functions))
-	  (setcar form 'testcover-after)
+      (cond
+       ((memq (car-safe (nth 2 form)) testcover-noreturn-functions)
 	;;This function won't return, so set the value in advance
 	;;(edebug-after (edebug-before XXX) YYY FORM)
 	;;  => (progn (edebug-after YYY nil) FORM)
 	(setcar form 'progn)
-	(setcar (cdr form) `(testcover-after ,fun nil)))
+	(setcar (cdr form) `(testcover-after ,id nil)))
+       ((eq (car-safe (nth 2 form)) '1value)
+	;;This function is always supposed to return the same value
+	(setcar form 'testcover-1value))
+       (t
+	(setcar form 'testcover-after)))
       (when (testcover-reinstrument (nth 2 form))
-	(aset testcover-vector fun '1value)))
+	(aset testcover-vector id '1value)))
      ((eq fun 'defun)
       (if (testcover-reinstrument-list (nthcdr 3 form))
 	  (push (cadr form) testcover-module-1value-functions)))
@@ -316,8 +321,11 @@ always return the same value."
       ;;Hack - pretend the arg is 1-valued here
       (if (symbolp (cadr form)) ;A pseudoconstant variable
 	  t
+	(if (eq (car (cadr form)) 'edebug-after)
+	    (setq id (car (nth 3 (cadr form))))
+	  (setq id (car (cadr form))))
 	(let ((testcover-1value-functions
-	       (cons (car (cadr form)) testcover-1value-functions)))
+	       (cons id testcover-1value-functions)))
 	  (testcover-reinstrument (cadr form)))))
      (t ;Some other function or weird thing
       (testcover-reinstrument-list (cdr form))
@@ -348,15 +356,6 @@ Result is t if every clause is 1-valued."
   (let ((buf (find-file-noselect buffer)))
     (eval-buffer buf t)))
 
-(defmacro 1value (form)
-  "For coverage testing, indicate FORM should always have the same value."
-  form)
-
-(defmacro noreturn (form)
-  "For coverage testing, indicate that FORM will never return."
-  `(prog1 ,form
-     (error "Form marked with `noreturn' did return")))
-
 
 ;;;=========================================================================
 ;;; Accumulate coverage data
@@ -379,6 +378,19 @@ binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM
     (aset testcover-vector idx 'ok-coverage)))
   val)
 
+(defun testcover-1value (idx val)
+  "Internal function for coverage testing.  Returns VAL after installing it in
+`testcover-vector' at offset IDX.  Error if FORM does not always return the
+same value during coverage testing."
+  (cond
+   ((eq (aref testcover-vector idx) '1value)
+    (aset testcover-vector idx (cons '1value val)))
+   ((not (and (eq (car-safe (aref testcover-vector idx)) '1value)
+	      (equal (cdr (aref testcover-vector idx)) val)))
+    (error "Value of form marked with `1value' does vary.")))
+  val)
+
+
 
 ;;;=========================================================================
 ;;; Display the coverage data as color splotches on your code.
@@ -411,6 +423,7 @@ eliminated by adding more test cases."
 	(setq len  (1- len)
 	      data (aref coverage len))
 	(when (and (not (eq data 'ok-coverage))
+		   (not (eq (car-safe data) '1value))
 		   (setq j (+ def-mark (aref points len))))
 	  (setq ov (make-overlay (1- j) j))
 	  (overlay-put ov 'face