Commit | Line | Data |
---|---|---|
7ed9159a JY |
1 | ;;;; testcover.el -- Visual code-coverage tool |
2 | ||
5df4f04c | 3 | ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. |
7ed9159a | 4 | |
df961c06 JY |
5 | ;; Author: Jonathan Yavner <jyavner@member.fsf.org> |
6 | ;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org> | |
7ed9159a JY |
7 | ;; Keywords: lisp utility |
8 | ||
9 | ;; This file is part of GNU Emacs. | |
10 | ||
d6cba7ae | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
7ed9159a | 12 | ;; it under the terms of the GNU General Public License as published by |
d6cba7ae GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
7ed9159a JY |
15 | |
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. | |
20 | ||
21 | ;; You should have received a copy of the GNU General Public License | |
d6cba7ae | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
7ed9159a JY |
23 | |
24 | ||
25 | ;;; Commentary: | |
26 | ||
27 | ;; * Use `testcover-start' to instrument a Lisp file for coverage testing. | |
28 | ;; * Use `testcover-mark-all' to add overlay "splotches" to the Lisp file's | |
29 | ;; buffer to show where coverage is lacking. Normally, a red splotch | |
30 | ;; indicates the form was never evaluated; a brown splotch means it always | |
31 | ;; evaluted to the same value. | |
32 | ;; * Use `testcover-next-mark' (bind it to a key!) to jump to the next spot | |
33 | ;; that has a splotch. | |
34 | ||
35 | ;; * Basic algorithm: use `edebug' to mark up the function text with | |
36 | ;; instrumentation callbacks, then replace edebug's callbacks with ours. | |
37 | ;; * To show good coverage, we want to see two values for every form, except | |
38 | ;; functions that always return the same value and `defconst' variables | |
3e39672f JY |
39 | ;; need show only one value for good coverage. To avoid the brown |
40 | ;; splotch, the definitions for constants and 1-valued functions must | |
41 | ;; precede the references. | |
7ed9159a JY |
42 | ;; * Use the macro `1value' in your Lisp code to mark spots where the local |
43 | ;; code environment causes a function or variable to always have the same | |
44 | ;; value, but the function or variable is not intrinsically 1-valued. | |
45 | ;; * Use the macro `noreturn' in your Lisp code to mark function calls that | |
46 | ;; never return, because of the local code environment, even though the | |
47 | ;; function being called is capable of returning in other cases. | |
48 | ||
49 | ;; Problems: | |
50 | ;; * To detect different values, we store the form's result in a vector and | |
51 | ;; compare the next result using `equal'. We don't copy the form's | |
52 | ;; result, so if caller alters it (`setcar', etc.) we'll think the next | |
53 | ;; call has the same value! Also, equal thinks two strings are the same | |
54 | ;; if they differ only in properties. | |
55 | ;; * Because we have only a "1value" class and no "always nil" class, we have | |
3e39672f JY |
56 | ;; to treat as potentially 1-valued any `and' whose last term is 1-valued, |
57 | ;; in case the last term is always nil. Example: | |
7ed9159a | 58 | ;; (and (< (point) 1000) (forward-char 10)) |
3e39672f JY |
59 | ;; This form always returns nil. Similarly, `or', `if', and `cond' are |
60 | ;; treated as potentially 1-valued if all clauses are, in case those | |
61 | ;; values are always nil. Unlike truly 1-valued functions, it is not an | |
62 | ;; error if these "potentially" 1-valued forms actually return differing | |
63 | ;; values. | |
7ed9159a JY |
64 | |
65 | (require 'edebug) | |
66 | (provide 'testcover) | |
67 | ||
68 | ||
69 | ;;;========================================================================== | |
70 | ;;; User options | |
71 | ;;;========================================================================== | |
72 | ||
73 | (defgroup testcover nil | |
4702c10d | 74 | "Code-coverage tester." |
7ed9159a JY |
75 | :group 'lisp |
76 | :prefix "testcover-" | |
77 | :version "21.1") | |
78 | ||
79 | (defcustom testcover-constants | |
80 | '(nil t emacs-build-time emacs-version emacs-major-version | |
81 | emacs-minor-version) | |
82 | "Variables whose values never change. No brown splotch is shown for | |
83 | these. This list is quite incomplete!" | |
84 | :group 'testcover | |
85 | :type '(repeat variable)) | |
86 | ||
87 | (defcustom testcover-1value-functions | |
88 | '(backward-char barf-if-buffer-read-only beginning-of-line | |
3e39672f JY |
89 | buffer-disable-undo buffer-enable-undo current-global-map |
90 | deactivate-mark delete-backward-char delete-char delete-region ding | |
91 | forward-char function* insert insert-and-inherit kill-all-local-variables | |
92 | kill-line kill-paragraph kill-region kill-sexp lambda | |
93 | minibuffer-complete-and-exit narrow-to-region next-line push-mark | |
94 | put-text-property run-hooks set-match-data signal | |
95 | substitute-key-definition suppress-keymap undo use-local-map while widen | |
96 | yank) | |
7ed9159a JY |
97 | "Functions that always return the same value. No brown splotch is shown |
98 | for these. This list is quite incomplete! Notes: Nobody ever changes the | |
99 | current global map. The macro `lambda' is self-evaluating, hence always | |
100 | returns the same value (the function it defines may return varying values | |
101 | when called)." | |
102 | :group 'testcover | |
103 | :type 'hook) | |
104 | ||
105 | (defcustom testcover-noreturn-functions | |
106 | '(error noreturn throw signal) | |
107 | "Subset of `testcover-1value-functions' -- these never return. We mark | |
108 | them as having returned nil just before calling them." | |
109 | :group 'testcover | |
110 | :type 'hook) | |
111 | ||
112 | (defcustom testcover-compose-functions | |
3e39672f JY |
113 | '(+ - * / = append length list make-keymap make-sparse-keymap |
114 | mapcar message propertize replace-regexp-in-string | |
115 | run-with-idle-timer set-buffer-modified-p) | |
7ed9159a JY |
116 | "Functions that are 1-valued if all their args are either constants or |
117 | calls to one of the `testcover-1value-functions', so if that's true then no | |
118 | brown splotch is shown for these. This list is quite incomplete! Most | |
119 | side-effect-free functions should be here." | |
120 | :group 'testcover | |
121 | :type 'hook) | |
122 | ||
123 | (defcustom testcover-progn-functions | |
3e39672f JY |
124 | '(define-key fset function goto-char mapc overlay-put progn |
125 | save-current-buffer save-excursion save-match-data | |
126 | save-restriction save-selected-window save-window-excursion | |
127 | set set-default set-marker-insertion-type setq setq-default | |
128 | with-current-buffer with-output-to-temp-buffer with-syntax-table | |
129 | with-temp-buffer with-temp-file with-temp-message with-timeout) | |
7ed9159a JY |
130 | "Functions whose return value is the same as their last argument. No |
131 | brown splotch is shown for these if the last argument is a constant or a | |
132 | call to one of the `testcover-1value-functions'. This list is probably | |
3e39672f | 133 | incomplete!" |
7ed9159a JY |
134 | :group 'testcover |
135 | :type 'hook) | |
136 | ||
137 | (defcustom testcover-prog1-functions | |
138 | '(prog1 unwind-protect) | |
139 | "Functions whose return value is the same as their first argument. No | |
140 | brown splotch is shown for these if the first argument is a constant or a | |
141 | call to one of the `testcover-1value-functions'." | |
142 | :group 'testcover | |
143 | :type 'hook) | |
144 | ||
3e39672f JY |
145 | (defcustom testcover-potentially-1value-functions |
146 | '(add-hook and beep or remove-hook unless when) | |
147 | "Functions that are potentially 1-valued. No brown splotch if actually | |
f5307782 JB |
148 | 1-valued, no error if actually multi-valued." |
149 | :group 'testcover) | |
3e39672f | 150 | |
4719d184 | 151 | (defface testcover-nohits |
7ed9159a JY |
152 | '((t (:background "DeepPink2"))) |
153 | "Face for forms that had no hits during coverage test" | |
154 | :group 'testcover) | |
155 | ||
4719d184 | 156 | (defface testcover-1value |
7ed9159a JY |
157 | '((t (:background "Wheat2"))) |
158 | "Face for forms that always produced the same value during coverage test" | |
159 | :group 'testcover) | |
160 | ||
161 | ||
162 | ;;;========================================================================= | |
163 | ;;; Other variables | |
164 | ;;;========================================================================= | |
165 | ||
166 | (defvar testcover-module-constants nil | |
167 | "Symbols declared with defconst in the last file processed by | |
168 | `testcover-start'.") | |
169 | ||
170 | (defvar testcover-module-1value-functions nil | |
171 | "Symbols declared with defun in the last file processed by | |
3e39672f JY |
172 | `testcover-start', whose functions should always return the same value.") |
173 | ||
174 | (defvar testcover-module-potentially-1value-functions nil | |
175 | "Symbols declared with defun in the last file processed by | |
176 | `testcover-start', whose functions might always return the same value.") | |
7ed9159a JY |
177 | |
178 | (defvar testcover-vector nil | |
179 | "Locally bound to coverage vector for function in progress.") | |
180 | ||
181 | ||
182 | ;;;========================================================================= | |
183 | ;;; Add instrumentation to your module | |
184 | ;;;========================================================================= | |
185 | ||
7ed9159a JY |
186 | (defun testcover-start (filename &optional byte-compile) |
187 | "Uses edebug to instrument all macros and functions in FILENAME, then | |
188 | changes the instrumentation from edebug to testcover--much faster, no | |
189 | problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is | |
190 | non-nil, byte-compiles each function after instrumenting." | |
6e5a4966 | 191 | (interactive "fStart covering file: ") |
bbaa1429 | 192 | (let ((buf (find-file filename)) |
7ed9159a JY |
193 | (load-read-function 'testcover-read) |
194 | (edebug-all-defs t)) | |
195 | (setq edebug-form-data nil | |
196 | testcover-module-constants nil | |
197 | testcover-module-1value-functions nil) | |
198 | (eval-buffer buf)) | |
199 | (when byte-compile | |
200 | (dolist (x (reverse edebug-form-data)) | |
201 | (when (fboundp (car x)) | |
202 | (message "Compiling %s..." (car x)) | |
203 | (byte-compile (car x)))))) | |
204 | ||
205 | ;;;###autoload | |
206 | (defun testcover-this-defun () | |
207 | "Start coverage on function under point." | |
208 | (interactive) | |
209 | (let* ((edebug-all-defs t) | |
210 | (x (symbol-function (eval-defun nil)))) | |
211 | (testcover-reinstrument x) | |
212 | x)) | |
213 | ||
214 | (defun testcover-read (&optional stream) | |
215 | "Read a form using edebug, changing edebug callbacks to testcover callbacks." | |
216 | (let ((x (edebug-read stream))) | |
217 | (testcover-reinstrument x) | |
218 | x)) | |
219 | ||
220 | (defun testcover-reinstrument (form) | |
3e39672f JY |
221 | "Reinstruments FORM to use testcover instead of edebug. This |
222 | function modifies the list that FORM points to. Result is nil if | |
223 | FORM should return multiple vlues, t if should always return same | |
224 | value, 'maybe if either is acceptable." | |
bbaa1429 | 225 | (let ((fun (car-safe form)) |
3e39672f | 226 | id val) |
7ed9159a | 227 | (cond |
3e39672f JY |
228 | ((not fun) ;Atom |
229 | (when (or (not (symbolp form)) | |
230 | (memq form testcover-constants) | |
231 | (memq form testcover-module-constants)) | |
232 | t)) | |
233 | ((consp fun) ;Embedded list | |
7ed9159a JY |
234 | (testcover-reinstrument fun) |
235 | (testcover-reinstrument-list (cdr form)) | |
236 | nil) | |
237 | ((or (memq fun testcover-1value-functions) | |
238 | (memq fun testcover-module-1value-functions)) | |
3e39672f | 239 | ;;Should always return same value |
7ed9159a JY |
240 | (testcover-reinstrument-list (cdr form)) |
241 | t) | |
3e39672f JY |
242 | ((or (memq fun testcover-potentially-1value-functions) |
243 | (memq fun testcover-module-potentially-1value-functions)) | |
244 | ;;Might always return same value | |
245 | (testcover-reinstrument-list (cdr form)) | |
246 | 'maybe) | |
7ed9159a JY |
247 | ((memq fun testcover-progn-functions) |
248 | ;;1-valued if last argument is | |
249 | (testcover-reinstrument-list (cdr form))) | |
250 | ((memq fun testcover-prog1-functions) | |
251 | ;;1-valued if first argument is | |
252 | (testcover-reinstrument-list (cddr form)) | |
253 | (testcover-reinstrument (cadr form))) | |
254 | ((memq fun testcover-compose-functions) | |
3e39672f JY |
255 | ;;1-valued if all arguments are. Potentially 1-valued if all |
256 | ;;arguments are either definitely or potentially. | |
257 | (testcover-reinstrument-compose (cdr form) 'testcover-reinstrument)) | |
7ed9159a JY |
258 | ((eq fun 'edebug-enter) |
259 | ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS)) | |
260 | ;; => (testcover-enter 'SYM #'(lambda nil FORMS)) | |
261 | (setcar form 'testcover-enter) | |
262 | (setcdr (nthcdr 1 form) (nthcdr 3 form)) | |
263 | (let ((testcover-vector (get (cadr (cadr form)) 'edebug-coverage))) | |
264 | (testcover-reinstrument-list (nthcdr 2 (cadr (nth 2 form)))))) | |
265 | ((eq fun 'edebug-after) | |
266 | ;;(edebug-after (edebug-before XXX) YYY FORM) | |
267 | ;; => (testcover-after YYY FORM), mark XXX as ok-coverage | |
268 | (unless (eq (cadr form) 0) | |
269 | (aset testcover-vector (cadr (cadr form)) 'ok-coverage)) | |
bbaa1429 | 270 | (setq id (nth 2 form)) |
7ed9159a | 271 | (setcdr form (nthcdr 2 form)) |
3e39672f JY |
272 | (setq val (testcover-reinstrument (nth 2 form))) |
273 | (if (eq val t) | |
274 | (setcar form 'testcover-1value) | |
275 | (setcar form 'testcover-after)) | |
276 | (when val | |
277 | ;;1-valued or potentially 1-valued | |
278 | (aset testcover-vector id '1value)) | |
bbaa1429 JY |
279 | (cond |
280 | ((memq (car-safe (nth 2 form)) testcover-noreturn-functions) | |
7ed9159a JY |
281 | ;;This function won't return, so set the value in advance |
282 | ;;(edebug-after (edebug-before XXX) YYY FORM) | |
283 | ;; => (progn (edebug-after YYY nil) FORM) | |
3e39672f | 284 | (setcar (cdr form) `(,(car form) ,id nil)) |
7ed9159a | 285 | (setcar form 'progn) |
3e39672f JY |
286 | (aset testcover-vector id '1value) |
287 | (setq val t)) | |
bbaa1429 JY |
288 | ((eq (car-safe (nth 2 form)) '1value) |
289 | ;;This function is always supposed to return the same value | |
3e39672f JY |
290 | (setq val t) |
291 | (aset testcover-vector id '1value) | |
292 | (setcar form 'testcover-1value))) | |
293 | val) | |
7ed9159a | 294 | ((eq fun 'defun) |
3e39672f JY |
295 | (setq val (testcover-reinstrument-list (nthcdr 3 form))) |
296 | (when (eq val t) | |
297 | (push (cadr form) testcover-module-1value-functions)) | |
298 | (when (eq val 'maybe) | |
299 | (push (cadr form) testcover-module-potentially-1value-functions))) | |
300 | ((memq fun '(defconst defcustom)) | |
7ed9159a JY |
301 | ;;Define this symbol as 1-valued |
302 | (push (cadr form) testcover-module-constants) | |
303 | (testcover-reinstrument-list (cddr form))) | |
304 | ((memq fun '(dotimes dolist)) | |
305 | ;;Always returns third value from SPEC | |
306 | (testcover-reinstrument-list (cddr form)) | |
3e39672f | 307 | (setq val (testcover-reinstrument-list (cadr form))) |
7ed9159a | 308 | (if (nth 2 (cadr form)) |
3e39672f | 309 | val |
7ed9159a JY |
310 | ;;No third value, always returns nil |
311 | t)) | |
312 | ((memq fun '(let let*)) | |
313 | ;;Special parsing for second argument | |
314 | (mapc 'testcover-reinstrument-list (cadr form)) | |
315 | (testcover-reinstrument-list (cddr form))) | |
316 | ((eq fun 'if) | |
3e39672f | 317 | ;;Potentially 1-valued if both THEN and ELSE clauses are |
7ed9159a JY |
318 | (testcover-reinstrument (cadr form)) |
319 | (let ((then (testcover-reinstrument (nth 2 form))) | |
320 | (else (testcover-reinstrument-list (nthcdr 3 form)))) | |
3e39672f | 321 | (and then else 'maybe))) |
7ed9159a | 322 | ((eq fun 'cond) |
3e39672f JY |
323 | ;;Potentially 1-valued if all clauses are |
324 | (when (testcover-reinstrument-compose (cdr form) | |
325 | 'testcover-reinstrument-list) | |
326 | 'maybe)) | |
7ed9159a | 327 | ((eq fun 'condition-case) |
3e39672f | 328 | ;;Potentially 1-valued if BODYFORM is and all HANDLERS are |
7ed9159a | 329 | (let ((body (testcover-reinstrument (nth 2 form))) |
3e39672f JY |
330 | (errs (testcover-reinstrument-compose |
331 | (mapcar #'cdr (nthcdr 3 form)) | |
332 | 'testcover-reinstrument-list))) | |
333 | (and body errs 'maybe))) | |
7ed9159a JY |
334 | ((eq fun 'quote) |
335 | ;;Don't reinstrument what's inside! | |
336 | ;;This doesn't apply within a backquote | |
337 | t) | |
338 | ((eq fun '\`) | |
339 | ;;Quotes are not special within backquotes | |
340 | (let ((testcover-1value-functions | |
341 | (cons 'quote testcover-1value-functions))) | |
342 | (testcover-reinstrument (cadr form)))) | |
343 | ((eq fun '\,) | |
344 | ;;In commas inside backquotes, quotes are special again | |
345 | (let ((testcover-1value-functions | |
346 | (remq 'quote testcover-1value-functions))) | |
347 | (testcover-reinstrument (cadr form)))) | |
3e39672f | 348 | ((eq fun '1value) |
7ed9159a | 349 | ;;Hack - pretend the arg is 1-valued here |
3e39672f JY |
350 | (cond |
351 | ((symbolp (cadr form)) | |
352 | ;;A pseudoconstant variable | |
353 | t) | |
354 | ((and (eq (car (cadr form)) 'edebug-after) | |
355 | (symbolp (nth 3 (cadr form)))) | |
356 | ;;Reference to pseudoconstant | |
357 | (aset testcover-vector (nth 2 (cadr form)) '1value) | |
358 | (setcar (cdr form) `(testcover-1value ,(nth 2 (cadr form)) | |
359 | ,(nth 3 (cadr form)))) | |
360 | t) | |
361 | (t | |
bbaa1429 JY |
362 | (if (eq (car (cadr form)) 'edebug-after) |
363 | (setq id (car (nth 3 (cadr form)))) | |
364 | (setq id (car (cadr form)))) | |
7ed9159a | 365 | (let ((testcover-1value-functions |
bbaa1429 | 366 | (cons id testcover-1value-functions))) |
3e39672f JY |
367 | (testcover-reinstrument (cadr form)))))) |
368 | ((eq fun 'noreturn) | |
369 | ;;Hack - pretend the arg has no return | |
370 | (cond | |
371 | ((symbolp (cadr form)) | |
372 | ;;A pseudoconstant variable | |
373 | 'maybe) | |
374 | ((and (eq (car (cadr form)) 'edebug-after) | |
375 | (symbolp (nth 3 (cadr form)))) | |
376 | ;;Reference to pseudoconstant | |
377 | (aset testcover-vector (nth 2 (cadr form)) '1value) | |
378 | (setcar (cdr form) `(progn (testcover-after ,(nth 2 (cadr form)) nil) | |
379 | ,(nth 3 (cadr form)))) | |
380 | 'maybe) | |
381 | (t | |
382 | (if (eq (car (cadr form)) 'edebug-after) | |
383 | (setq id (car (nth 3 (cadr form)))) | |
384 | (setq id (car (cadr form)))) | |
385 | (let ((testcover-noreturn-functions | |
386 | (cons id testcover-noreturn-functions))) | |
387 | (testcover-reinstrument (cadr form)))))) | |
388 | ((and (eq fun 'apply) | |
389 | (eq (car-safe (cadr form)) 'quote) | |
390 | (symbolp (cadr (cadr form)))) | |
391 | ;;Apply of a constant symbol. Process as 1value or noreturn | |
392 | ;;depending on symbol. | |
393 | (setq fun (cons (cadr (cadr form)) (cddr form)) | |
394 | val (testcover-reinstrument fun)) | |
395 | (setcdr (cdr form) (cdr fun)) | |
396 | val) | |
7ed9159a JY |
397 | (t ;Some other function or weird thing |
398 | (testcover-reinstrument-list (cdr form)) | |
399 | nil)))) | |
400 | ||
401 | (defun testcover-reinstrument-list (list) | |
402 | "Reinstruments each form in LIST to use testcover instead of edebug. | |
403 | This function modifies the forms in LIST. Result is `testcover-reinstrument's | |
404 | value for the last form in LIST. If the LIST is empty, its evaluation will | |
405 | always be nil, so we return t for 1-valued." | |
406 | (let ((result t)) | |
407 | (while (consp list) | |
408 | (setq result (testcover-reinstrument (pop list)))) | |
409 | result)) | |
410 | ||
3e39672f JY |
411 | (defun testcover-reinstrument-compose (list fun) |
412 | "For a compositional function, the result is 1-valued if all | |
413 | arguments are, potentially 1-valued if all arguments are either | |
414 | definitely or potentially 1-valued, and multi-valued otherwise. | |
415 | FUN should be `testcover-reinstrument' for compositional functions, | |
416 | `testcover-reinstrument-list' for clauses in a `cond'." | |
7ed9159a JY |
417 | (let ((result t)) |
418 | (mapc #'(lambda (x) | |
3e39672f JY |
419 | (setq x (funcall fun x)) |
420 | (cond | |
421 | ((eq result t) | |
422 | (setq result x)) | |
423 | ((eq result 'maybe) | |
424 | (when (not x) | |
425 | (setq result nil))))) | |
426 | list) | |
7ed9159a JY |
427 | result)) |
428 | ||
6e5a4966 | 429 | (defun testcover-end (filename) |
7ed9159a | 430 | "Turn off instrumentation of all macros and functions in FILENAME." |
6e5a4966 EZ |
431 | (interactive "fStop covering file: ") |
432 | (let ((buf (find-file-noselect filename))) | |
7ed9159a JY |
433 | (eval-buffer buf t))) |
434 | ||
7ed9159a JY |
435 | |
436 | ;;;========================================================================= | |
437 | ;;; Accumulate coverage data | |
438 | ;;;========================================================================= | |
439 | ||
440 | (defun testcover-enter (testcover-sym testcover-fun) | |
441 | "Internal function for coverage testing. Invokes TESTCOVER-FUN while | |
442 | binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM | |
443 | \(the name of the current function)." | |
444 | (let ((testcover-vector (get testcover-sym 'edebug-coverage))) | |
445 | (funcall testcover-fun))) | |
446 | ||
447 | (defun testcover-after (idx val) | |
448 | "Internal function for coverage testing. Returns VAL after installing it in | |
449 | `testcover-vector' at offset IDX." | |
450 | (cond | |
451 | ((eq (aref testcover-vector idx) 'unknown) | |
452 | (aset testcover-vector idx val)) | |
453 | ((not (equal (aref testcover-vector idx) val)) | |
454 | (aset testcover-vector idx 'ok-coverage))) | |
455 | val) | |
456 | ||
bbaa1429 JY |
457 | (defun testcover-1value (idx val) |
458 | "Internal function for coverage testing. Returns VAL after installing it in | |
459 | `testcover-vector' at offset IDX. Error if FORM does not always return the | |
460 | same value during coverage testing." | |
461 | (cond | |
462 | ((eq (aref testcover-vector idx) '1value) | |
463 | (aset testcover-vector idx (cons '1value val))) | |
464 | ((not (and (eq (car-safe (aref testcover-vector idx)) '1value) | |
465 | (equal (cdr (aref testcover-vector idx)) val))) | |
3e39672f | 466 | (error "Value of form marked with `1value' does vary: %s" val))) |
bbaa1429 JY |
467 | val) |
468 | ||
469 | ||
7ed9159a JY |
470 | |
471 | ;;;========================================================================= | |
472 | ;;; Display the coverage data as color splotches on your code. | |
473 | ;;;========================================================================= | |
474 | ||
475 | (defun testcover-mark (def) | |
476 | "Marks one DEF (a function or macro symbol) to highlight its contained forms | |
477 | that did not get completely tested during coverage tests. | |
4719d184 MB |
478 | A marking with the face `testcover-nohits' (default = red) indicates that the |
479 | form was never evaluated. A marking using the `testcover-1value' face | |
7ed9159a JY |
480 | \(default = tan) indicates that the form always evaluated to the same value. |
481 | The forms throw, error, and signal are not marked. They do not return and | |
482 | would always get a red mark. Some forms that always return the same | |
483 | value (e.g., setq of a constant), always get a tan mark that can't be | |
484 | eliminated by adding more test cases." | |
485 | (let* ((data (get def 'edebug)) | |
486 | (def-mark (car data)) | |
487 | (points (nth 2 data)) | |
488 | (len (length points)) | |
489 | (changed (buffer-modified-p)) | |
490 | (coverage (get def 'edebug-coverage)) | |
491 | ov j item) | |
492 | (or (and def-mark points coverage) | |
493 | (error "Missing edebug data for function %s" def)) | |
3e39672f | 494 | (when (> len 0) |
7119cefe JY |
495 | (set-buffer (marker-buffer def-mark)) |
496 | (mapc 'delete-overlay | |
497 | (overlays-in def-mark (+ def-mark (aref points (1- len)) 1))) | |
498 | (while (> len 0) | |
499 | (setq len (1- len) | |
500 | data (aref coverage len)) | |
501 | (when (and (not (eq data 'ok-coverage)) | |
bbaa1429 | 502 | (not (eq (car-safe data) '1value)) |
7119cefe | 503 | (setq j (+ def-mark (aref points len)))) |
7ed9159a JY |
504 | (setq ov (make-overlay (1- j) j)) |
505 | (overlay-put ov 'face | |
506 | (if (memq data '(unknown 1value)) | |
4719d184 MB |
507 | 'testcover-nohits |
508 | 'testcover-1value)))) | |
7119cefe | 509 | (set-buffer-modified-p changed)))) |
7ed9159a JY |
510 | |
511 | (defun testcover-mark-all (&optional buffer) | |
512 | "Mark all forms in BUFFER that did not get completley tested during | |
7119cefe | 513 | coverage tests. This function creates many overlays." |
6e5a4966 | 514 | (interactive "bMark forms in buffer: ") |
7ed9159a JY |
515 | (if buffer |
516 | (switch-to-buffer buffer)) | |
517 | (goto-char 1) | |
518 | (dolist (x edebug-form-data) | |
7119cefe | 519 | (if (get (car x) 'edebug) |
7ed9159a JY |
520 | (testcover-mark (car x))))) |
521 | ||
522 | (defun testcover-unmark-all (buffer) | |
523 | "Remove all overlays from FILENAME." | |
6e5a4966 | 524 | (interactive "bUnmark forms in buffer: ") |
7ed9159a JY |
525 | (condition-case nil |
526 | (progn | |
527 | (set-buffer buffer) | |
528 | (mapc 'delete-overlay (overlays-in 1 (buffer-size)))) | |
529 | (error nil))) ;Ignore "No such buffer" errors | |
530 | ||
531 | (defun testcover-next-mark () | |
532 | "Moves point to next line in current buffer that has a splotch." | |
533 | (interactive) | |
534 | (goto-char (next-overlay-change (point))) | |
535 | (end-of-line)) | |
536 | ||
cbee283d | 537 | ;; arch-tag: 72324a4a-4a2e-4142-9249-cc56d6757588 |
7ed9159a | 538 | ;; testcover.el ends here. |