Mercurial > emacs

--- a/lisp/emacs-lisp/testcover.el	Sat Jul 17 15:00:22 2004 +0000
+++ b/lisp/emacs-lisp/testcover.el	Sat Jul 17 17:01:28 2004 +0000
@@ -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 @@

 (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 @@
   :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 @@
   :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 @@
   :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 @@

 (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 @@
     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 @@
       (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 @@
 	(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 @@
       (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 @@
       (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 @@
       (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 @@
     (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 @@
 	 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)))