1 ;;;; testcover.el -- Visual code-coverage tool
3 ;; Copyright (C) 2002 Free Software Foundation, Inc.
5 ;; Author: Jonathan Yavner <jyavner@engineer.com>
6 ;; Maintainer: Jonathan Yavner <jyavner@engineer.com>
7 ;; Keywords: lisp utility
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
29 ;; * Use `testcover-start' to instrument a Lisp file for coverage testing.
30 ;; * Use `testcover-mark-all' to add overlay "splotches" to the Lisp file's
31 ;; buffer to show where coverage is lacking. Normally, a red splotch
32 ;; indicates the form was never evaluated; a brown splotch means it always
33 ;; evaluted to the same value.
34 ;; * Use `testcover-next-mark' (bind it to a key!) to jump to the next spot
35 ;; that has a splotch.
37 ;; * Basic algorithm: use `edebug' to mark up the function text with
38 ;; instrumentation callbacks, then replace edebug's callbacks with ours.
39 ;; * To show good coverage, we want to see two values for every form, except
40 ;; functions that always return the same value and `defconst' variables
41 ;; need show only value for good coverage. To avoid the brown splotch, the
42 ;; definitions for constants and 1-valued functions must precede the
44 ;; * Use the macro `1value' in your Lisp code to mark spots where the local
45 ;; code environment causes a function or variable to always have the same
46 ;; value, but the function or variable is not intrinsically 1-valued.
47 ;; * Use the macro `noreturn' in your Lisp code to mark function calls that
48 ;; never return, because of the local code environment, even though the
49 ;; function being called is capable of returning in other cases.
52 ;; * To detect different values, we store the form's result in a vector and
53 ;; compare the next result using `equal'. We don't copy the form's
54 ;; result, so if caller alters it (`setcar', etc.) we'll think the next
55 ;; call has the same value! Also, equal thinks two strings are the same
56 ;; if they differ only in properties.
57 ;; * Because we have only a "1value" class and no "always nil" class, we have
58 ;; to treat as 1-valued any `and' whose last term is 1-valued, in case the
59 ;; last term is always nil. Example:
60 ;; (and (< (point) 1000) (forward-char 10))
61 ;; This form always returns nil. Similarly, `if' and `cond' are
62 ;; treated as 1-valued if all clauses are, in case those values are
69 ;;;==========================================================================
71 ;;;==========================================================================
73 (defgroup testcover nil
74 "Code-coverage tester"
79 (defcustom testcover-constants
80 '(nil t emacs-build-time emacs-version emacs-major-version
82 "Variables whose values never change. No brown splotch is shown for
83 these. This list is quite incomplete!"
85 :type
'(repeat variable
))
87 (defcustom testcover-1value-functions
88 '(backward-char barf-if-buffer-read-only beginning-of-line
89 buffer-disable-undo buffer-enable-undo current-global-map deactivate-mark
90 delete-char delete-region ding error forward-char function
* insert
91 insert-and-inherit kill-all-local-variables lambda mapc narrow-to-region
92 noreturn push-mark put-text-property run-hooks set-text-properties signal
93 substitute-key-definition suppress-keymap throw undo use-local-map while
95 "Functions that always return the same value. No brown splotch is shown
96 for these. This list is quite incomplete! Notes: Nobody ever changes the
97 current global map. The macro `lambda' is self-evaluating, hence always
98 returns the same value (the function it defines may return varying values
103 (defcustom testcover-noreturn-functions
104 '(error noreturn throw signal
)
105 "Subset of `testcover-1value-functions' -- these never return. We mark
106 them as having returned nil just before calling them."
110 (defcustom testcover-compose-functions
111 '(+ -
* / length list make-keymap make-sparse-keymap message propertize
112 replace-regexp-in-string run-with-idle-timer
113 set-buffer-modified-p
)
114 "Functions that are 1-valued if all their args are either constants or
115 calls to one of the `testcover-1value-functions', so if that's true then no
116 brown splotch is shown for these. This list is quite incomplete! Most
117 side-effect-free functions should be here."
121 (defcustom testcover-progn-functions
122 '(define-key fset function goto-char or overlay-put progn save-current-buffer
123 save-excursion save-match-data save-restriction save-selected-window
124 save-window-excursion set set-default setq setq-default
125 with-output-to-temp-buffer with-syntax-table with-temp-buffer
126 with-temp-file with-temp-message with-timeout
)
127 "Functions whose return value is the same as their last argument. No
128 brown splotch is shown for these if the last argument is a constant or a
129 call to one of the `testcover-1value-functions'. This list is probably
130 incomplete! Note: `or' is here in case the last argument is a function that
135 (defcustom testcover-prog1-functions
136 '(prog1 unwind-protect
)
137 "Functions whose return value is the same as their first argument. No
138 brown splotch is shown for these if the first argument is a constant or a
139 call to one of the `testcover-1value-functions'."
143 (defface testcover-nohits-face
144 '((t (:background
"DeepPink2")))
145 "Face for forms that had no hits during coverage test"
148 (defface testcover-1value-face
149 '((t (:background
"Wheat2")))
150 "Face for forms that always produced the same value during coverage test"
154 ;;;=========================================================================
156 ;;;=========================================================================
158 (defvar testcover-module-constants nil
159 "Symbols declared with defconst in the last file processed by
162 (defvar testcover-module-1value-functions nil
163 "Symbols declared with defun in the last file processed by
164 `testcover-start', whose functions always return the same value.")
166 (defvar testcover-vector nil
167 "Locally bound to coverage vector for function in progress.")
170 ;;;=========================================================================
171 ;;; Add instrumentation to your module
172 ;;;=========================================================================
175 (defun testcover-start (filename &optional byte-compile
)
176 "Uses edebug to instrument all macros and functions in FILENAME, then
177 changes the instrumentation from edebug to testcover--much faster, no
178 problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is
179 non-nil, byte-compiles each function after instrumenting."
181 (let ((buf (find-file filename
))
182 (load-read-function 'testcover-read
)
184 (setq edebug-form-data nil
185 testcover-module-constants nil
186 testcover-module-1value-functions nil
)
189 (dolist (x (reverse edebug-form-data
))
190 (when (fboundp (car x
))
191 (message "Compiling %s..." (car x
))
192 (byte-compile (car x
))))))
195 (defun testcover-this-defun ()
196 "Start coverage on function under point."
198 (let* ((edebug-all-defs t
)
199 (x (symbol-function (eval-defun nil))))
200 (testcover-reinstrument x
)
203 (defun testcover-read (&optional stream
)
204 "Read a form using edebug, changing edebug callbacks to testcover callbacks."
205 (let ((x (edebug-read stream
)))
206 (testcover-reinstrument x
)
209 (defun testcover-reinstrument (form)
210 "Reinstruments FORM to use testcover instead of edebug. This function
211 modifies the list that FORM points to. Result is non-nil if FORM will
212 always return the same value."
213 (let ((fun (car-safe form
)))
216 (or (not (symbolp form
))
217 (memq form testcover-constants
)
218 (memq form testcover-module-constants
)))
219 ((consp fun
) ;Embedded list
220 (testcover-reinstrument fun
)
221 (testcover-reinstrument-list (cdr form
))
223 ((or (memq fun testcover-1value-functions
)
224 (memq fun testcover-module-1value-functions
))
225 ;;Always return same value
226 (testcover-reinstrument-list (cdr form
))
228 ((memq fun testcover-progn-functions
)
229 ;;1-valued if last argument is
230 (testcover-reinstrument-list (cdr form
)))
231 ((memq fun testcover-prog1-functions
)
232 ;;1-valued if first argument is
233 (testcover-reinstrument-list (cddr form
))
234 (testcover-reinstrument (cadr form
)))
235 ((memq fun testcover-compose-functions
)
236 ;;1-valued if all arguments are
238 (mapc #'(lambda (x) (setq fun
(or (testcover-reinstrument x
) fun
)))
241 ((eq fun
'edebug-enter
)
242 ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS))
243 ;; => (testcover-enter 'SYM #'(lambda nil FORMS))
244 (setcar form
'testcover-enter
)
245 (setcdr (nthcdr 1 form
) (nthcdr 3 form
))
246 (let ((testcover-vector (get (cadr (cadr form
)) 'edebug-coverage
)))
247 (testcover-reinstrument-list (nthcdr 2 (cadr (nth 2 form
))))))
248 ((eq fun
'edebug-after
)
249 ;;(edebug-after (edebug-before XXX) YYY FORM)
250 ;; => (testcover-after YYY FORM), mark XXX as ok-coverage
251 (unless (eq (cadr form
) 0)
252 (aset testcover-vector
(cadr (cadr form
)) 'ok-coverage
))
253 (setq fun
(nth 2 form
))
254 (setcdr form
(nthcdr 2 form
))
255 (if (not (memq (car-safe (nth 2 form
)) testcover-noreturn-functions
))
256 (setcar form
'testcover-after
)
257 ;;This function won't return, so set the value in advance
258 ;;(edebug-after (edebug-before XXX) YYY FORM)
259 ;; => (progn (edebug-after YYY nil) FORM)
261 (setcar (cdr form
) `(testcover-after ,fun nil
)))
262 (when (testcover-reinstrument (nth 2 form
))
263 (aset testcover-vector fun
'1value
)))
265 (if (testcover-reinstrument-list (nthcdr 3 form
))
266 (push (cadr form
) testcover-module-1value-functions
)))
268 ;;Define this symbol as 1-valued
269 (push (cadr form
) testcover-module-constants
)
270 (testcover-reinstrument-list (cddr form
)))
271 ((memq fun
'(dotimes dolist
))
272 ;;Always returns third value from SPEC
273 (testcover-reinstrument-list (cddr form
))
274 (setq fun
(testcover-reinstrument-list (cadr form
)))
275 (if (nth 2 (cadr form
))
277 ;;No third value, always returns nil
279 ((memq fun
'(let let
*))
280 ;;Special parsing for second argument
281 (mapc 'testcover-reinstrument-list
(cadr form
))
282 (testcover-reinstrument-list (cddr form
)))
284 ;;1-valued if both THEN and ELSE clauses are
285 (testcover-reinstrument (cadr form
))
286 (let ((then (testcover-reinstrument (nth 2 form
)))
287 (else (testcover-reinstrument-list (nthcdr 3 form
))))
289 ((memq fun
'(when unless and
))
290 ;;1-valued if last clause of BODY is
291 (testcover-reinstrument-list (cdr form
)))
293 ;;1-valued if all clauses are
294 (testcover-reinstrument-clauses (cdr form
)))
295 ((eq fun
'condition-case
)
296 ;;1-valued if BODYFORM is and all HANDLERS are
297 (let ((body (testcover-reinstrument (nth 2 form
)))
298 (errs (testcover-reinstrument-clauses (mapcar #'cdr
302 ;;Don't reinstrument what's inside!
303 ;;This doesn't apply within a backquote
306 ;;Quotes are not special within backquotes
307 (let ((testcover-1value-functions
308 (cons 'quote testcover-1value-functions
)))
309 (testcover-reinstrument (cadr form
))))
311 ;;In commas inside backquotes, quotes are special again
312 (let ((testcover-1value-functions
313 (remq 'quote testcover-1value-functions
)))
314 (testcover-reinstrument (cadr form
))))
315 ((memq fun
'(1value noreturn
))
316 ;;Hack - pretend the arg is 1-valued here
317 (if (symbolp (cadr form
)) ;A pseudoconstant variable
319 (let ((testcover-1value-functions
320 (cons (car (cadr form
)) testcover-1value-functions
)))
321 (testcover-reinstrument (cadr form
)))))
322 (t ;Some other function or weird thing
323 (testcover-reinstrument-list (cdr form
))
326 (defun testcover-reinstrument-list (list)
327 "Reinstruments each form in LIST to use testcover instead of edebug.
328 This function modifies the forms in LIST. Result is `testcover-reinstrument's
329 value for the last form in LIST. If the LIST is empty, its evaluation will
330 always be nil, so we return t for 1-valued."
333 (setq result
(testcover-reinstrument (pop list
))))
336 (defun testcover-reinstrument-clauses (clauselist)
337 "Reinstruments each list in CLAUSELIST. Result is t if every
341 (setq result
(and (testcover-reinstrument-list x
) result
)))
345 (defun testcover-end (buffer)
346 "Turn off instrumentation of all macros and functions in FILENAME."
348 (let ((buf (find-file-noselect buffer
)))
349 (eval-buffer buf t
)))
351 (defmacro 1value
(form)
352 "For code-coverage testing, indicate that FORM is expected to always have
356 (defmacro noreturn
(form)
357 "For code-coverage testing, indicate that FORM will always signal an error."
361 ;;;=========================================================================
362 ;;; Accumulate coverage data
363 ;;;=========================================================================
365 (defun testcover-enter (testcover-sym testcover-fun
)
366 "Internal function for coverage testing. Invokes TESTCOVER-FUN while
367 binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM
368 \(the name of the current function)."
369 (let ((testcover-vector (get testcover-sym
'edebug-coverage
)))
370 (funcall testcover-fun
)))
372 (defun testcover-after (idx val
)
373 "Internal function for coverage testing. Returns VAL after installing it in
374 `testcover-vector' at offset IDX."
376 ((eq (aref testcover-vector idx
) 'unknown
)
377 (aset testcover-vector idx val
))
378 ((not (equal (aref testcover-vector idx
) val
))
379 (aset testcover-vector idx
'ok-coverage
)))
383 ;;;=========================================================================
384 ;;; Display the coverage data as color splotches on your code.
385 ;;;=========================================================================
387 (defun testcover-mark (def)
388 "Marks one DEF (a function or macro symbol) to highlight its contained forms
389 that did not get completely tested during coverage tests.
390 A marking of testcover-nohits-face (default = red) indicates that the
391 form was never evaluated. A marking of testcover-1value-face
392 \(default = tan) indicates that the form always evaluated to the same value.
393 The forms throw, error, and signal are not marked. They do not return and
394 would always get a red mark. Some forms that always return the same
395 value (e.g., setq of a constant), always get a tan mark that can't be
396 eliminated by adding more test cases."
397 (let* ((data (get def
'edebug
))
398 (def-mark (car data
))
399 (points (nth 2 data
))
400 (len (length points
))
401 (changed (buffer-modified-p))
402 (coverage (get def
'edebug-coverage
))
404 (or (and def-mark points coverage
)
405 (error "Missing edebug data for function %s" def
))
407 (set-buffer (marker-buffer def-mark
))
408 (mapc 'delete-overlay
409 (overlays-in def-mark
(+ def-mark
(aref points
(1- len
)) 1)))
412 data
(aref coverage len
))
413 (when (and (not (eq data
'ok-coverage
))
414 (setq j
(+ def-mark
(aref points len
))))
415 (setq ov
(make-overlay (1- j
) j
))
416 (overlay-put ov
'face
417 (if (memq data
'(unknown 1value
))
418 'testcover-nohits-face
419 'testcover-1value-face
))))
420 (set-buffer-modified-p changed
))))
422 (defun testcover-mark-all (&optional buffer
)
423 "Mark all forms in BUFFER that did not get completley tested during
424 coverage tests. This function creates many overlays."
427 (switch-to-buffer buffer
))
429 (dolist (x edebug-form-data
)
430 (if (get (car x
) 'edebug
)
431 (testcover-mark (car x
)))))
433 (defun testcover-unmark-all (buffer)
434 "Remove all overlays from FILENAME."
439 (mapc 'delete-overlay
(overlays-in 1 (buffer-size))))
440 (error nil
))) ;Ignore "No such buffer" errors
442 (defun testcover-next-mark ()
443 "Moves point to next line in current buffer that has a splotch."
445 (goto-char (next-overlay-change (point)))
448 ;; testcover.el ends here.