1 ;;;; testcover.el -- Visual code-coverage tool
3 ;; Copyright (C) 2002 Free Software Foundation, Inc.
5 ;; Author: Jonathan Yavner <jyavner@member.fsf.org>
6 ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org>
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 ;;;=========================================================================
174 (defun testcover-start (filename &optional byte-compile
)
175 "Uses edebug to instrument all macros and functions in FILENAME, then
176 changes the instrumentation from edebug to testcover--much faster, no
177 problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is
178 non-nil, byte-compiles each function after instrumenting."
180 (let ((buf (find-file filename
))
181 (load-read-function 'testcover-read
)
183 (setq edebug-form-data nil
184 testcover-module-constants nil
185 testcover-module-1value-functions nil
)
188 (dolist (x (reverse edebug-form-data
))
189 (when (fboundp (car x
))
190 (message "Compiling %s..." (car x
))
191 (byte-compile (car x
))))))
194 (defun testcover-this-defun ()
195 "Start coverage on function under point."
197 (let* ((edebug-all-defs t
)
198 (x (symbol-function (eval-defun nil))))
199 (testcover-reinstrument x
)
202 (defun testcover-read (&optional stream
)
203 "Read a form using edebug, changing edebug callbacks to testcover callbacks."
204 (let ((x (edebug-read stream
)))
205 (testcover-reinstrument x
)
208 (defun testcover-reinstrument (form)
209 "Reinstruments FORM to use testcover instead of edebug. This function
210 modifies the list that FORM points to. Result is non-nil if FORM will
211 always return the same value."
212 (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 id
(or (testcover-reinstrument x
) id
)))
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 id
(nth 2 form
))
254 (setcdr form
(nthcdr 2 form
))
256 ((memq (car-safe (nth 2 form
)) testcover-noreturn-functions
)
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 ,id nil
)))
262 ((eq (car-safe (nth 2 form
)) '1value
)
263 ;;This function is always supposed to return the same value
264 (setcar form
'testcover-1value
))
266 (setcar form
'testcover-after
)))
267 (when (testcover-reinstrument (nth 2 form
))
268 (aset testcover-vector id
'1value
)))
270 (if (testcover-reinstrument-list (nthcdr 3 form
))
271 (push (cadr form
) testcover-module-1value-functions
)))
273 ;;Define this symbol as 1-valued
274 (push (cadr form
) testcover-module-constants
)
275 (testcover-reinstrument-list (cddr form
)))
276 ((memq fun
'(dotimes dolist
))
277 ;;Always returns third value from SPEC
278 (testcover-reinstrument-list (cddr form
))
279 (setq fun
(testcover-reinstrument-list (cadr form
)))
280 (if (nth 2 (cadr form
))
282 ;;No third value, always returns nil
284 ((memq fun
'(let let
*))
285 ;;Special parsing for second argument
286 (mapc 'testcover-reinstrument-list
(cadr form
))
287 (testcover-reinstrument-list (cddr form
)))
289 ;;1-valued if both THEN and ELSE clauses are
290 (testcover-reinstrument (cadr form
))
291 (let ((then (testcover-reinstrument (nth 2 form
)))
292 (else (testcover-reinstrument-list (nthcdr 3 form
))))
294 ((memq fun
'(when unless and
))
295 ;;1-valued if last clause of BODY is
296 (testcover-reinstrument-list (cdr form
)))
298 ;;1-valued if all clauses are
299 (testcover-reinstrument-clauses (cdr form
)))
300 ((eq fun
'condition-case
)
301 ;;1-valued if BODYFORM is and all HANDLERS are
302 (let ((body (testcover-reinstrument (nth 2 form
)))
303 (errs (testcover-reinstrument-clauses (mapcar #'cdr
307 ;;Don't reinstrument what's inside!
308 ;;This doesn't apply within a backquote
311 ;;Quotes are not special within backquotes
312 (let ((testcover-1value-functions
313 (cons 'quote testcover-1value-functions
)))
314 (testcover-reinstrument (cadr form
))))
316 ;;In commas inside backquotes, quotes are special again
317 (let ((testcover-1value-functions
318 (remq 'quote testcover-1value-functions
)))
319 (testcover-reinstrument (cadr form
))))
320 ((memq fun
'(1value noreturn
))
321 ;;Hack - pretend the arg is 1-valued here
322 (if (symbolp (cadr form
)) ;A pseudoconstant variable
324 (if (eq (car (cadr form
)) 'edebug-after
)
325 (setq id
(car (nth 3 (cadr form
))))
326 (setq id
(car (cadr form
))))
327 (let ((testcover-1value-functions
328 (cons id testcover-1value-functions
)))
329 (testcover-reinstrument (cadr form
)))))
330 (t ;Some other function or weird thing
331 (testcover-reinstrument-list (cdr form
))
334 (defun testcover-reinstrument-list (list)
335 "Reinstruments each form in LIST to use testcover instead of edebug.
336 This function modifies the forms in LIST. Result is `testcover-reinstrument's
337 value for the last form in LIST. If the LIST is empty, its evaluation will
338 always be nil, so we return t for 1-valued."
341 (setq result
(testcover-reinstrument (pop list
))))
344 (defun testcover-reinstrument-clauses (clauselist)
345 "Reinstrument each list in CLAUSELIST.
346 Result is t if every clause is 1-valued."
349 (setq result
(and (testcover-reinstrument-list x
) result
)))
353 (defun testcover-end (buffer)
354 "Turn off instrumentation of all macros and functions in FILENAME."
356 (let ((buf (find-file-noselect buffer
)))
357 (eval-buffer buf t
)))
360 ;;;=========================================================================
361 ;;; Accumulate coverage data
362 ;;;=========================================================================
364 (defun testcover-enter (testcover-sym testcover-fun
)
365 "Internal function for coverage testing. Invokes TESTCOVER-FUN while
366 binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM
367 \(the name of the current function)."
368 (let ((testcover-vector (get testcover-sym
'edebug-coverage
)))
369 (funcall testcover-fun
)))
371 (defun testcover-after (idx val
)
372 "Internal function for coverage testing. Returns VAL after installing it in
373 `testcover-vector' at offset IDX."
375 ((eq (aref testcover-vector idx
) 'unknown
)
376 (aset testcover-vector idx val
))
377 ((not (equal (aref testcover-vector idx
) val
))
378 (aset testcover-vector idx
'ok-coverage
)))
381 (defun testcover-1value (idx val
)
382 "Internal function for coverage testing. Returns VAL after installing it in
383 `testcover-vector' at offset IDX. Error if FORM does not always return the
384 same value during coverage testing."
386 ((eq (aref testcover-vector idx
) '1value
)
387 (aset testcover-vector idx
(cons '1value val
)))
388 ((not (and (eq (car-safe (aref testcover-vector idx
)) '1value
)
389 (equal (cdr (aref testcover-vector idx
)) val
)))
390 (error "Value of form marked with `1value' does vary.")))
395 ;;;=========================================================================
396 ;;; Display the coverage data as color splotches on your code.
397 ;;;=========================================================================
399 (defun testcover-mark (def)
400 "Marks one DEF (a function or macro symbol) to highlight its contained forms
401 that did not get completely tested during coverage tests.
402 A marking of testcover-nohits-face (default = red) indicates that the
403 form was never evaluated. A marking of testcover-1value-face
404 \(default = tan) indicates that the form always evaluated to the same value.
405 The forms throw, error, and signal are not marked. They do not return and
406 would always get a red mark. Some forms that always return the same
407 value (e.g., setq of a constant), always get a tan mark that can't be
408 eliminated by adding more test cases."
409 (let* ((data (get def
'edebug
))
410 (def-mark (car data
))
411 (points (nth 2 data
))
412 (len (length points
))
413 (changed (buffer-modified-p))
414 (coverage (get def
'edebug-coverage
))
416 (or (and def-mark points coverage
)
417 (error "Missing edebug data for function %s" def
))
419 (set-buffer (marker-buffer def-mark
))
420 (mapc 'delete-overlay
421 (overlays-in def-mark
(+ def-mark
(aref points
(1- len
)) 1)))
424 data
(aref coverage len
))
425 (when (and (not (eq data
'ok-coverage
))
426 (not (eq (car-safe data
) '1value
))
427 (setq j
(+ def-mark
(aref points len
))))
428 (setq ov
(make-overlay (1- j
) j
))
429 (overlay-put ov
'face
430 (if (memq data
'(unknown 1value
))
431 'testcover-nohits-face
432 'testcover-1value-face
))))
433 (set-buffer-modified-p changed
))))
435 (defun testcover-mark-all (&optional buffer
)
436 "Mark all forms in BUFFER that did not get completley tested during
437 coverage tests. This function creates many overlays."
440 (switch-to-buffer buffer
))
442 (dolist (x edebug-form-data
)
443 (if (get (car x
) 'edebug
)
444 (testcover-mark (car x
)))))
446 (defun testcover-unmark-all (buffer)
447 "Remove all overlays from FILENAME."
452 (mapc 'delete-overlay
(overlays-in 1 (buffer-size))))
453 (error nil
))) ;Ignore "No such buffer" errors
455 (defun testcover-next-mark ()
456 "Moves point to next line in current buffer that has a splotch."
458 (goto-char (next-overlay-change (point)))
461 ;;; arch-tag: 72324a4a-4a2e-4142-9249-cc56d6757588
462 ;; testcover.el ends here.