Sync to HEAD

[bpt/emacs.git] / lisp / emacs-lisp / testcover.el

diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el
index d422a42..547e2cb 100644 (file)
--- 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))
@@ -334,8 +342,8 @@ always be nil, so we return t for 1-valued."
     result))
 
 (defun testcover-reinstrument-clauses (clauselist)
-  "Reinstruments each list in CLAUSELIST.  Result is t if every
-clause is 1-valued."
+  "Reinstrument each list in CLAUSELIST.
+Result is t if every clause is 1-valued."
   (let ((result t))
     (mapc #'(lambda (x)
              (setq result (and (testcover-reinstrument-list x) result)))
@@ -348,15 +356,6 @@ clause is 1-valued."
   (let ((buf (find-file-noselect buffer)))
     (eval-buffer buf t)))
 
-(defmacro 1value (form)
-  "For code-coverage testing, indicate that FORM is expected to always have
-the same value."
-  form)
-
-(defmacro noreturn (form)
-  "For code-coverage testing, indicate that FORM will always signal an error."
-  form)
-
 
 ;;;=========================================================================
 ;;; 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
@@ -445,4 +458,5 @@ coverage tests.  This function creates many overlays."
   (goto-char (next-overlay-change (point)))
   (end-of-line))
 
+;;; arch-tag: 72324a4a-4a2e-4142-9249-cc56d6757588
 ;; testcover.el ends here.