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