;; 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.
;; 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)
(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
: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
: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)
: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"
(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.")
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)))
(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))
(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*))
(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
(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))))
(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)
(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)
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)))
projects / emacs.git / commitdiff