-;;;; testcover.el -- Visual code-coverage tool
+;;;; testcover.el -- Visual code-coverage tool -*- lexical-binding:t -*-
-;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2016 Free Software Foundation, Inc.
;; Author: Jonathan Yavner <jyavner@member.fsf.org>
;; Maintainer: Jonathan Yavner <jyavner@member.fsf.org>
;; * Use `testcover-mark-all' to add overlay "splotches" to the Lisp file's
;; buffer to show where coverage is lacking. Normally, a red splotch
;; indicates the form was never evaluated; a brown splotch means it always
-;; evaluted to the same value.
+;; evaluated to the same value.
;; * Use `testcover-next-mark' (bind it to a key!) to jump to the next spot
;; that has a splotch.
returns the same value (the function it defines may return varying values
when called)."
:group 'testcover
- :type 'hook)
+ :type '(repeat symbol))
(defcustom testcover-noreturn-functions
'(error noreturn throw signal)
"Subset of `testcover-1value-functions' -- these never return. We mark
them as having returned nil just before calling them."
:group 'testcover
- :type 'hook)
+ :type '(repeat symbol))
(defcustom testcover-compose-functions
'(+ - * / = append length list make-keymap make-sparse-keymap
brown splotch is shown for these. This list is quite incomplete! Most
side-effect-free functions should be here."
:group 'testcover
- :type 'hook)
+ :type '(repeat symbol))
(defcustom testcover-progn-functions
'(define-key fset function goto-char mapc overlay-put progn
call to one of the `testcover-1value-functions'. This list is probably
incomplete!"
:group 'testcover
- :type 'hook)
+ :type '(repeat symbol))
(defcustom testcover-prog1-functions
'(prog1 unwind-protect)
brown splotch is shown for these if the first argument is a constant or a
call to one of the `testcover-1value-functions'."
:group 'testcover
- :type 'hook)
+ :type '(repeat symbol))
(defcustom testcover-potentially-1value-functions
'(add-hook and beep or remove-hook unless when)
"Functions that are potentially 1-valued. No brown splotch if actually
1-valued, no error if actually multi-valued."
- :group 'testcover)
+ :group 'testcover
+ :type '(repeat symbol))
(defface testcover-nohits
'((t (:background "DeepPink2")))
non-nil, byte-compiles each function after instrumenting."
(interactive "fStart covering file: ")
(let ((buf (find-file filename))
- (load-read-function 'testcover-read)
- (edebug-all-defs t))
+ (load-read-function load-read-function))
+ (add-function :around load-read-function
+ #'testcover--read)
(setq edebug-form-data nil
testcover-module-constants nil
testcover-module-1value-functions nil)
(defun testcover-this-defun ()
"Start coverage on function under point."
(interactive)
- (let* ((edebug-all-defs t)
- (x (symbol-function (eval-defun nil))))
+ (let ((x (let ((edebug-all-defs t))
+ (symbol-function (eval-defun nil)))))
(testcover-reinstrument x)
x))
-(defun testcover-read (&optional stream)
+(defun testcover--read (orig &optional stream)
"Read a form using edebug, changing edebug callbacks to testcover callbacks."
- (let ((x (edebug-read stream)))
- (testcover-reinstrument x)
- x))
+ (or stream (setq stream standard-input))
+ (if (eq stream (current-buffer))
+ (let ((x (let ((edebug-all-defs t))
+ (edebug-read-and-maybe-wrap-form))))
+ (testcover-reinstrument x)
+ x)
+ (funcall (or orig #'read) stream)))
(defun testcover-reinstrument (form)
"Reinstruments FORM to use testcover instead of edebug. This
function modifies the list that FORM points to. Result is nil if
-FORM should return multiple vlues, t if should always return same
-value, 'maybe if either is acceptable."
+FORM should return multiple values, t if should always return same
+value, `maybe' if either is acceptable."
(let ((fun (car-safe form))
id val)
(cond
(setq id (nth 2 form))
(setcdr form (nthcdr 2 form))
(setq val (testcover-reinstrument (nth 2 form)))
- (if (eq val t)
- (setcar form 'testcover-1value)
- (setcar form 'testcover-after))
+ (setcar form (if (eq val t)
+ 'testcover-1value
+ 'testcover-after))
(when val
;;1-valued or potentially 1-valued
(aset testcover-vector id '1value))
,(nth 3 (cadr form))))
t)
(t
- (if (eq (car (cadr form)) 'edebug-after)
- (setq id (car (nth 3 (cadr form))))
- (setq id (car (cadr form))))
+ (setq id (car (if (eq (car (cadr form)) 'edebug-after)
+ (nth 3 (cadr form))
+ (cadr form))))
(let ((testcover-1value-functions
(cons id testcover-1value-functions)))
(testcover-reinstrument (cadr form))))))
,(nth 3 (cadr form))))
'maybe)
(t
- (if (eq (car (cadr form)) 'edebug-after)
- (setq id (car (nth 3 (cadr form))))
- (setq id (car (cadr form))))
+ (setq id (car (if (eq (car (cadr form)) 'edebug-after)
+ (nth 3 (cadr form))
+ (cadr form))))
(let ((testcover-noreturn-functions
(cons id testcover-noreturn-functions)))
(testcover-reinstrument (cadr form))))))
"Turn off instrumentation of all macros and functions in FILENAME."
(interactive "fStop covering file: ")
(let ((buf (find-file-noselect filename)))
- (eval-buffer buf t)))
+ (eval-buffer buf)))
;;;=========================================================================
(defun testcover-after (idx val)
"Internal function for coverage testing. Returns VAL after installing it in
`testcover-vector' at offset IDX."
+ (declare (gv-expander (lambda (do)
+ (gv-letplace (getter setter) val
+ (funcall do getter
+ (lambda (store)
+ `(progn (testcover-after ,idx ,getter)
+ ,(funcall setter store))))))))
(cond
((eq (aref testcover-vector idx) 'unknown)
(aset testcover-vector idx val))
(len (length points))
(changed (buffer-modified-p))
(coverage (get def 'edebug-coverage))
- ov j item)
+ ov j)
(or (and def-mark points coverage)
(error "Missing edebug data for function %s" def))
(when (> len 0)
(set-buffer-modified-p changed))))
(defun testcover-mark-all (&optional buffer)
- "Mark all forms in BUFFER that did not get completley tested during
+ "Mark all forms in BUFFER that did not get completely tested during
coverage tests. This function creates many overlays."
(interactive "bMark forms in buffer: ")
(if buffer