Added some additional functions to the `1-valued', `compose', and progn groups.

Bugfix for marking up the definition for an empty function.
New category "potentially-1valued" for functions that are not erroneous if either 1-valued or multi-valued.

2 files changed, 160 insertions, 73 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 2b249918d7f..cf0600b7605 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,13 @@
+2004-07-17  Jonathan Yavner  <jyavner@member.fsf.org>
+
+        * emacs-lisp/testcover.el: New category "potentially-1valued" for
+        functions that are not erroneous if either 1-valued or
+        multi-valued.  Detect functions in this class.
+        (testcover-1value-functions, testcover-compose-functions,
+        testcover-progn-functions) Added some additional functions to lists.
+        (testcover-mark): Bugfix when marking up the definition for an
+        empty function.
+
 2004-07-17  Richard M. Stallman  <rms@gnu.org>
 
         * replace.el (occur-read-primary-args): Pass default to read-from-minibuffer.
diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el
index 547e2cbd32d..23e9a54b1bb 100644
--- a/lisp/emacs-lisp/testcover.el
+++ b/lisp/emacs-lisp/testcover.el
@@ -38,9 +38,9 @@
 ;;   instrumentation callbacks, then replace edebug's callbacks with ours.
 ;; * To show good coverage, we want to see two values for every form, except
 ;;   functions that always return the same value and `defconst' variables
-;;   need show only value for good coverage.  To avoid the brown splotch, the
-;;   definitions for constants and 1-valued functions must precede the
-;;   references.
+;;   need show only one value for good coverage.  To avoid the brown
+;;   splotch, the definitions for constants and 1-valued functions must
+;;   precede the references.
 ;; * Use the macro `1value' in your Lisp code to mark spots where the local
 ;;   code environment causes a function or variable to always have the same
 ;;   value, but the function or variable is not intrinsically 1-valued.
@@ -55,12 +55,14 @@
 ;;   call has the same value!  Also, equal thinks two strings are the same
 ;;   if they differ only in properties.
 ;; * Because we have only a "1value" class and no "always nil" class, we have
-;;   to treat as 1-valued any `and' whose last term is 1-valued, in case the
-;;   last term is always nil.  Example:
+;;   to treat as potentially 1-valued any `and' whose last term is 1-valued,
+;;   in case the last term is always nil.  Example:
 ;;     (and (< (point) 1000) (forward-char 10))
-;;   This form always returns nil.  Similarly, `if' and `cond' are
-;;   treated as 1-valued if all clauses are, in case those values are
-;;   always nil.
+;;   This form always returns nil.  Similarly, `or', `if', and `cond' are
+;;   treated as potentially 1-valued if all clauses are, in case those
+;;   values are always nil.  Unlike truly 1-valued functions, it is not an
+;;   error if these "potentially" 1-valued forms actually return differing
+;;   values.
 
 (require 'edebug)
 (provide 'testcover)
@@ -86,12 +88,14 @@ these.  This list is quite incomplete!"
 
 (defcustom testcover-1value-functions
   '(backward-char barf-if-buffer-read-only beginning-of-line
-    buffer-disable-undo buffer-enable-undo current-global-map deactivate-mark
-    delete-char delete-region ding error forward-char function* insert
-    insert-and-inherit kill-all-local-variables lambda mapc narrow-to-region
-    noreturn push-mark put-text-property run-hooks set-text-properties signal
-    substitute-key-definition suppress-keymap throw undo use-local-map while
-    widen yank)
+    buffer-disable-undo buffer-enable-undo current-global-map
+    deactivate-mark delete-backward-char delete-char delete-region ding
+    forward-char function* insert insert-and-inherit kill-all-local-variables
+    kill-line kill-paragraph kill-region kill-sexp lambda
+    minibuffer-complete-and-exit narrow-to-region next-line push-mark
+    put-text-property run-hooks set-match-data signal
+    substitute-key-definition suppress-keymap undo use-local-map while widen
+    yank)
   "Functions that always return the same value.  No brown splotch is shown
 for these.  This list is quite incomplete!  Notes: Nobody ever changes the
 current global map.  The macro `lambda' is self-evaluating, hence always
@@ -108,9 +112,9 @@ them as having returned nil just before calling them."
   :type 'hook)
 
 (defcustom testcover-compose-functions
-  '(+ - * / length list make-keymap make-sparse-keymap message propertize
-    replace-regexp-in-string run-with-idle-timer
-    set-buffer-modified-p)
+  '(+ - * / = append length list make-keymap make-sparse-keymap
+    mapcar message propertize replace-regexp-in-string
+    run-with-idle-timer set-buffer-modified-p)
   "Functions that are 1-valued if all their args are either constants or
 calls to one of the `testcover-1value-functions', so if that's true then no
 brown splotch is shown for these.  This list is quite incomplete!  Most
@@ -119,16 +123,16 @@ side-effect-free functions should be here."
   :type 'hook)
 
 (defcustom testcover-progn-functions
-  '(define-key fset function goto-char or overlay-put progn save-current-buffer
-    save-excursion save-match-data save-restriction save-selected-window
-    save-window-excursion set set-default setq setq-default
-    with-output-to-temp-buffer with-syntax-table with-temp-buffer
-    with-temp-file with-temp-message with-timeout)
+  '(define-key fset function goto-char mapc overlay-put progn
+    save-current-buffer save-excursion save-match-data
+    save-restriction save-selected-window save-window-excursion
+    set set-default set-marker-insertion-type setq setq-default
+    with-current-buffer with-output-to-temp-buffer with-syntax-table
+    with-temp-buffer with-temp-file with-temp-message with-timeout)
   "Functions whose return value is the same as their last argument.  No
 brown splotch is shown for these if the last argument is a constant or a
 call to one of the `testcover-1value-functions'.  This list is probably
-incomplete!  Note: `or' is here in case the last argument is a function that
-always returns nil."
+incomplete!"
   :group 'testcover
   :type 'hook)
 
@@ -140,6 +144,11 @@ call to one of the `testcover-1value-functions'."
   :group 'testcover
   :type 'hook)
 
+(defcustom testcover-potentially-1value-functions
+  '(add-hook and beep or remove-hook unless when)
+  "Functions that are potentially 1-valued.  No brown splotch if actually
+1-valued, no error if actually multi-valued.")
+
 (defface testcover-nohits-face
   '((t (:background "DeepPink2")))
   "Face for forms that had no hits during coverage test"
@@ -161,7 +170,11 @@ call to one of the `testcover-1value-functions'."
 
 (defvar testcover-module-1value-functions nil
   "Symbols declared with defun in the last file processed by
-`testcover-start', whose functions always return the same value.")
+`testcover-start', whose functions should always return the same value.")
+
+(defvar testcover-module-potentially-1value-functions nil
+  "Symbols declared with defun in the last file processed by
+`testcover-start', whose functions might always return the same value.")
 
 (defvar testcover-vector nil
   "Locally bound to coverage vector for function in progress.")
@@ -206,25 +219,32 @@ non-nil, byte-compiles each function after instrumenting."
     x))
 
 (defun testcover-reinstrument (form)
-  "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."
+  "Reinstruments FORM to use testcover instead of edebug.  This
+function modifies the list that FORM points to.  Result is nil if
+FORM should return multiple vlues, t if should always return same
+value, 'maybe if either is acceptable."
   (let ((fun (car-safe form))
-        id)
+        id val)
     (cond
-     ((not fun) ;Atom
-      (or (not (symbolp form))
-          (memq form testcover-constants)
-          (memq form testcover-module-constants)))
-     ((consp fun) ;Embedded list
+     ((not fun)                         ;Atom
+      (when (or (not (symbolp form))
+                (memq form testcover-constants)
+                (memq form testcover-module-constants))
+        t))
+     ((consp fun)                       ;Embedded list
       (testcover-reinstrument fun)
       (testcover-reinstrument-list (cdr form))
       nil)
      ((or (memq fun testcover-1value-functions)
           (memq fun testcover-module-1value-functions))
-      ;;Always return same value
+      ;;Should always return same value
       (testcover-reinstrument-list (cdr form))
       t)
+     ((or (memq fun testcover-potentially-1value-functions)
+          (memq fun testcover-module-potentially-1value-functions))
+      ;;Might always return same value
+      (testcover-reinstrument-list (cdr form))
+      'maybe)
      ((memq fun testcover-progn-functions)
       ;;1-valued if last argument is
       (testcover-reinstrument-list (cdr form)))
@@ -233,11 +253,9 @@ always return the same value."
       (testcover-reinstrument-list (cddr form))
       (testcover-reinstrument (cadr form)))
      ((memq fun testcover-compose-functions)
-      ;;1-valued if all arguments are
-      (setq id t)
-      (mapc #'(lambda (x) (setq id (or (testcover-reinstrument x) id)))
-            (cdr form))
-      id)
+      ;;1-valued if all arguments are.  Potentially 1-valued if all
+      ;;arguments are either definitely or potentially.
+      (testcover-reinstrument-compose (cdr form) 'testcover-reinstrument))
      ((eq fun 'edebug-enter)
       ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS))
       ;;  => (testcover-enter 'SYM #'(lambda nil FORMS))
@@ -252,33 +270,44 @@ always return the same value."
         (aset testcover-vector (cadr (cadr form)) 'ok-coverage))
       (setq id (nth 2 form))
       (setcdr form (nthcdr 2 form))
+      (setq val (testcover-reinstrument (nth 2 form)))
+      (if (eq val t)
+          (setcar form 'testcover-1value)
+        (setcar form 'testcover-after))
+      (when val
+        ;;1-valued or potentially 1-valued
+        (aset testcover-vector id '1value))
       (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 (cdr form) `(,(car form) ,id nil))
         (setcar form 'progn)
-        (setcar (cdr form) `(testcover-after ,id nil)))
+        (aset testcover-vector id '1value)
+        (setq val t))
        ((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 id '1value)))
+        (setq val t)
+        (aset testcover-vector id '1value)
+        (setcar form 'testcover-1value)))
+      val)
      ((eq fun 'defun)
-      (if (testcover-reinstrument-list (nthcdr 3 form))
-          (push (cadr form) testcover-module-1value-functions)))
-     ((eq fun 'defconst)
+      (setq val (testcover-reinstrument-list (nthcdr 3 form)))
+      (when (eq val t)
+        (push (cadr form) testcover-module-1value-functions))
+      (when (eq val 'maybe)
+        (push (cadr form) testcover-module-potentially-1value-functions)))
+     ((memq fun '(defconst defcustom))
       ;;Define this symbol as 1-valued
       (push (cadr form) testcover-module-constants)
       (testcover-reinstrument-list (cddr form)))
      ((memq fun '(dotimes dolist))
       ;;Always returns third value from SPEC
       (testcover-reinstrument-list (cddr form))
-      (setq fun (testcover-reinstrument-list (cadr form)))
+      (setq val (testcover-reinstrument-list (cadr form)))
       (if (nth 2 (cadr form))
-          fun
+          val
         ;;No third value, always returns nil
         t))
      ((memq fun '(let let*))
@@ -286,23 +315,23 @@ always return the same value."
       (mapc 'testcover-reinstrument-list (cadr form))
       (testcover-reinstrument-list (cddr form)))
      ((eq fun 'if)
-      ;;1-valued if both THEN and ELSE clauses are
+      ;;Potentially 1-valued if both THEN and ELSE clauses are
       (testcover-reinstrument (cadr form))
       (let ((then (testcover-reinstrument (nth 2 form)))
             (else (testcover-reinstrument-list (nthcdr 3 form))))
-        (and then else)))
-     ((memq fun '(when unless and))
-      ;;1-valued if last clause of BODY is
-      (testcover-reinstrument-list (cdr form)))
+        (and then else 'maybe)))
      ((eq fun 'cond)
-      ;;1-valued if all clauses are
-      (testcover-reinstrument-clauses (cdr form)))
+      ;;Potentially 1-valued if all clauses are
+      (when (testcover-reinstrument-compose (cdr form)
+                                            'testcover-reinstrument-list)
+        'maybe))
      ((eq fun 'condition-case)
-      ;;1-valued if BODYFORM is and all HANDLERS are
+      ;;Potentially 1-valued if BODYFORM is and all HANDLERS are
       (let ((body (testcover-reinstrument (nth 2 form)))
-            (errs (testcover-reinstrument-clauses (mapcar #'cdr
-                                                          (nthcdr 3 form)))))
-        (and body errs)))
+            (errs (testcover-reinstrument-compose
+                   (mapcar #'cdr (nthcdr 3 form))
+                   'testcover-reinstrument-list)))
+        (and body errs 'maybe)))
      ((eq fun 'quote)
       ;;Don't reinstrument what's inside!
       ;;This doesn't apply within a backquote
@@ -317,16 +346,55 @@ always return the same value."
       (let ((testcover-1value-functions
              (remq 'quote testcover-1value-functions)))
         (testcover-reinstrument (cadr form))))
-     ((memq fun '(1value noreturn))
+     ((eq fun '1value)
       ;;Hack - pretend the arg is 1-valued here
-      (if (symbolp (cadr form)) ;A pseudoconstant variable
-          t
+      (cond
+       ((symbolp (cadr form))
+        ;;A pseudoconstant variable
+        t)
+       ((and (eq (car (cadr form)) 'edebug-after)
+             (symbolp (nth 3 (cadr form))))
+        ;;Reference to pseudoconstant
+        (aset testcover-vector (nth 2 (cadr form)) '1value)
+        (setcar (cdr form) `(testcover-1value ,(nth 2 (cadr form))
+                                              ,(nth 3 (cadr form))))
+        t)
+       (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 id testcover-1value-functions)))
-          (testcover-reinstrument (cadr form)))))
+          (testcover-reinstrument (cadr form))))))
+     ((eq fun 'noreturn)
+      ;;Hack - pretend the arg has no return
+      (cond
+       ((symbolp (cadr form))
+        ;;A pseudoconstant variable
+        'maybe)
+       ((and (eq (car (cadr form)) 'edebug-after)
+             (symbolp (nth 3 (cadr form))))
+        ;;Reference to pseudoconstant
+        (aset testcover-vector (nth 2 (cadr form)) '1value)
+        (setcar (cdr form) `(progn (testcover-after ,(nth 2 (cadr form)) nil)
+                                   ,(nth 3 (cadr form))))
+        'maybe)
+       (t
+        (if (eq (car (cadr form)) 'edebug-after)
+            (setq id (car (nth 3 (cadr form))))
+          (setq id (car (cadr form))))
+        (let ((testcover-noreturn-functions
+               (cons id testcover-noreturn-functions)))
+          (testcover-reinstrument (cadr form))))))
+     ((and (eq fun 'apply)
+           (eq (car-safe (cadr form)) 'quote)
+           (symbolp (cadr (cadr form))))
+      ;;Apply of a constant symbol.  Process as 1value or noreturn
+      ;;depending on symbol.
+      (setq fun (cons (cadr (cadr form)) (cddr form))
+            val (testcover-reinstrument fun))
+      (setcdr (cdr form) (cdr fun))
+      val)
      (t ;Some other function or weird thing
       (testcover-reinstrument-list (cdr form))
       nil))))
@@ -341,13 +409,22 @@ always be nil, so we return t for 1-valued."
       (setq result (testcover-reinstrument (pop list))))
     result))
 
-(defun testcover-reinstrument-clauses (clauselist)
-  "Reinstrument each list in CLAUSELIST.
-Result is t if every clause is 1-valued."
+(defun testcover-reinstrument-compose (list fun)
+  "For a compositional function, the result is 1-valued if all
+arguments are, potentially 1-valued if all arguments are either
+definitely or potentially 1-valued, and multi-valued otherwise.
+FUN should be `testcover-reinstrument' for compositional functions,
+  `testcover-reinstrument-list' for clauses in a `cond'."
   (let ((result t))
     (mapc #'(lambda (x)
-              (setq result (and (testcover-reinstrument-list x) result)))
-          clauselist)
+              (setq x (funcall fun x))
+              (cond
+               ((eq result t)
+                (setq result x))
+               ((eq result 'maybe)
+                (when (not x)
+                  (setq result nil)))))
+          list)
     result))
 
 (defun testcover-end (buffer)
@@ -387,7 +464,7 @@ same value during coverage testing."
     (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.")))
+    (error "Value of form marked with `1value' does vary: %s" val)))
   val)
 
 
@@ -415,7 +492,7 @@ eliminated by adding more test cases."
          ov j item)
     (or (and def-mark points coverage)
         (error "Missing edebug data for function %s" def))
-    (when len
+    (when (> len 0)
       (set-buffer (marker-buffer def-mark))
       (mapc 'delete-overlay
             (overlays-in def-mark (+ def-mark (aref points (1- len)) 1)))