38 |
;; instrumentation callbacks, then replace edebug's callbacks with ours. |
;; instrumentation callbacks, then replace edebug's callbacks with ours. |
39 |
;; * To show good coverage, we want to see two values for every form, except |
;; * 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 |
;; functions that always return the same value and `defconst' variables |
41 |
;; need show only value for good coverage. To avoid the brown splotch, the |
;; need show only one value for good coverage. To avoid the brown |
42 |
;; definitions for constants and 1-valued functions must precede the |
;; splotch, the definitions for constants and 1-valued functions must |
43 |
;; references. |
;; precede the references. |
44 |
;; * Use the macro `1value' in your Lisp code to mark spots where the local |
;; * 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 |
;; code environment causes a function or variable to always have the same |
46 |
;; value, but the function or variable is not intrinsically 1-valued. |
;; value, but the function or variable is not intrinsically 1-valued. |
55 |
;; call has the same value! Also, equal thinks two strings are the same |
;; call has the same value! Also, equal thinks two strings are the same |
56 |
;; if they differ only in properties. |
;; if they differ only in properties. |
57 |
;; * Because we have only a "1value" class and no "always nil" class, we have |
;; * 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 |
;; to treat as potentially 1-valued any `and' whose last term is 1-valued, |
59 |
;; last term is always nil. Example: |
;; in case the last term is always nil. Example: |
60 |
;; (and (< (point) 1000) (forward-char 10)) |
;; (and (< (point) 1000) (forward-char 10)) |
61 |
;; This form always returns nil. Similarly, `if' and `cond' are |
;; This form always returns nil. Similarly, `or', `if', and `cond' are |
62 |
;; treated as 1-valued if all clauses are, in case those values are |
;; treated as potentially 1-valued if all clauses are, in case those |
63 |
;; always nil. |
;; 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. |
66 |
|
|
67 |
(require 'edebug) |
(require 'edebug) |
68 |
(provide 'testcover) |
(provide 'testcover) |
88 |
|
|
89 |
(defcustom testcover-1value-functions |
(defcustom testcover-1value-functions |
90 |
'(backward-char barf-if-buffer-read-only beginning-of-line |
'(backward-char barf-if-buffer-read-only beginning-of-line |
91 |
buffer-disable-undo buffer-enable-undo current-global-map deactivate-mark |
buffer-disable-undo buffer-enable-undo current-global-map |
92 |
delete-char delete-region ding error forward-char function* insert |
deactivate-mark delete-backward-char delete-char delete-region ding |
93 |
insert-and-inherit kill-all-local-variables lambda mapc narrow-to-region |
forward-char function* insert insert-and-inherit kill-all-local-variables |
94 |
noreturn push-mark put-text-property run-hooks set-text-properties signal |
kill-line kill-paragraph kill-region kill-sexp lambda |
95 |
substitute-key-definition suppress-keymap throw undo use-local-map while |
minibuffer-complete-and-exit narrow-to-region next-line push-mark |
96 |
widen yank) |
put-text-property run-hooks set-match-data signal |
97 |
|
substitute-key-definition suppress-keymap undo use-local-map while widen |
98 |
|
yank) |
99 |
"Functions that always return the same value. No brown splotch is shown |
"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 |
for these. This list is quite incomplete! Notes: Nobody ever changes the |
101 |
current global map. The macro `lambda' is self-evaluating, hence always |
current global map. The macro `lambda' is self-evaluating, hence always |
112 |
:type 'hook) |
:type 'hook) |
113 |
|
|
114 |
(defcustom testcover-compose-functions |
(defcustom testcover-compose-functions |
115 |
'(+ - * / length list make-keymap make-sparse-keymap message propertize |
'(+ - * / = append length list make-keymap make-sparse-keymap |
116 |
replace-regexp-in-string run-with-idle-timer |
mapcar message propertize replace-regexp-in-string |
117 |
set-buffer-modified-p) |
run-with-idle-timer set-buffer-modified-p) |
118 |
"Functions that are 1-valued if all their args are either constants or |
"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 |
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 |
brown splotch is shown for these. This list is quite incomplete! Most |
123 |
:type 'hook) |
:type 'hook) |
124 |
|
|
125 |
(defcustom testcover-progn-functions |
(defcustom testcover-progn-functions |
126 |
'(define-key fset function goto-char or overlay-put progn save-current-buffer |
'(define-key fset function goto-char mapc overlay-put progn |
127 |
save-excursion save-match-data save-restriction save-selected-window |
save-current-buffer save-excursion save-match-data |
128 |
save-window-excursion set set-default setq setq-default |
save-restriction save-selected-window save-window-excursion |
129 |
with-output-to-temp-buffer with-syntax-table with-temp-buffer |
set set-default set-marker-insertion-type setq setq-default |
130 |
with-temp-file with-temp-message with-timeout) |
with-current-buffer with-output-to-temp-buffer with-syntax-table |
131 |
|
with-temp-buffer with-temp-file with-temp-message with-timeout) |
132 |
"Functions whose return value is the same as their last argument. No |
"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 |
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 |
call to one of the `testcover-1value-functions'. This list is probably |
135 |
incomplete! Note: `or' is here in case the last argument is a function that |
incomplete!" |
|
always returns nil." |
|
136 |
:group 'testcover |
:group 'testcover |
137 |
:type 'hook) |
:type 'hook) |
138 |
|
|
144 |
:group 'testcover |
:group 'testcover |
145 |
:type 'hook) |
:type 'hook) |
146 |
|
|
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 |
150 |
|
1-valued, no error if actually multi-valued.") |
151 |
|
|
152 |
(defface testcover-nohits-face |
(defface testcover-nohits-face |
153 |
'((t (:background "DeepPink2"))) |
'((t (:background "DeepPink2"))) |
154 |
"Face for forms that had no hits during coverage test" |
"Face for forms that had no hits during coverage test" |
170 |
|
|
171 |
(defvar testcover-module-1value-functions nil |
(defvar testcover-module-1value-functions nil |
172 |
"Symbols declared with defun in the last file processed by |
"Symbols declared with defun in the last file processed by |
173 |
`testcover-start', whose functions always return the same value.") |
`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.") |
178 |
|
|
179 |
(defvar testcover-vector nil |
(defvar testcover-vector nil |
180 |
"Locally bound to coverage vector for function in progress.") |
"Locally bound to coverage vector for function in progress.") |
219 |
x)) |
x)) |
220 |
|
|
221 |
(defun testcover-reinstrument (form) |
(defun testcover-reinstrument (form) |
222 |
"Reinstruments FORM to use testcover instead of edebug. This function |
"Reinstruments FORM to use testcover instead of edebug. This |
223 |
modifies the list that FORM points to. Result is non-nil if FORM will |
function modifies the list that FORM points to. Result is nil if |
224 |
always return the same value." |
FORM should return multiple vlues, t if should always return same |
225 |
|
value, 'maybe if either is acceptable." |
226 |
(let ((fun (car-safe form)) |
(let ((fun (car-safe form)) |
227 |
id) |
id val) |
228 |
(cond |
(cond |
229 |
((not fun) ;Atom |
((not fun) ;Atom |
230 |
(or (not (symbolp form)) |
(when (or (not (symbolp form)) |
231 |
(memq form testcover-constants) |
(memq form testcover-constants) |
232 |
(memq form testcover-module-constants))) |
(memq form testcover-module-constants)) |
233 |
((consp fun) ;Embedded list |
t)) |
234 |
|
((consp fun) ;Embedded list |
235 |
(testcover-reinstrument fun) |
(testcover-reinstrument fun) |
236 |
(testcover-reinstrument-list (cdr form)) |
(testcover-reinstrument-list (cdr form)) |
237 |
nil) |
nil) |
238 |
((or (memq fun testcover-1value-functions) |
((or (memq fun testcover-1value-functions) |
239 |
(memq fun testcover-module-1value-functions)) |
(memq fun testcover-module-1value-functions)) |
240 |
;;Always return same value |
;;Should always return same value |
241 |
(testcover-reinstrument-list (cdr form)) |
(testcover-reinstrument-list (cdr form)) |
242 |
t) |
t) |
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) |
248 |
((memq fun testcover-progn-functions) |
((memq fun testcover-progn-functions) |
249 |
;;1-valued if last argument is |
;;1-valued if last argument is |
250 |
(testcover-reinstrument-list (cdr form))) |
(testcover-reinstrument-list (cdr form))) |
253 |
(testcover-reinstrument-list (cddr form)) |
(testcover-reinstrument-list (cddr form)) |
254 |
(testcover-reinstrument (cadr form))) |
(testcover-reinstrument (cadr form))) |
255 |
((memq fun testcover-compose-functions) |
((memq fun testcover-compose-functions) |
256 |
;;1-valued if all arguments are |
;;1-valued if all arguments are. Potentially 1-valued if all |
257 |
(setq id t) |
;;arguments are either definitely or potentially. |
258 |
(mapc #'(lambda (x) (setq id (or (testcover-reinstrument x) id))) |
(testcover-reinstrument-compose (cdr form) 'testcover-reinstrument)) |
|
(cdr form)) |
|
|
id) |
|
259 |
((eq fun 'edebug-enter) |
((eq fun 'edebug-enter) |
260 |
;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS)) |
;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS)) |
261 |
;; => (testcover-enter 'SYM #'(lambda nil FORMS)) |
;; => (testcover-enter 'SYM #'(lambda nil FORMS)) |
270 |
(aset testcover-vector (cadr (cadr form)) 'ok-coverage)) |
(aset testcover-vector (cadr (cadr form)) 'ok-coverage)) |
271 |
(setq id (nth 2 form)) |
(setq id (nth 2 form)) |
272 |
(setcdr form (nthcdr 2 form)) |
(setcdr form (nthcdr 2 form)) |
273 |
|
(setq val (testcover-reinstrument (nth 2 form))) |
274 |
|
(if (eq val t) |
275 |
|
(setcar form 'testcover-1value) |
276 |
|
(setcar form 'testcover-after)) |
277 |
|
(when val |
278 |
|
;;1-valued or potentially 1-valued |
279 |
|
(aset testcover-vector id '1value)) |
280 |
(cond |
(cond |
281 |
((memq (car-safe (nth 2 form)) testcover-noreturn-functions) |
((memq (car-safe (nth 2 form)) testcover-noreturn-functions) |
282 |
;;This function won't return, so set the value in advance |
;;This function won't return, so set the value in advance |
283 |
;;(edebug-after (edebug-before XXX) YYY FORM) |
;;(edebug-after (edebug-before XXX) YYY FORM) |
284 |
;; => (progn (edebug-after YYY nil) FORM) |
;; => (progn (edebug-after YYY nil) FORM) |
285 |
|
(setcar (cdr form) `(,(car form) ,id nil)) |
286 |
(setcar form 'progn) |
(setcar form 'progn) |
287 |
(setcar (cdr form) `(testcover-after ,id nil))) |
(aset testcover-vector id '1value) |
288 |
|
(setq val t)) |
289 |
((eq (car-safe (nth 2 form)) '1value) |
((eq (car-safe (nth 2 form)) '1value) |
290 |
;;This function is always supposed to return the same value |
;;This function is always supposed to return the same value |
291 |
(setcar form 'testcover-1value)) |
(setq val t) |
292 |
(t |
(aset testcover-vector id '1value) |
293 |
(setcar form 'testcover-after))) |
(setcar form 'testcover-1value))) |
294 |
(when (testcover-reinstrument (nth 2 form)) |
val) |
|
(aset testcover-vector id '1value))) |
|
295 |
((eq fun 'defun) |
((eq fun 'defun) |
296 |
(if (testcover-reinstrument-list (nthcdr 3 form)) |
(setq val (testcover-reinstrument-list (nthcdr 3 form))) |
297 |
(push (cadr form) testcover-module-1value-functions))) |
(when (eq val t) |
298 |
((eq fun 'defconst) |
(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)) |
302 |
;;Define this symbol as 1-valued |
;;Define this symbol as 1-valued |
303 |
(push (cadr form) testcover-module-constants) |
(push (cadr form) testcover-module-constants) |
304 |
(testcover-reinstrument-list (cddr form))) |
(testcover-reinstrument-list (cddr form))) |
305 |
((memq fun '(dotimes dolist)) |
((memq fun '(dotimes dolist)) |
306 |
;;Always returns third value from SPEC |
;;Always returns third value from SPEC |
307 |
(testcover-reinstrument-list (cddr form)) |
(testcover-reinstrument-list (cddr form)) |
308 |
(setq fun (testcover-reinstrument-list (cadr form))) |
(setq val (testcover-reinstrument-list (cadr form))) |
309 |
(if (nth 2 (cadr form)) |
(if (nth 2 (cadr form)) |
310 |
fun |
val |
311 |
;;No third value, always returns nil |
;;No third value, always returns nil |
312 |
t)) |
t)) |
313 |
((memq fun '(let let*)) |
((memq fun '(let let*)) |
315 |
(mapc 'testcover-reinstrument-list (cadr form)) |
(mapc 'testcover-reinstrument-list (cadr form)) |
316 |
(testcover-reinstrument-list (cddr form))) |
(testcover-reinstrument-list (cddr form))) |
317 |
((eq fun 'if) |
((eq fun 'if) |
318 |
;;1-valued if both THEN and ELSE clauses are |
;;Potentially 1-valued if both THEN and ELSE clauses are |
319 |
(testcover-reinstrument (cadr form)) |
(testcover-reinstrument (cadr form)) |
320 |
(let ((then (testcover-reinstrument (nth 2 form))) |
(let ((then (testcover-reinstrument (nth 2 form))) |
321 |
(else (testcover-reinstrument-list (nthcdr 3 form)))) |
(else (testcover-reinstrument-list (nthcdr 3 form)))) |
322 |
(and then else))) |
(and then else 'maybe))) |
|
((memq fun '(when unless and)) |
|
|
;;1-valued if last clause of BODY is |
|
|
(testcover-reinstrument-list (cdr form))) |
|
323 |
((eq fun 'cond) |
((eq fun 'cond) |
324 |
;;1-valued if all clauses are |
;;Potentially 1-valued if all clauses are |
325 |
(testcover-reinstrument-clauses (cdr form))) |
(when (testcover-reinstrument-compose (cdr form) |
326 |
|
'testcover-reinstrument-list) |
327 |
|
'maybe)) |
328 |
((eq fun 'condition-case) |
((eq fun 'condition-case) |
329 |
;;1-valued if BODYFORM is and all HANDLERS are |
;;Potentially 1-valued if BODYFORM is and all HANDLERS are |
330 |
(let ((body (testcover-reinstrument (nth 2 form))) |
(let ((body (testcover-reinstrument (nth 2 form))) |
331 |
(errs (testcover-reinstrument-clauses (mapcar #'cdr |
(errs (testcover-reinstrument-compose |
332 |
(nthcdr 3 form))))) |
(mapcar #'cdr (nthcdr 3 form)) |
333 |
(and body errs))) |
'testcover-reinstrument-list))) |
334 |
|
(and body errs 'maybe))) |
335 |
((eq fun 'quote) |
((eq fun 'quote) |
336 |
;;Don't reinstrument what's inside! |
;;Don't reinstrument what's inside! |
337 |
;;This doesn't apply within a backquote |
;;This doesn't apply within a backquote |
346 |
(let ((testcover-1value-functions |
(let ((testcover-1value-functions |
347 |
(remq 'quote testcover-1value-functions))) |
(remq 'quote testcover-1value-functions))) |
348 |
(testcover-reinstrument (cadr form)))) |
(testcover-reinstrument (cadr form)))) |
349 |
((memq fun '(1value noreturn)) |
((eq fun '1value) |
350 |
;;Hack - pretend the arg is 1-valued here |
;;Hack - pretend the arg is 1-valued here |
351 |
(if (symbolp (cadr form)) ;A pseudoconstant variable |
(cond |
352 |
t |
((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 |
363 |
(if (eq (car (cadr form)) 'edebug-after) |
(if (eq (car (cadr form)) 'edebug-after) |
364 |
(setq id (car (nth 3 (cadr form)))) |
(setq id (car (nth 3 (cadr form)))) |
365 |
(setq id (car (cadr form)))) |
(setq id (car (cadr form)))) |
366 |
(let ((testcover-1value-functions |
(let ((testcover-1value-functions |
367 |
(cons id testcover-1value-functions))) |
(cons id testcover-1value-functions))) |
368 |
(testcover-reinstrument (cadr form))))) |
(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 |
383 |
|
(if (eq (car (cadr form)) 'edebug-after) |
384 |
|
(setq id (car (nth 3 (cadr form)))) |
385 |
|
(setq id (car (cadr form)))) |
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) |
398 |
(t ;Some other function or weird thing |
(t ;Some other function or weird thing |
399 |
(testcover-reinstrument-list (cdr form)) |
(testcover-reinstrument-list (cdr form)) |
400 |
nil)))) |
nil)))) |
409 |
(setq result (testcover-reinstrument (pop list)))) |
(setq result (testcover-reinstrument (pop list)))) |
410 |
result)) |
result)) |
411 |
|
|
412 |
(defun testcover-reinstrument-clauses (clauselist) |
(defun testcover-reinstrument-compose (list fun) |
413 |
"Reinstrument each list in CLAUSELIST. |
"For a compositional function, the result is 1-valued if all |
414 |
Result is t if every clause is 1-valued." |
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'." |
418 |
(let ((result t)) |
(let ((result t)) |
419 |
(mapc #'(lambda (x) |
(mapc #'(lambda (x) |
420 |
(setq result (and (testcover-reinstrument-list x) result))) |
(setq x (funcall fun x)) |
421 |
clauselist) |
(cond |
422 |
|
((eq result t) |
423 |
|
(setq result x)) |
424 |
|
((eq result 'maybe) |
425 |
|
(when (not x) |
426 |
|
(setq result nil))))) |
427 |
|
list) |
428 |
result)) |
result)) |
429 |
|
|
430 |
(defun testcover-end (buffer) |
(defun testcover-end (buffer) |
464 |
(aset testcover-vector idx (cons '1value val))) |
(aset testcover-vector idx (cons '1value val))) |
465 |
((not (and (eq (car-safe (aref testcover-vector idx)) '1value) |
((not (and (eq (car-safe (aref testcover-vector idx)) '1value) |
466 |
(equal (cdr (aref testcover-vector idx)) val))) |
(equal (cdr (aref testcover-vector idx)) val))) |
467 |
(error "Value of form marked with `1value' does vary."))) |
(error "Value of form marked with `1value' does vary: %s" val))) |
468 |
val) |
val) |
469 |
|
|
470 |
|
|
492 |
ov j item) |
ov j item) |
493 |
(or (and def-mark points coverage) |
(or (and def-mark points coverage) |
494 |
(error "Missing edebug data for function %s" def)) |
(error "Missing edebug data for function %s" def)) |
495 |
(when len |
(when (> len 0) |
496 |
(set-buffer (marker-buffer def-mark)) |
(set-buffer (marker-buffer def-mark)) |
497 |
(mapc 'delete-overlay |
(mapc 'delete-overlay |
498 |
(overlays-in def-mark (+ def-mark (aref points (1- len)) 1))) |
(overlays-in def-mark (+ def-mark (aref points (1- len)) 1))) |