Commit | Line | Data |
---|---|---|
7ed9159a JY |
1 | ;;;; testcover.el -- Visual code-coverage tool |
2 | ||
ba318903 | 3 | ;; Copyright (C) 2002-2014 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 | |
5eba16a3 | 31 | ;; evaluated to the same value. |
7ed9159a JY |
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 | |
a931698a | 103 | :type '(repeat symbol)) |
7ed9159a JY |
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 | |
a931698a | 110 | :type '(repeat symbol)) |
7ed9159a JY |
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 | |
99fb2756 | 121 | :type '(repeat symbol)) |
7ed9159a JY |
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 | 134 | :group 'testcover |
a931698a | 135 | :type '(repeat symbol)) |
7ed9159a JY |
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 | |
a931698a | 143 | :type '(repeat symbol)) |
7ed9159a | 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 | 148 | 1-valued, no error if actually multi-valued." |
9c5a5c77 GM |
149 | :group 'testcover |
150 | :type '(repeat symbol)) | |
3e39672f | 151 | |
4719d184 | 152 | (defface testcover-nohits |
7ed9159a JY |
153 | '((t (:background "DeepPink2"))) |
154 | "Face for forms that had no hits during coverage test" | |
155 | :group 'testcover) | |
156 | ||
4719d184 | 157 | (defface testcover-1value |
7ed9159a JY |
158 | '((t (:background "Wheat2"))) |
159 | "Face for forms that always produced the same value during coverage test" | |
160 | :group 'testcover) | |
161 | ||
162 | ||
163 | ;;;========================================================================= | |
164 | ;;; Other variables | |
165 | ;;;========================================================================= | |
166 | ||
167 | (defvar testcover-module-constants nil | |
168 | "Symbols declared with defconst in the last file processed by | |
169 | `testcover-start'.") | |
170 | ||
171 | (defvar testcover-module-1value-functions nil | |
172 | "Symbols declared with defun in the last file processed by | |
3e39672f JY |
173 | `testcover-start', whose functions should always return the same value.") |
174 | ||
175 | (defvar testcover-module-potentially-1value-functions nil | |
176 | "Symbols declared with defun in the last file processed by | |
177 | `testcover-start', whose functions might always return the same value.") | |
7ed9159a JY |
178 | |
179 | (defvar testcover-vector nil | |
180 | "Locally bound to coverage vector for function in progress.") | |
181 | ||
182 | ||
183 | ;;;========================================================================= | |
184 | ;;; Add instrumentation to your module | |
185 | ;;;========================================================================= | |
186 | ||
7ed9159a JY |
187 | (defun testcover-start (filename &optional byte-compile) |
188 | "Uses edebug to instrument all macros and functions in FILENAME, then | |
189 | changes the instrumentation from edebug to testcover--much faster, no | |
190 | problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is | |
191 | non-nil, byte-compiles each function after instrumenting." | |
6e5a4966 | 192 | (interactive "fStart covering file: ") |
bbaa1429 | 193 | (let ((buf (find-file filename)) |
7ed9159a JY |
194 | (load-read-function 'testcover-read) |
195 | (edebug-all-defs t)) | |
196 | (setq edebug-form-data nil | |
197 | testcover-module-constants nil | |
198 | testcover-module-1value-functions nil) | |
199 | (eval-buffer buf)) | |
200 | (when byte-compile | |
201 | (dolist (x (reverse edebug-form-data)) | |
202 | (when (fboundp (car x)) | |
203 | (message "Compiling %s..." (car x)) | |
204 | (byte-compile (car x)))))) | |
205 | ||
206 | ;;;###autoload | |
207 | (defun testcover-this-defun () | |
208 | "Start coverage on function under point." | |
209 | (interactive) | |
210 | (let* ((edebug-all-defs t) | |
211 | (x (symbol-function (eval-defun nil)))) | |
212 | (testcover-reinstrument x) | |
213 | x)) | |
214 | ||
215 | (defun testcover-read (&optional stream) | |
216 | "Read a form using edebug, changing edebug callbacks to testcover callbacks." | |
217 | (let ((x (edebug-read stream))) | |
218 | (testcover-reinstrument x) | |
219 | x)) | |
220 | ||
221 | (defun testcover-reinstrument (form) | |
3e39672f JY |
222 | "Reinstruments FORM to use testcover instead of edebug. This |
223 | function modifies the list that FORM points to. Result is nil if | |
ee7683eb | 224 | FORM should return multiple values, t if should always return same |
3e39672f | 225 | value, 'maybe if either is acceptable." |
bbaa1429 | 226 | (let ((fun (car-safe form)) |
3e39672f | 227 | id val) |
7ed9159a | 228 | (cond |
3e39672f JY |
229 | ((not fun) ;Atom |
230 | (when (or (not (symbolp form)) | |
231 | (memq form testcover-constants) | |
232 | (memq form testcover-module-constants)) | |
233 | t)) | |
234 | ((consp fun) ;Embedded list | |
7ed9159a JY |
235 | (testcover-reinstrument fun) |
236 | (testcover-reinstrument-list (cdr form)) | |
237 | nil) | |
238 | ((or (memq fun testcover-1value-functions) | |
239 | (memq fun testcover-module-1value-functions)) | |
3e39672f | 240 | ;;Should always return same value |
7ed9159a JY |
241 | (testcover-reinstrument-list (cdr form)) |
242 | t) | |
3e39672f JY |
243 | ((or (memq fun testcover-potentially-1value-functions) |
244 | (memq fun testcover-module-potentially-1value-functions)) | |
245 | ;;Might always return same value | |
246 | (testcover-reinstrument-list (cdr form)) | |
247 | 'maybe) | |
7ed9159a JY |
248 | ((memq fun testcover-progn-functions) |
249 | ;;1-valued if last argument is | |
250 | (testcover-reinstrument-list (cdr form))) | |
251 | ((memq fun testcover-prog1-functions) | |
252 | ;;1-valued if first argument is | |
253 | (testcover-reinstrument-list (cddr form)) | |
254 | (testcover-reinstrument (cadr form))) | |
255 | ((memq fun testcover-compose-functions) | |
3e39672f JY |
256 | ;;1-valued if all arguments are. Potentially 1-valued if all |
257 | ;;arguments are either definitely or potentially. | |
258 | (testcover-reinstrument-compose (cdr form) 'testcover-reinstrument)) | |
7ed9159a JY |
259 | ((eq fun 'edebug-enter) |
260 | ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS)) | |
261 | ;; => (testcover-enter 'SYM #'(lambda nil FORMS)) | |
262 | (setcar form 'testcover-enter) | |
263 | (setcdr (nthcdr 1 form) (nthcdr 3 form)) | |
264 | (let ((testcover-vector (get (cadr (cadr form)) 'edebug-coverage))) | |
265 | (testcover-reinstrument-list (nthcdr 2 (cadr (nth 2 form)))))) | |
266 | ((eq fun 'edebug-after) | |
267 | ;;(edebug-after (edebug-before XXX) YYY FORM) | |
268 | ;; => (testcover-after YYY FORM), mark XXX as ok-coverage | |
269 | (unless (eq (cadr form) 0) | |
270 | (aset testcover-vector (cadr (cadr form)) 'ok-coverage)) | |
bbaa1429 | 271 | (setq id (nth 2 form)) |
7ed9159a | 272 | (setcdr form (nthcdr 2 form)) |
3e39672f | 273 | (setq val (testcover-reinstrument (nth 2 form))) |
07b1a5fb SM |
274 | (setcar form (if (eq val t) |
275 | 'testcover-1value | |
276 | 'testcover-after)) | |
3e39672f JY |
277 | (when val |
278 | ;;1-valued or potentially 1-valued | |
279 | (aset testcover-vector id '1value)) | |
bbaa1429 JY |
280 | (cond |
281 | ((memq (car-safe (nth 2 form)) testcover-noreturn-functions) | |
7ed9159a JY |
282 | ;;This function won't return, so set the value in advance |
283 | ;;(edebug-after (edebug-before XXX) YYY FORM) | |
284 | ;; => (progn (edebug-after YYY nil) FORM) | |
3e39672f | 285 | (setcar (cdr form) `(,(car form) ,id nil)) |
7ed9159a | 286 | (setcar form 'progn) |
3e39672f JY |
287 | (aset testcover-vector id '1value) |
288 | (setq val t)) | |
bbaa1429 JY |
289 | ((eq (car-safe (nth 2 form)) '1value) |
290 | ;;This function is always supposed to return the same value | |
3e39672f JY |
291 | (setq val t) |
292 | (aset testcover-vector id '1value) | |
293 | (setcar form 'testcover-1value))) | |
294 | val) | |
7ed9159a | 295 | ((eq fun 'defun) |
3e39672f JY |
296 | (setq val (testcover-reinstrument-list (nthcdr 3 form))) |
297 | (when (eq val t) | |
298 | (push (cadr form) testcover-module-1value-functions)) | |
299 | (when (eq val 'maybe) | |
300 | (push (cadr form) testcover-module-potentially-1value-functions))) | |
301 | ((memq fun '(defconst defcustom)) | |
7ed9159a JY |
302 | ;;Define this symbol as 1-valued |
303 | (push (cadr form) testcover-module-constants) | |
304 | (testcover-reinstrument-list (cddr form))) | |
305 | ((memq fun '(dotimes dolist)) | |
306 | ;;Always returns third value from SPEC | |
307 | (testcover-reinstrument-list (cddr form)) | |
3e39672f | 308 | (setq val (testcover-reinstrument-list (cadr form))) |
7ed9159a | 309 | (if (nth 2 (cadr form)) |
3e39672f | 310 | val |
7ed9159a JY |
311 | ;;No third value, always returns nil |
312 | t)) | |
313 | ((memq fun '(let let*)) | |
314 | ;;Special parsing for second argument | |
315 | (mapc 'testcover-reinstrument-list (cadr form)) | |
316 | (testcover-reinstrument-list (cddr form))) | |
317 | ((eq fun 'if) | |
3e39672f | 318 | ;;Potentially 1-valued if both THEN and ELSE clauses are |
7ed9159a JY |
319 | (testcover-reinstrument (cadr form)) |
320 | (let ((then (testcover-reinstrument (nth 2 form))) | |
321 | (else (testcover-reinstrument-list (nthcdr 3 form)))) | |
3e39672f | 322 | (and then else 'maybe))) |
7ed9159a | 323 | ((eq fun 'cond) |
3e39672f JY |
324 | ;;Potentially 1-valued if all clauses are |
325 | (when (testcover-reinstrument-compose (cdr form) | |
326 | 'testcover-reinstrument-list) | |
327 | 'maybe)) | |
7ed9159a | 328 | ((eq fun 'condition-case) |
3e39672f | 329 | ;;Potentially 1-valued if BODYFORM is and all HANDLERS are |
7ed9159a | 330 | (let ((body (testcover-reinstrument (nth 2 form))) |
3e39672f JY |
331 | (errs (testcover-reinstrument-compose |
332 | (mapcar #'cdr (nthcdr 3 form)) | |
333 | 'testcover-reinstrument-list))) | |
334 | (and body errs 'maybe))) | |
7ed9159a JY |
335 | ((eq fun 'quote) |
336 | ;;Don't reinstrument what's inside! | |
337 | ;;This doesn't apply within a backquote | |
338 | t) | |
339 | ((eq fun '\`) | |
340 | ;;Quotes are not special within backquotes | |
341 | (let ((testcover-1value-functions | |
342 | (cons 'quote testcover-1value-functions))) | |
343 | (testcover-reinstrument (cadr form)))) | |
344 | ((eq fun '\,) | |
345 | ;;In commas inside backquotes, quotes are special again | |
346 | (let ((testcover-1value-functions | |
347 | (remq 'quote testcover-1value-functions))) | |
348 | (testcover-reinstrument (cadr form)))) | |
3e39672f | 349 | ((eq fun '1value) |
7ed9159a | 350 | ;;Hack - pretend the arg is 1-valued here |
3e39672f JY |
351 | (cond |
352 | ((symbolp (cadr form)) | |
353 | ;;A pseudoconstant variable | |
354 | t) | |
355 | ((and (eq (car (cadr form)) 'edebug-after) | |
356 | (symbolp (nth 3 (cadr form)))) | |
357 | ;;Reference to pseudoconstant | |
358 | (aset testcover-vector (nth 2 (cadr form)) '1value) | |
359 | (setcar (cdr form) `(testcover-1value ,(nth 2 (cadr form)) | |
360 | ,(nth 3 (cadr form)))) | |
361 | t) | |
362 | (t | |
07b1a5fb SM |
363 | (setq id (car (if (eq (car (cadr form)) 'edebug-after) |
364 | (nth 3 (cadr form)) | |
365 | (cadr form)))) | |
7ed9159a | 366 | (let ((testcover-1value-functions |
bbaa1429 | 367 | (cons id testcover-1value-functions))) |
3e39672f JY |
368 | (testcover-reinstrument (cadr form)))))) |
369 | ((eq fun 'noreturn) | |
370 | ;;Hack - pretend the arg has no return | |
371 | (cond | |
372 | ((symbolp (cadr form)) | |
373 | ;;A pseudoconstant variable | |
374 | 'maybe) | |
375 | ((and (eq (car (cadr form)) 'edebug-after) | |
376 | (symbolp (nth 3 (cadr form)))) | |
377 | ;;Reference to pseudoconstant | |
378 | (aset testcover-vector (nth 2 (cadr form)) '1value) | |
379 | (setcar (cdr form) `(progn (testcover-after ,(nth 2 (cadr form)) nil) | |
380 | ,(nth 3 (cadr form)))) | |
381 | 'maybe) | |
382 | (t | |
07b1a5fb SM |
383 | (setq id (car (if (eq (car (cadr form)) 'edebug-after) |
384 | (nth 3 (cadr form)) | |
385 | (cadr form)))) | |
3e39672f JY |
386 | (let ((testcover-noreturn-functions |
387 | (cons id testcover-noreturn-functions))) | |
388 | (testcover-reinstrument (cadr form)))))) | |
389 | ((and (eq fun 'apply) | |
390 | (eq (car-safe (cadr form)) 'quote) | |
391 | (symbolp (cadr (cadr form)))) | |
392 | ;;Apply of a constant symbol. Process as 1value or noreturn | |
393 | ;;depending on symbol. | |
394 | (setq fun (cons (cadr (cadr form)) (cddr form)) | |
395 | val (testcover-reinstrument fun)) | |
396 | (setcdr (cdr form) (cdr fun)) | |
397 | val) | |
7ed9159a JY |
398 | (t ;Some other function or weird thing |
399 | (testcover-reinstrument-list (cdr form)) | |
400 | nil)))) | |
401 | ||
402 | (defun testcover-reinstrument-list (list) | |
403 | "Reinstruments each form in LIST to use testcover instead of edebug. | |
404 | This function modifies the forms in LIST. Result is `testcover-reinstrument's | |
405 | value for the last form in LIST. If the LIST is empty, its evaluation will | |
406 | always be nil, so we return t for 1-valued." | |
407 | (let ((result t)) | |
408 | (while (consp list) | |
409 | (setq result (testcover-reinstrument (pop list)))) | |
410 | result)) | |
411 | ||
3e39672f JY |
412 | (defun testcover-reinstrument-compose (list fun) |
413 | "For a compositional function, the result is 1-valued if all | |
414 | arguments are, potentially 1-valued if all arguments are either | |
415 | definitely or potentially 1-valued, and multi-valued otherwise. | |
416 | FUN should be `testcover-reinstrument' for compositional functions, | |
417 | `testcover-reinstrument-list' for clauses in a `cond'." | |
7ed9159a JY |
418 | (let ((result t)) |
419 | (mapc #'(lambda (x) | |
3e39672f JY |
420 | (setq x (funcall fun x)) |
421 | (cond | |
422 | ((eq result t) | |
423 | (setq result x)) | |
424 | ((eq result 'maybe) | |
425 | (when (not x) | |
426 | (setq result nil))))) | |
427 | list) | |
7ed9159a JY |
428 | result)) |
429 | ||
6e5a4966 | 430 | (defun testcover-end (filename) |
7ed9159a | 431 | "Turn off instrumentation of all macros and functions in FILENAME." |
6e5a4966 EZ |
432 | (interactive "fStop covering file: ") |
433 | (let ((buf (find-file-noselect filename))) | |
2462470b | 434 | (eval-buffer buf))) |
7ed9159a | 435 | |
7ed9159a JY |
436 | |
437 | ;;;========================================================================= | |
438 | ;;; Accumulate coverage data | |
439 | ;;;========================================================================= | |
440 | ||
441 | (defun testcover-enter (testcover-sym testcover-fun) | |
442 | "Internal function for coverage testing. Invokes TESTCOVER-FUN while | |
443 | binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM | |
444 | \(the name of the current function)." | |
445 | (let ((testcover-vector (get testcover-sym 'edebug-coverage))) | |
446 | (funcall testcover-fun))) | |
447 | ||
448 | (defun testcover-after (idx val) | |
449 | "Internal function for coverage testing. Returns VAL after installing it in | |
450 | `testcover-vector' at offset IDX." | |
07b1a5fb SM |
451 | (declare (gv-expander (lambda (do) |
452 | (gv-letplace (getter setter) val | |
453 | (funcall do getter | |
454 | (lambda (store) | |
455 | `(progn (testcover-after ,idx ,getter) | |
456 | ,(funcall setter store)))))))) | |
7ed9159a JY |
457 | (cond |
458 | ((eq (aref testcover-vector idx) 'unknown) | |
459 | (aset testcover-vector idx val)) | |
460 | ((not (equal (aref testcover-vector idx) val)) | |
461 | (aset testcover-vector idx 'ok-coverage))) | |
462 | val) | |
463 | ||
bbaa1429 JY |
464 | (defun testcover-1value (idx val) |
465 | "Internal function for coverage testing. Returns VAL after installing it in | |
466 | `testcover-vector' at offset IDX. Error if FORM does not always return the | |
467 | same value during coverage testing." | |
468 | (cond | |
469 | ((eq (aref testcover-vector idx) '1value) | |
470 | (aset testcover-vector idx (cons '1value val))) | |
471 | ((not (and (eq (car-safe (aref testcover-vector idx)) '1value) | |
472 | (equal (cdr (aref testcover-vector idx)) val))) | |
3e39672f | 473 | (error "Value of form marked with `1value' does vary: %s" val))) |
bbaa1429 JY |
474 | val) |
475 | ||
476 | ||
7ed9159a JY |
477 | |
478 | ;;;========================================================================= | |
479 | ;;; Display the coverage data as color splotches on your code. | |
480 | ;;;========================================================================= | |
481 | ||
482 | (defun testcover-mark (def) | |
483 | "Marks one DEF (a function or macro symbol) to highlight its contained forms | |
484 | that did not get completely tested during coverage tests. | |
4719d184 MB |
485 | A marking with the face `testcover-nohits' (default = red) indicates that the |
486 | form was never evaluated. A marking using the `testcover-1value' face | |
7ed9159a JY |
487 | \(default = tan) indicates that the form always evaluated to the same value. |
488 | The forms throw, error, and signal are not marked. They do not return and | |
489 | would always get a red mark. Some forms that always return the same | |
490 | value (e.g., setq of a constant), always get a tan mark that can't be | |
491 | eliminated by adding more test cases." | |
492 | (let* ((data (get def 'edebug)) | |
493 | (def-mark (car data)) | |
494 | (points (nth 2 data)) | |
495 | (len (length points)) | |
496 | (changed (buffer-modified-p)) | |
497 | (coverage (get def 'edebug-coverage)) | |
498 | ov j item) | |
499 | (or (and def-mark points coverage) | |
500 | (error "Missing edebug data for function %s" def)) | |
3e39672f | 501 | (when (> len 0) |
7119cefe JY |
502 | (set-buffer (marker-buffer def-mark)) |
503 | (mapc 'delete-overlay | |
504 | (overlays-in def-mark (+ def-mark (aref points (1- len)) 1))) | |
505 | (while (> len 0) | |
506 | (setq len (1- len) | |
507 | data (aref coverage len)) | |
508 | (when (and (not (eq data 'ok-coverage)) | |
bbaa1429 | 509 | (not (eq (car-safe data) '1value)) |
7119cefe | 510 | (setq j (+ def-mark (aref points len)))) |
7ed9159a JY |
511 | (setq ov (make-overlay (1- j) j)) |
512 | (overlay-put ov 'face | |
513 | (if (memq data '(unknown 1value)) | |
4719d184 MB |
514 | 'testcover-nohits |
515 | 'testcover-1value)))) | |
7119cefe | 516 | (set-buffer-modified-p changed)))) |
7ed9159a JY |
517 | |
518 | (defun testcover-mark-all (&optional buffer) | |
da6062e6 | 519 | "Mark all forms in BUFFER that did not get completely tested during |
7119cefe | 520 | coverage tests. This function creates many overlays." |
6e5a4966 | 521 | (interactive "bMark forms in buffer: ") |
7ed9159a JY |
522 | (if buffer |
523 | (switch-to-buffer buffer)) | |
524 | (goto-char 1) | |
525 | (dolist (x edebug-form-data) | |
7119cefe | 526 | (if (get (car x) 'edebug) |
7ed9159a JY |
527 | (testcover-mark (car x))))) |
528 | ||
529 | (defun testcover-unmark-all (buffer) | |
530 | "Remove all overlays from FILENAME." | |
6e5a4966 | 531 | (interactive "bUnmark forms in buffer: ") |
7ed9159a JY |
532 | (condition-case nil |
533 | (progn | |
534 | (set-buffer buffer) | |
535 | (mapc 'delete-overlay (overlays-in 1 (buffer-size)))) | |
536 | (error nil))) ;Ignore "No such buffer" errors | |
537 | ||
538 | (defun testcover-next-mark () | |
539 | "Moves point to next line in current buffer that has a splotch." | |
540 | (interactive) | |
541 | (goto-char (next-overlay-change (point))) | |
542 | (end-of-line)) | |
543 | ||
544 | ;; testcover.el ends here. |