From: Gemini Lasswell <gazally@runbox.com>
To: Eli Zaretskii <eliz@gnu.org>
Cc: 25316@debbugs.gnu.org
Subject: bug#25316: Patch for bug#25316: 26.0.50; Bugs in testcover-reinstrument
Date: Tue, 03 Oct 2017 12:17:50 -0700 [thread overview]
Message-ID: <871smkrqg1.fsf@runbox.com> (raw)
In-Reply-To: <83o9pt95wm.fsf@gnu.org>
[-- Attachment #1: Type: text/plain, Size: 353 bytes --]
Eli Zaretskii writes:
> Thanks, I have a few comments below. Please let others to comment for
> a week or so before installing on master.
>
Here are revised patches with your comments incorporated. I've removed
the NEWS entry for Testcover because there aren't any new features to
document, just old features that are more likely to work correctly.
[-- Attachment #2: 0001-Allow-Edebug-s-instrumentation-to-be-used-for-other-.patch --]
[-- Type: text/plain, Size: 12700 bytes --]
From a34283b098dd50a35ddfa92e7f384b54956353da Mon Sep 17 00:00:00 2001
From: Gemini Lasswell <gazally@runbox.com>
Date: Sun, 1 Oct 2017 09:12:29 -0700
Subject: [PATCH 1/2] Allow Edebug's instrumentation to be used for other
purposes
* lisp/emacs-lisp/edebug.el:
(edebug-after-instrumentation-functions)
(edebug-new-definition-functions): New hook variables.
(edebug-behavior-alist): New variable.
(edebug-read-and-maybe-wrap-form): Run a hook after a form is
wrapped.
(edebug-make-form-wrapper): Run a hook after a definition is
wrapped. Remove message for each definition.
(edebug-announce-definition): New function.
(edebug-enter): Rewritten to change behavior of Edebug based
on symbol property `edebug-behavior' and `edebug-behavior-alist'.
(edebug-default-enter): New function which does what `edebug-enter'
used to do.
(edebug-run-slow, edebug-run-fast): Modify edebug-behavior-alist.
(edebug-before, edebug-after): Function definitions are now set by
`edebug-enter'.
---
doc/lispref/edebug.texi | 35 +++++++++++
etc/NEWS | 9 +++
lisp/emacs-lisp/edebug.el | 154 ++++++++++++++++++++++++++++++----------------
3 files changed, 146 insertions(+), 52 deletions(-)
diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index cebf0a3af3..94d61480f1 100644
--- a/doc/lispref/edebug.texi
+++ b/doc/lispref/edebug.texi
@@ -1690,3 +1690,38 @@ Edebug Options
a breakpoint. Set to @code{nil} to prevent the pause, non-@code{nil}
to allow it.
@end defopt
+
+@defopt edebug-behavior-alist
+By default, this alist contains one entry with the key @code{edebug}
+and a list of three functions, which are the default implementations
+of the functions inserted in instrumented code: @code{edebug-enter},
+@code{edebug-before} and @code{edebug-after}. To change Edebug's
+behavior globally, modify the default entry.
+
+Edebug's behavior may also be changed on a per-definition basis by
+adding an entry to this alist, with a key of your choice and three
+functions. Then set the @code{edebug-behavior} symbol property of an
+instrumented definition to the key of the new entry, and Edebug will
+call the new functions in place of its own for that definition.
+@end defopt
+
+@defopt edebug-new-definition-functions
+An abnormal hook run by Edebug after it wraps the body of a definition
+or closure. After Edebug has initialized its own data, each function
+is called with one argument, the symbol associated with the
+definition, which may be the actual symbol defined or one generated by
+Edebug. This hook may be used to set the @code{edebug-behavior}
+symbol property of each definition instrumented by Edebug.
+
+By default @code{edebug-new-definition-functions} contains
+@code{edebug-announce-definition} which prints a message each time a
+definition is instrumented. If you are instrumenting a lot of code
+and find the messages excessive, remove
+@code{edebug-announce-definition}.
+@end defopt
+
+@defopt edebug-after-instrumentation-functions
+An abnormal hook run by Edebug after it instruments a form.
+Each function is called with one argument, a form which has
+just been instrumented by Edebug.
+@end defopt
diff --git a/etc/NEWS b/etc/NEWS
index 42c1b04816..b0cb0ae495 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -50,6 +50,15 @@ replaced by a double typographic quote.
\f
* Changes in Specialized Modes and Packages in Emacs 27.1
+** Edebug
+
++++
+*** The runtime behavior of Edebug's instrumentation can be changed
+using the new variable 'edebug-behavior-alist' and the new abnormal
+hooks 'edebug-after-instrumentation-functions' and
+'edebug-new-definition-functions'. Edebug's behavior can be changed
+globally or for individual definitions.
+
** Enhanced xterm support
*** New variable 'xterm-set-window-title' controls whether Emacs
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index dbc56e272f..a070ff25d1 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -1065,6 +1065,31 @@ edebug-old-def-name
(defvar edebug-error-point nil)
(defvar edebug-best-error nil)
+;; Hooks which may be used to extend Edebug's functionality. See
+;; Testcover for an example.
+(defvar edebug-after-instrumentation-functions nil
+ "Abnormal hook run on code after instrumentation for debugging.
+Each function is called with one argument, a form which has just
+been instrumented for Edebugging.")
+
+(defvar edebug-new-definition-functions '(edebug-announce-definition)
+ "Abnormal hook run after Edebug wraps a new definition.
+After Edebug has initialized its own data, each hook function is
+called with one argument, the symbol associated with the
+definition, which may be the actual symbol defined or one
+generated by Edebug.")
+
+(defvar edebug-behavior-alist
+ '((edebug edebug-default-enter edebug-slow-before edebug-slow-after))
+ "Alist describing the runtime behavior of Edebug's instrumented code.
+Each definition instrumented by Edebug will have a
+`edebug-behavior' property which is a key to this alist. When
+the instrumented code is running, Edebug will look here for the
+implementations of `edebug-enter', `edebug-before', and
+`edebug-after'. Edebug's instrumentation may be used for a new
+purpose by adding an entry to this alist and a hook to
+`edebug-new-definition-functions' which sets `edebug-behavior'
+for the definition.")
(defun edebug-read-and-maybe-wrap-form ()
;; Read a form and wrap it with edebug calls, if the conditions are right.
@@ -1124,47 +1149,48 @@ edebug-read-and-maybe-wrap-form1
(eq 'symbol (edebug-next-token-class)))
(read (current-buffer))))))
;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms)
- (cond
- (defining-form-p
- (if (or edebug-all-defs edebug-all-forms)
- ;; If it is a defining form and we are edebugging defs,
- ;; then let edebug-list-form start it.
- (let ((cursor (edebug-new-cursor
- (list (edebug-read-storing-offsets (current-buffer)))
- (list edebug-offsets))))
- (car
- (edebug-make-form-wrapper
- cursor
- (edebug-before-offset cursor)
- (1- (edebug-after-offset cursor))
- (list (cons (symbol-name def-kind) (cdr spec))))))
-
- ;; Not edebugging this form, so reset the symbol's edebug
- ;; property to be just a marker at the definition's source code.
- ;; This only works for defs with simple names.
- (put def-name 'edebug (point-marker))
- ;; Also nil out dependent defs.
- '(mapcar (function
- (lambda (def)
- (put def-name 'edebug nil)))
- (get def-name 'edebug-dependents))
- (edebug-read-sexp)))
-
- ;; If all forms are being edebugged, explicitly wrap it.
- (edebug-all-forms
- (let ((cursor (edebug-new-cursor
- (list (edebug-read-storing-offsets (current-buffer)))
- (list edebug-offsets))))
- (edebug-make-form-wrapper
- cursor
- (edebug-before-offset cursor)
- (edebug-after-offset cursor)
- nil)))
-
- ;; Not a defining form, and not edebugging.
- (t (edebug-read-sexp)))
- ))
-
+ (let ((result
+ (cond
+ (defining-form-p
+ (if (or edebug-all-defs edebug-all-forms)
+ ;; If it is a defining form and we are edebugging defs,
+ ;; then let edebug-list-form start it.
+ (let ((cursor (edebug-new-cursor
+ (list (edebug-read-storing-offsets (current-buffer)))
+ (list edebug-offsets))))
+ (car
+ (edebug-make-form-wrapper
+ cursor
+ (edebug-before-offset cursor)
+ (1- (edebug-after-offset cursor))
+ (list (cons (symbol-name def-kind) (cdr spec))))))
+
+ ;; Not edebugging this form, so reset the symbol's edebug
+ ;; property to be just a marker at the definition's source code.
+ ;; This only works for defs with simple names.
+ (put def-name 'edebug (point-marker))
+ ;; Also nil out dependent defs.
+ '(mapcar (function
+ (lambda (def)
+ (put def-name 'edebug nil)))
+ (get def-name 'edebug-dependents))
+ (edebug-read-sexp)))
+
+ ;; If all forms are being edebugged, explicitly wrap it.
+ (edebug-all-forms
+ (let ((cursor (edebug-new-cursor
+ (list (edebug-read-storing-offsets (current-buffer)))
+ (list edebug-offsets))))
+ (edebug-make-form-wrapper
+ cursor
+ (edebug-before-offset cursor)
+ (edebug-after-offset cursor)
+ nil)))
+
+ ;; Not a defining form, and not edebugging.
+ (t (edebug-read-sexp)))))
+ (run-hook-with-args 'edebug-after-instrumentation-functions result)
+ result)))
(defvar edebug-def-args) ; args of defining form.
(defvar edebug-def-interactive) ; is it an emacs interactive function?
@@ -1332,7 +1358,6 @@ edebug-make-form-wrapper
;; (message "defining: %s" edebug-def-name) (sit-for 2)
(edebug-make-top-form-data-entry form-data-entry)
- (message "Edebug: %s" edebug-def-name)
;;(debug edebug-def-name)
;; Destructively reverse edebug-offset-list and make vector from it.
@@ -1358,9 +1383,15 @@ edebug-make-form-wrapper
edebug-offset-list
edebug-top-window-data
))
+ (put edebug-def-name 'edebug-behavior 'edebug)
+ (run-hook-with-args 'edebug-new-definition-functions edebug-def-name)
result
)))
+(defun edebug-announce-definition (def-name)
+ "Announce Edebug's processing of DEF-NAME."
+ (message "Edebug: %s" def-name))
+
(defun edebug-clear-frequency-count (name)
;; Create initial frequency count vector.
@@ -2167,7 +2198,21 @@ edebug-signal
;;; Entering Edebug
-(defun edebug-enter (function args body)
+(defun edebug-enter (func args body)
+ "Enter Edebug for a function.
+FUNC should be the symbol with the Edebug information, ARGS is
+the list of arguments and BODY is the code.
+
+Look up the `edebug-behavior' for FUNC in `edebug-behavior-alist'
+and run its entry function, and set up `edebug-before' and
+`edebug-after'."
+ (cl-letf* ((behavior (get func 'edebug-behavior))
+ (functions (cdr (assoc behavior edebug-behavior-alist)))
+ ((symbol-function #'edebug-before) (nth 1 functions))
+ ((symbol-function #'edebug-after) (nth 2 functions)))
+ (funcall (nth 0 functions) func args body)))
+
+(defun edebug-default-enter (function args body)
;; Entering FUNC. The arguments are ARGS, and the body is BODY.
;; Setup edebug variables and evaluate BODY. This function is called
;; when a function evaluated with edebug-eval-top-level-form is entered.
@@ -2198,7 +2243,7 @@ edebug-enter
edebug-initial-mode
edebug-execution-mode)
edebug-next-execution-mode nil)
- (edebug-enter function args body))))
+ (edebug-default-enter function args body))))
(let* ((edebug-data (get function 'edebug))
(edebug-def-mark (car edebug-data)) ; mark at def start
@@ -2317,22 +2362,27 @@ edebug-slow-after
value
(edebug-debugger after-index 'after value)
)))
-
(defun edebug-fast-after (_before-index _after-index value)
;; Do nothing but return the value.
value)
(defun edebug-run-slow ()
- (defalias 'edebug-before 'edebug-slow-before)
- (defalias 'edebug-after 'edebug-slow-after))
+ "Set up Edebug's normal behavior."
+ (setf (cdr (assq 'edebug edebug-behavior-alist))
+ '(edebug-default-enter edebug-slow-before edebug-slow-after)))
;; This is not used, yet.
(defun edebug-run-fast ()
- (defalias 'edebug-before 'edebug-fast-before)
- (defalias 'edebug-after 'edebug-fast-after))
-
-(edebug-run-slow)
-
+ "Disable Edebug without de-instrumenting code."
+ (setf (cdr (assq 'edebug edebug-behavior-alist))
+ '(edebug-default-enter edebug-fast-before edebug-fast-after)))
+
+(defalias 'edebug-before nil
+ "Function called by Edebug before a form is evaluated.
+See `edebug-behavior-alist' for implementations.")
+(defalias 'edebug-after nil
+ "Function called by Edebug after a form is evaluated.
+See `edebug-behavior-alist' for implementations.")
(defun edebug--update-coverage (after-index value)
(let ((old-result (aref edebug-coverage after-index)))
--
2.14.1
[-- Attachment #3: 0002-Rewrite-Testcover-s-internals-fixing-several-bugs.patch --]
[-- Type: text/plain, Size: 48581 bytes --]
From 8529ae90d673082633994698078a14bebf17d868 Mon Sep 17 00:00:00 2001
From: Gemini Lasswell <gazally@runbox.com>
Date: Mon, 25 Sep 2017 13:45:07 -0700
Subject: [PATCH 2/2] Rewrite Testcover's internals, fixing several bugs
* lisp/emacs-lisp/testcover.el: Rewrite the internals of Testcover
to analyze instrumented code instead of reinstrumenting it. Use new
hooks in Edebug to collect code coverage information at runtime
using Edebug's instrumentation.
Includes fixes for: (bug#11307) (bug#24509) (bug#24688) (bug#24743)
(bug#25316) (bug#25326).
(testcover-compose-functions): Remove mapcar.
(testcover-start, testcover-this-defun): Analyze code instead of
reinstrumenting it. Set edebug-behavior for each definition.
(testcover--read, testcover-1value, testcover-reinstrument)
(testcover-reinstrument-list, testcover-reinstrument-compose):
Deleted.
(testcover-after-instrumentation, testcover-init-definition)
(testcover-before): New functions.
(testcover-enter): Change call signature to match edebug-enter.
(testcover-after, testcover-mark): Add handling of 'maybe and
'noreturn.
(testcover-analyze-coverage, testcover-analyze-coverage-progn)
(testcover-analyze-coverage-edebug-after)
(testcover-analyze-coverage-wrapped-form)
(testcover-analyze-coverage-wrapped-application)
(testcover-analyze-coverage-compose)
(testcover-analyze-coverage-backquote)
(testcover-analyze-coverage-backquote-form)
(testcover-coverage-combine): New functions to analyze instrumented
code.
* lisp/emacs-lisp/gv.el: Modify edebug-after's gv-expander to
instrument in the setter as well as the getter.
* test/lisp/emacs-lisp/testcover-tests.el
(testcover-tests-run-test-case): Use `edebug-default-enter'
instead of `edebug-enter' to detect Edebug invocation
during tests.
* test/lisp/emacs-lisp/testcover-resources/testcases.el
(constants-bug-25316)
(customize-defcustom-bug-25326)
(1-value-symbol-bug-25316)
(quotes-within-backquotes-bug-25316)
(backquote-1value-bug-24509)
(pcase-bug-24688)
(defun-in-backquote-bug-11307-and-24743)
(closure-1value-bug)
(backquoted-vector-bug-25316)
(vector-in-macro-spec-bug-25316)
(mapcar-is-not-compose): Remove expected failure tags.
(function-with-edebug-spec-bug-25316): Remove expected failure tag
and modify expected result.
(quoted-backquote): New test.
* lisp/textmodes/rst.el: Remove workarounds for bugs in Testcover.
(rst-testcover-defcustom): Deleted.
* lisp/subr.el (1value): Remove incorrect description of
testcover-1value from docstring, replace with description of
Testcover's treatment of 1value.
---
lisp/emacs-lisp/gv.el | 4 +-
lisp/emacs-lisp/testcover.el | 658 ++++++++++++---------
lisp/subr.el | 4 +-
lisp/textmodes/rst.el | 47 --
.../emacs-lisp/testcover-resources/testcases.el | 29 +-
test/lisp/emacs-lisp/testcover-tests.el | 12 +-
6 files changed, 392 insertions(+), 362 deletions(-)
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 892d6e9716..777b955d90 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -303,7 +303,9 @@ setf
(lambda (do before index place)
(gv-letplace (getter setter) place
(funcall do `(edebug-after ,before ,index ,getter)
- setter))))
+ (lambda (store)
+ `(progn (edebug-after ,before ,index ,getter)
+ ,(funcall setter store)))))))
;;; The common generalized variables.
diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el
index 691860bbd7..320c43b59f 100644
--- a/lisp/emacs-lisp/testcover.el
+++ b/lisp/emacs-lisp/testcover.el
@@ -33,7 +33,9 @@
;; that has a splotch.
;; * Basic algorithm: use `edebug' to mark up the function text with
-;; instrumentation callbacks, then replace edebug's callbacks with ours.
+;; instrumentation callbacks, walk the instrumented code looking for
+;; forms which don't return or always return the same value, then use
+;; Edebug's before and after hooks to replace its code coverage with ours.
;; * To show good coverage, we want to see two values for every form, except
;; functions that always return the same value and `defconst' variables
;; need show only one value for good coverage. To avoid the brown
@@ -89,16 +91,14 @@ testcover-1value-functions
buffer-disable-undo buffer-enable-undo current-global-map
deactivate-mark delete-backward-char delete-char delete-region ding
forward-char function* insert insert-and-inherit kill-all-local-variables
- kill-line kill-paragraph kill-region kill-sexp lambda
+ kill-line kill-paragraph kill-region kill-sexp
minibuffer-complete-and-exit narrow-to-region next-line push-mark
put-text-property run-hooks set-match-data signal
substitute-key-definition suppress-keymap undo use-local-map while widen
yank)
- "Functions that always return the same value. No brown splotch is shown
-for these. This list is quite incomplete! Notes: Nobody ever changes the
-current global map. The macro `lambda' is self-evaluating, hence always
-returns the same value (the function it defines may return varying values
-when called)."
+ "Functions that always return the same value, according to `equal'.
+No brown splotch is shown for these. This list is quite
+incomplete! Notes: Nobody ever changes the current global map."
:group 'testcover
:type '(repeat symbol))
@@ -111,7 +111,7 @@ testcover-noreturn-functions
(defcustom testcover-compose-functions
'(+ - * / = append length list make-keymap make-sparse-keymap
- mapcar message propertize replace-regexp-in-string
+ message propertize replace-regexp-in-string
run-with-idle-timer set-buffer-modified-p)
"Functions that are 1-valued if all their args are either constants or
calls to one of the `testcover-1value-functions', so if that's true then no
@@ -186,19 +186,21 @@ testcover-vector
;;;###autoload
(defun testcover-start (filename &optional byte-compile)
- "Uses edebug to instrument all macros and functions in FILENAME, then
-changes the instrumentation from edebug to testcover--much faster, no
-problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is
-non-nil, byte-compiles each function after instrumenting."
+ "Use Edebug to instrument for coverage all macros and functions in FILENAME.
+If BYTE-COMPILE is non-nil, byte compile each function after instrumenting."
(interactive "fStart covering file: ")
- (let ((buf (find-file filename))
- (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)
- (eval-buffer buf))
+ (let ((buf (find-file filename)))
+ (setq edebug-form-data nil
+ testcover-module-constants nil
+ testcover-module-1value-functions nil
+ testcover-module-potentially-1value-functions nil)
+ (cl-letf ((edebug-all-defs t)
+ (edebug-after-instrumentation-functions)
+ (edebug-new-definition-functions))
+ (add-hook 'edebug-after-instrumentation-functions 'testcover-after-instrumentation)
+ (add-hook 'edebug-new-definition-functions 'testcover-init-definition)
+ (remove-hook 'edebug-new-definition-functions 'edebug-announce-definition)
+ (eval-buffer buf)))
(when byte-compile
(dolist (x (reverse edebug-form-data))
(when (fboundp (car x))
@@ -209,229 +211,13 @@ testcover-start
(defun testcover-this-defun ()
"Start coverage on function under point."
(interactive)
- (let ((x (let ((edebug-all-defs t))
- (symbol-function (eval-defun nil)))))
- (testcover-reinstrument x)
- x))
-
-(defun testcover--read (orig &optional stream)
- "Read a form using edebug, changing edebug callbacks to testcover callbacks."
- (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 values, t if should always return same
-value, `maybe' if either is acceptable."
- (let ((fun (car-safe form))
- id val)
- (cond
- ((not fun) ;Atom
- (when (or (not (symbolp form))
- (memq form testcover-constants)
- (memq form testcover-module-constants))
- t))
- ((consp fun) ;Embedded list
- (testcover-reinstrument fun)
- (testcover-reinstrument-list (cdr form))
- nil)
- ((or (memq fun testcover-1value-functions)
- (memq fun testcover-module-1value-functions))
- ;;Should always return same value
- (testcover-reinstrument-list (cdr form))
- t)
- ((or (memq fun testcover-potentially-1value-functions)
- (memq fun testcover-module-potentially-1value-functions))
- ;;Might always return same value
- (testcover-reinstrument-list (cdr form))
- 'maybe)
- ((memq fun testcover-progn-functions)
- ;;1-valued if last argument is
- (testcover-reinstrument-list (cdr form)))
- ((memq fun testcover-prog1-functions)
- ;;1-valued if first argument is
- (testcover-reinstrument-list (cddr form))
- (testcover-reinstrument (cadr form)))
- ((memq fun testcover-compose-functions)
- ;;1-valued if all arguments are. Potentially 1-valued if all
- ;;arguments are either definitely or potentially.
- (testcover-reinstrument-compose (cdr form) 'testcover-reinstrument))
- ((eq fun 'edebug-enter)
- ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS))
- ;; => (testcover-enter 'SYM #'(lambda nil FORMS))
- (setcar form 'testcover-enter)
- (setcdr (nthcdr 1 form) (nthcdr 3 form))
- (let ((testcover-vector (get (cadr (cadr form)) 'edebug-coverage)))
- (testcover-reinstrument-list (nthcdr 2 (cadr (nth 2 form))))))
- ((eq fun 'edebug-after)
- ;;(edebug-after (edebug-before XXX) YYY FORM)
- ;; => (testcover-after YYY FORM), mark XXX as ok-coverage
- (unless (eq (cadr form) 0)
- (aset testcover-vector (cadr (cadr form)) 'ok-coverage))
- (setq id (nth 2 form))
- (setcdr form (nthcdr 2 form))
- (setq val (testcover-reinstrument (nth 2 form)))
- (setcar form (if (eq val t)
- 'testcover-1value
- 'testcover-after))
- (when val
- ;;1-valued or potentially 1-valued
- (aset testcover-vector id '1value))
- (cond
- ((memq (car-safe (nth 2 form)) testcover-noreturn-functions)
- ;;This function won't return, so set the value in advance
- ;;(edebug-after (edebug-before XXX) YYY FORM)
- ;; => (progn (edebug-after YYY nil) FORM)
- (setcar (cdr form) `(,(car form) ,id nil))
- (setcar form 'progn)
- (aset testcover-vector id '1value)
- (setq val t))
- ((eq (car-safe (nth 2 form)) '1value)
- ;;This function is always supposed to return the same value
- (setq val t)
- (aset testcover-vector id '1value)
- (setcar form 'testcover-1value)))
- val)
- ((eq fun 'defun)
- (setq val (testcover-reinstrument-list (nthcdr 3 form)))
- (when (eq val t)
- (push (cadr form) testcover-module-1value-functions))
- (when (eq val 'maybe)
- (push (cadr form) testcover-module-potentially-1value-functions)))
- ((memq fun '(defconst defcustom))
- ;;Define this symbol as 1-valued
- (push (cadr form) testcover-module-constants)
- (testcover-reinstrument-list (cddr form)))
- ((memq fun '(dotimes dolist))
- ;;Always returns third value from SPEC
- (testcover-reinstrument-list (cddr form))
- (setq val (testcover-reinstrument-list (cadr form)))
- (if (nth 2 (cadr form))
- val
- ;;No third value, always returns nil
- t))
- ((memq fun '(let let*))
- ;;Special parsing for second argument
- (mapc 'testcover-reinstrument-list (cadr form))
- (testcover-reinstrument-list (cddr form)))
- ((eq fun 'if)
- ;;Potentially 1-valued if both THEN and ELSE clauses are
- (testcover-reinstrument (cadr form))
- (let ((then (testcover-reinstrument (nth 2 form)))
- (else (testcover-reinstrument-list (nthcdr 3 form))))
- (and then else 'maybe)))
- ((eq fun 'cond)
- ;;Potentially 1-valued if all clauses are
- (when (testcover-reinstrument-compose (cdr form)
- 'testcover-reinstrument-list)
- 'maybe))
- ((eq fun 'condition-case)
- ;;Potentially 1-valued if BODYFORM is and all HANDLERS are
- (let ((body (testcover-reinstrument (nth 2 form)))
- (errs (testcover-reinstrument-compose
- (mapcar #'cdr (nthcdr 3 form))
- 'testcover-reinstrument-list)))
- (and body errs 'maybe)))
- ((eq fun 'quote)
- ;;Don't reinstrument what's inside!
- ;;This doesn't apply within a backquote
- t)
- ((eq fun '\`)
- ;;Quotes are not special within backquotes
- (let ((testcover-1value-functions
- (cons 'quote testcover-1value-functions)))
- (testcover-reinstrument (cadr form))))
- ((eq fun '\,)
- ;;In commas inside backquotes, quotes are special again
- (let ((testcover-1value-functions
- (remq 'quote testcover-1value-functions)))
- (testcover-reinstrument (cadr form))))
- ((eq fun '1value)
- ;;Hack - pretend the arg is 1-valued here
- (cond
- ((symbolp (cadr form))
- ;;A pseudoconstant variable
- t)
- ((and (eq (car (cadr form)) 'edebug-after)
- (symbolp (nth 3 (cadr form))))
- ;;Reference to pseudoconstant
- (aset testcover-vector (nth 2 (cadr form)) '1value)
- (setcar (cdr form) `(testcover-1value ,(nth 2 (cadr form))
- ,(nth 3 (cadr form))))
- t)
- (t
- (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))))))
- ((eq fun 'noreturn)
- ;;Hack - pretend the arg has no return
- (cond
- ((symbolp (cadr form))
- ;;A pseudoconstant variable
- 'maybe)
- ((and (eq (car (cadr form)) 'edebug-after)
- (symbolp (nth 3 (cadr form))))
- ;;Reference to pseudoconstant
- (aset testcover-vector (nth 2 (cadr form)) '1value)
- (setcar (cdr form) `(progn (testcover-after ,(nth 2 (cadr form)) nil)
- ,(nth 3 (cadr form))))
- 'maybe)
- (t
- (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))))))
- ((and (eq fun 'apply)
- (eq (car-safe (cadr form)) 'quote)
- (symbolp (cadr (cadr form))))
- ;;Apply of a constant symbol. Process as 1value or noreturn
- ;;depending on symbol.
- (setq fun (cons (cadr (cadr form)) (cddr form))
- val (testcover-reinstrument fun))
- (setcdr (cdr form) (cdr fun))
- val)
- (t ;Some other function or weird thing
- (testcover-reinstrument-list (cdr form))
- nil))))
-
-(defun testcover-reinstrument-list (list)
- "Reinstruments each form in LIST to use testcover instead of edebug.
-This function modifies the forms in LIST. Result is `testcover-reinstrument's
-value for the last form in LIST. If the LIST is empty, its evaluation will
-always be nil, so we return t for 1-valued."
- (let ((result t))
- (while (consp list)
- (setq result (testcover-reinstrument (pop list))))
- result))
-
-(defun testcover-reinstrument-compose (list fun)
- "For a compositional function, the result is 1-valued if all
-arguments are, potentially 1-valued if all arguments are either
-definitely or potentially 1-valued, and multi-valued otherwise.
-FUN should be `testcover-reinstrument' for compositional functions,
- `testcover-reinstrument-list' for clauses in a `cond'."
- (let ((result t))
- (mapc #'(lambda (x)
- (setq x (funcall fun x))
- (cond
- ((eq result t)
- (setq result x))
- ((eq result 'maybe)
- (when (not x)
- (setq result nil)))))
- list)
- result))
+ (cl-letf ((edebug-all-defs t)
+ (edebug-after-instrumentation-functions)
+ (edebug-new-definition-functions))
+ (add-hook 'edebug-after-instrumentation-functions 'testcover-after-instrumentation)
+ (add-hook 'edebug-new-definition-functions 'testcover-init-definition)
+ (remove-hook 'edebug-new-definition-functions 'edebug-announce-definition)
+ (eval-defun nil)))
(defun testcover-end (filename)
"Turn off instrumentation of all macros and functions in FILENAME."
@@ -444,48 +230,61 @@ testcover-end
;;; Accumulate coverage data
;;;=========================================================================
-(defun testcover-enter (testcover-sym testcover-fun)
- "Internal function for coverage testing. Invokes TESTCOVER-FUN while
-binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM
-\(the name of the current function)."
- (let ((testcover-vector (get testcover-sym 'edebug-coverage)))
- (funcall testcover-fun)))
-
-(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))
- ((not (condition-case ()
- (equal (aref testcover-vector idx) val)
- ;; TODO: Actually check circular lists for equality.
- (circular-list nil)))
- (aset testcover-vector idx 'ok-coverage)))
- val)
-
-(defun testcover-1value (idx val)
- "Internal function for coverage testing. Returns VAL after installing it in
-`testcover-vector' at offset IDX. Error if FORM does not always return the
-same value during coverage testing."
- (cond
- ((eq (aref testcover-vector idx) '1value)
- (aset testcover-vector idx (cons '1value val)))
- ((not (and (eq (car-safe (aref testcover-vector idx)) '1value)
- (condition-case ()
- (equal (cdr (aref testcover-vector idx)) val)
- ;; TODO: Actually check circular lists for equality.
- (circular-list nil))))
- (error "Value of form marked with `1value' does vary: %s" val)))
- val)
-
-
+(defun testcover-after-instrumentation (form)
+ "Analyze FORM for code coverage."
+ (testcover-analyze-coverage form))
+
+(defun testcover-init-definition (sym)
+ "Mark SYM as under test coverage."
+ (message "Testcover: %s" edebug-def-name)
+ (put sym 'edebug-behavior 'testcover))
+
+(defun testcover-enter (func _args body)
+ "Begin execution of a function under coverage testing.
+Bind `testcover-vector' to the code-coverage vector for FUNC and
+return the result of evaluating BODY."
+ (let ((testcover-vector (get func 'edebug-coverage)))
+ (funcall body)))
+
+(defun testcover-before (before-index)
+ "Update code coverage before a form is evaluated.
+BEFORE-INDEX is the form's index into the code-coverage vector."
+ (let ((before-entry (aref testcover-vector before-index)))
+ (when (eq (car-safe before-entry) 'noreturn)
+ (let* ((after-index (cdr before-entry)))
+ (aset testcover-vector after-index 'ok-coverage)))))
+
+(defun testcover-after (_before-index after-index value)
+ "Update code coverage with the result of a form's evaluation.
+AFTER-INDEX is the form's index into the code-coverage
+vector. Return VALUE."
+ (let ((old-result (aref testcover-vector after-index)))
+ (cond
+ ((eq 'unknown old-result)
+ (aset testcover-vector after-index value))
+ ((eq 'maybe old-result)
+ (aset testcover-vector after-index 'ok-coverage))
+ ((eq '1value old-result)
+ (aset testcover-vector after-index
+ (cons old-result value)))
+ ((and (eq (car-safe old-result) '1value)
+ (not (condition-case ()
+ (equal (cdr old-result) value)
+ ;; TODO: Actually check circular lists for equality.
+ (circular-list t))))
+ (error "Value of form marked with `1value' does vary: %s" value))
+ ;; Test if a different result.
+ ((not (condition-case ()
+ (equal value old-result)
+ ;; TODO: Actually check circular lists for equality.
+ (circular-list nil)))
+ (aset testcover-vector after-index 'ok-coverage))))
+ value)
+
+;; Add these behaviors to Edebug.
+(unless (assoc 'testcover edebug-behavior-alist)
+ (push '(testcover testcover-enter testcover-before testcover-after)
+ edebug-behavior-alist))
;;;=========================================================================
;;; Display the coverage data as color splotches on your code.
@@ -517,12 +316,13 @@ testcover-mark
(while (> len 0)
(setq len (1- len)
data (aref coverage len))
- (when (and (not (eq data 'ok-coverage))
- (not (eq (car-safe data) '1value))
- (setq j (+ def-mark (aref points len))))
+ (when (and (not (eq data 'ok-coverage))
+ (not (memq (car-safe data)
+ '(1value maybe noreturn)))
+ (setq j (+ def-mark (aref points len))))
(setq ov (make-overlay (1- j) j))
(overlay-put ov 'face
- (if (memq data '(unknown 1value))
+ (if (memq data '(unknown maybe 1value))
'testcover-nohits
'testcover-1value))))
(set-buffer-modified-p changed))))
@@ -553,4 +353,284 @@ testcover-next-mark
(goto-char (next-overlay-change (point)))
(end-of-line))
+
+;;; Coverage Analysis
+
+;; The top level function for initializing code coverage is
+;; `testcover-analyze-coverage', which recursively walks the form it is
+;; passed, which should have already been instrumented by
+;; edebug-read-and-maybe-wrap-form, and initializes the associated
+;; code coverage vectors, which should have already been created by
+;; `edebug-clear-coverage'.
+;;
+;; The purpose of the analysis is to identify forms which can only
+;; ever return a single value. These forms can be considered to have
+;; adequate code coverage even if only executed once. In addition,
+;; forms which will never return, such as error signals, can be
+;; identified and treated correctly.
+;;
+;; The code coverage vector entries for the beginnings of forms will
+;; be changed to `ok-coverage.', except for the beginnings of forms
+;; which should never return, which will be changed to
+;; (noreturn . AFTER-INDEX) so that testcover-before can set the entry
+;; for the end of the form just before it is executed.
+;;
+;; Entries for the ends of forms may be changed to `1value' if
+;; analysis determines the form will only ever return a single value,
+;; or `maybe' if the form could potentially only ever return a single
+;; value.
+;;
+;; An example of a potentially 1-valued form is an `and' whose last
+;; term is 1-valued, in case the last term is always nil. Example:
+;;
+;; (and (< (point) 1000) (forward-char 10))
+;;
+;; This form always returns nil. Similarly, `or', `if', and `cond'
+;; are treated as potentially 1-valued if all clauses are, in case
+;; those values are always nil. Unlike truly 1-valued functions, it
+;; is not an error if these "potentially" 1-valued forms actually
+;; return differing values.
+
+(defun testcover-analyze-coverage (form)
+ "Analyze FORM and initialize coverage vectors for definitions found within.
+Return 1value, maybe or nil depending on if the form is determined
+to return only a single value, potentially return only a single value,
+or return multiple values."
+ (pcase form
+ (`(edebug-enter ',sym ,_ (function (lambda nil . ,body)))
+ (let ((testcover-vector (get sym 'edebug-coverage)))
+ (testcover-analyze-coverage-progn body)))
+
+ (`(edebug-after ,(and before-form
+ (or `(edebug-before ,before-id) before-id))
+ ,after-id ,wrapped-form)
+ (testcover-analyze-coverage-edebug-after
+ form before-form before-id after-id wrapped-form))
+
+ (`(defconst ,sym . ,args)
+ (push sym testcover-module-constants)
+ (testcover-analyze-coverage-progn args)
+ '1value)
+
+ (`(defun ,name ,_ . ,doc-and-body)
+ (let ((val (testcover-analyze-coverage-progn doc-and-body)))
+ (cl-case val
+ ((1value) (push name testcover-module-1value-functions))
+ ((maybe) (push name testcover-module-potentially-1value-functions)))
+ nil))
+
+ (`(quote . ,_)
+ ;; A quoted form is 1value. Edebug could have instrumented
+ ;; something inside the form if an Edebug spec contained a quote.
+ ;; It's also possible that the quoted form is a circular object.
+ ;; To avoid infinite recursion, don't examine quoted objects.
+ ;; This will cause the coverage marks on an instrumented quoted
+ ;; form to look odd. See bug#25316.
+ '1value)
+
+ (`(\` ,bq-form)
+ (testcover-analyze-coverage-backquote-form bq-form))
+
+ ((or 't 'nil (pred keywordp))
+ '1value)
+
+ ((pred vectorp)
+ (testcover-analyze-coverage-compose (append form nil)
+ #'testcover-analyze-coverage))
+
+ ((pred symbolp)
+ nil)
+
+ ((pred atom)
+ '1value)
+
+ (_
+ ;; Whatever we have here, it's not wrapped, so treat it as a list of forms.
+ (testcover-analyze-coverage-compose form #'testcover-analyze-coverage))))
+
+(defun testcover-analyze-coverage-progn (forms)
+ "Analyze FORMS, which should be a list of forms, for code coverage.
+Analyze all the forms in FORMS and return 1value, maybe or nil
+depending on the analysis of the last one. Find the coverage
+vectors referenced by `edebug-enter' forms nested within FORMS and
+update them with the results of the analysis."
+ (let ((result '1value))
+ (while (consp forms)
+ (setq result (testcover-analyze-coverage (pop forms))))
+ result))
+
+(defun testcover-analyze-coverage-edebug-after (_form before-form before-id
+ after-id wrapped-form
+ &optional wrapper)
+ "Analyze a _FORM wrapped by `edebug-after' for code coverage.
+_FORM should be either:
+ (edebug-after (edebug-before BEFORE-ID) AFTER-ID WRAPPED-FORM)
+or:
+ (edebug-after 0 AFTER-ID WRAPPED-FORM)
+
+where BEFORE-FORM is bound to either (edebug-before BEFORE-ID) or
+0. WRAPPER may be 1value or noreturn, and if so it forces the
+form to be treated accordingly."
+ (let (val)
+ (unless (eql before-form 0)
+ (aset testcover-vector before-id 'ok-coverage))
+
+ (setq val (testcover-analyze-coverage-wrapped-form wrapped-form))
+ (when (or (eq wrapper '1value) val)
+ ;; The form is 1-valued or potentially 1-valued.
+ (aset testcover-vector after-id (or val '1value)))
+
+ (cond
+ ((or (eq wrapper 'noreturn)
+ (memq (car-safe wrapped-form) testcover-noreturn-functions))
+ ;; This function won't return, so indicate to testcover-before that
+ ;; it should record coverage.
+ (aset testcover-vector before-id (cons 'noreturn after-id))
+ (aset testcover-vector after-id '1value)
+ (setq val '1value))
+
+ ((eq (car-safe wrapped-form) '1value)
+ ;; This function is always supposed to return the same value.
+ (setq val '1value)
+ (aset testcover-vector after-id '1value)))
+ val))
+
+(defun testcover-analyze-coverage-wrapped-form (form)
+ "Analyze a FORM for code coverage which was wrapped by `edebug-after'.
+FORM is treated as if it will be evaluated."
+ (pcase form
+ ((pred keywordp)
+ '1value)
+ ((pred symbolp)
+ (when (or (memq form testcover-constants)
+ (memq form testcover-module-constants))
+ '1value))
+ ((pred atom)
+ '1value)
+ (`(\` ,bq-form)
+ (testcover-analyze-coverage-backquote-form bq-form))
+ (`(defconst ,sym ,val . ,_)
+ (push sym testcover-module-constants)
+ (testcover-analyze-coverage val)
+ '1value)
+ (`(,(or 'dotimes 'dolist) (,_ ,expr . ,result) . ,body)
+ ;; These always return RESULT if provided.
+ (testcover-analyze-coverage expr)
+ (testcover-analyze-coverage-progn body)
+ (let ((val (testcover-analyze-coverage-progn result)))
+ ;; If the third value is not present, the loop always returns nil.
+ (if result val '1value)))
+ (`(,(or 'let 'let*) ,bindings . ,body)
+ (testcover-analyze-coverage-progn bindings)
+ (testcover-analyze-coverage-progn body))
+ (`(if ,test ,then-form . ,else-body)
+ ;; `if' is potentially 1-valued if both THEN and ELSE clauses are.
+ (testcover-analyze-coverage test)
+ (let ((then (testcover-analyze-coverage then-form))
+ (else (testcover-analyze-coverage else-body)))
+ (and then else 'maybe)))
+ (`(cond . ,clauses)
+ ;; `cond' is potentially 1-valued if all clauses are.
+ (when (testcover-analyze-coverage-compose clauses #'testcover-analyze-coverage-progn)
+ 'maybe))
+ (`(condition-case ,_ ,body-form . ,handlers)
+ ;; `condition-case' is potentially 1-valued if BODY-FORM is and all
+ ;; HANDLERS are.
+ (let ((body (testcover-analyze-coverage body-form))
+ (errs (testcover-analyze-coverage-compose
+ (mapcar #'cdr handlers)
+ #'testcover-analyze-coverage-progn)))
+ (and body errs 'maybe)))
+ (`(apply (quote ,(and func (pred symbolp))) . ,args)
+ ;; Process application of a constant symbol as 1value or noreturn
+ ;; depending on the symbol.
+ (let ((temp-form (cons func args)))
+ (testcover-analyze-coverage-wrapped-form temp-form)))
+ (`(,(and func (or '1value 'noreturn)) ,inner-form)
+ ;; 1value and noreturn change how the edebug-after they wrap is handled.
+ (let ((val (if (eq func '1value) '1value 'maybe)))
+ (pcase inner-form
+ (`(edebug-after ,(and before-form
+ (or `(edebug-before ,before-id) before-id))
+ ,after-id ,wrapped-form)
+ (testcover-analyze-coverage-edebug-after inner-form before-form
+ before-id after-id
+ wrapped-form func))
+ (_ (testcover-analyze-coverage inner-form)))
+ val))
+ (`(,func . ,args)
+ (testcover-analyze-coverage-wrapped-application func args))))
+
+(defun testcover-analyze-coverage-wrapped-application (func args)
+ "Analyze the application of FUNC to ARGS for code coverage."
+ (cond
+ ((eq func 'quote) '1value)
+ ((or (memq func testcover-1value-functions)
+ (memq func testcover-module-1value-functions))
+ ;; The function should always return the same value.
+ (testcover-analyze-coverage-progn args)
+ '1value)
+ ((or (memq func testcover-potentially-1value-functions)
+ (memq func testcover-module-potentially-1value-functions))
+ ;; The function might always return the same value.
+ (testcover-analyze-coverage-progn args)
+ 'maybe)
+ ((memq func testcover-progn-functions)
+ ;; The function is 1-valued if the last argument is.
+ (testcover-analyze-coverage-progn args))
+ ((memq func testcover-prog1-functions)
+ ;; The function is 1-valued if first argument is.
+ (testcover-analyze-coverage-progn (cdr args))
+ (testcover-analyze-coverage (car args)))
+ ((memq func testcover-compose-functions)
+ ;; The function is 1-valued if all arguments are, and potentially
+ ;; 1-valued if all arguments are either definitely or potentially.
+ (testcover-analyze-coverage-compose args #'testcover-analyze-coverage))
+ (t (testcover-analyze-coverage-progn args)
+ nil)))
+
+(defun testcover-coverage-combine (result val)
+ "Combine RESULT with VAL and return the new result.
+If either argument is nil, return nil, otherwise if either
+argument is maybe, return maybe. Return 1value only if both arguments
+are 1value."
+ (cl-case val
+ (1value result)
+ (maybe (and result 'maybe))
+ (nil nil)))
+
+(defun testcover-analyze-coverage-compose (forms func)
+ "Analyze a list of FORMS for code coverage using FUNC.
+The list is 1valued if all of its constituent elements are also 1valued."
+ (let ((result '1value))
+ (dolist (form forms)
+ (let ((val (funcall func form)))
+ (setq result (testcover-coverage-combine result val))))
+ result))
+
+(defun testcover-analyze-coverage-backquote (bq-list)
+ "Analyze BQ-LIST, the body of a backquoted list, for code coverage."
+ (let ((result '1value))
+ (while (consp bq-list)
+ (let ((form (car bq-list))
+ val)
+ (if (memq form (list '\, '\,@))
+ ;; Correctly handle `(foo bar . ,(baz).
+ (progn
+ (setq val (testcover-analyze-coverage (cdr bq-list)))
+ (setq bq-list nil))
+ (setq val (testcover-analyze-coverage-backquote-form form))
+ (setq bq-list (cdr bq-list)))
+ (setq result (testcover-coverage-combine result val))))
+ result))
+
+(defun testcover-analyze-coverage-backquote-form (form)
+ "Analyze a single FORM from a backquoted list for code coverage."
+ (cond
+ ((vectorp form) (testcover-analyze-coverage-backquote (append form nil)))
+ ((atom form) '1value)
+ ((memq (car form) (list '\, '\,@))
+ (testcover-analyze-coverage (cadr form)))
+ (t (testcover-analyze-coverage-backquote form))))
+
;; testcover.el ends here.
diff --git a/lisp/subr.el b/lisp/subr.el
index cf15ec287f..b6470e2ce7 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -78,8 +78,8 @@ noreturn
(defmacro 1value (form)
"Evaluate FORM, expecting a constant return value.
-This is the global do-nothing version. There is also `testcover-1value'
-that complains if FORM ever does return differing values."
+If FORM returns differing values when running under Testcover,
+Testcover will raise an error."
(declare (debug t))
form)
diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el
index 5534294738..5eb64c82b9 100644
--- a/lisp/textmodes/rst.el
+++ b/lisp/textmodes/rst.el
@@ -128,27 +128,6 @@ cl-type-spec
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Support for `testcover'
-(when (and (boundp 'testcover-1value-functions)
- (boundp 'testcover-compose-functions))
- ;; Below `lambda' is used in a loop with varying parameters and is thus not
- ;; 1valued.
- (setq testcover-1value-functions
- (delq 'lambda testcover-1value-functions))
- (add-to-list 'testcover-compose-functions 'lambda))
-
-(defun rst-testcover-defcustom ()
- "Remove all customized variables from `testcover-module-constants'.
-This seems to be a bug in `testcover': `defcustom' variables are
-considered constants. Revert it with this function after each `defcustom'."
- (when (boundp 'testcover-module-constants)
- (setq testcover-module-constants
- (delq nil
- (mapcar
- #'(lambda (sym)
- (if (not (plist-member (symbol-plist sym) 'standard-value))
- sym))
- testcover-module-constants)))))
-
(defun rst-testcover-add-compose (fun)
"Add FUN to `testcover-compose-functions'."
(when (boundp 'testcover-compose-functions)
@@ -1360,7 +1339,6 @@ rst-mode-hook
The hook for `text-mode' is run before this one."
:group 'rst
:type '(hook))
-(rst-testcover-defcustom)
;; Pull in variable definitions silencing byte-compiler.
(require 'newcomment)
@@ -1557,7 +1535,6 @@ rst-preferred-adornments
(const :tag "Underline only" simple))
(integer :tag "Indentation for overline and underline type"
:value 0))))
-(rst-testcover-defcustom)
;; FIXME: Rename this to `rst-over-and-under-default-indent' and set default to
;; 0 because the effect of 1 is probably surprising in the few cases
@@ -1574,7 +1551,6 @@ rst-default-indent
over-and-under adornments is inconsistent across the buffer."
:group 'rst-adjust
:type '(integer))
-(rst-testcover-defcustom)
(defun rst-new-preferred-hdr (seen prev)
;; testcover: ok.
@@ -2013,7 +1989,6 @@ rst-adjust-hook
:group 'rst-adjust
:type '(hook)
:package-version '(rst . "1.1.0"))
-(rst-testcover-defcustom)
(defcustom rst-new-adornment-down nil
"Controls level of new adornment for section headers."
@@ -2022,7 +1997,6 @@ rst-new-adornment-down
(const :tag "Same level as previous one" nil)
(const :tag "One level down relative to the previous one" t))
:package-version '(rst . "1.1.0"))
-(rst-testcover-defcustom)
(defun rst-adjust-adornment (pfxarg)
"Call `rst-adjust-section' interactively.
@@ -2445,7 +2419,6 @@ rst-preferred-bullets
:tag (char-to-string char) char))
rst-bullets)))
:package-version '(rst . "1.1.0"))
-(rst-testcover-defcustom)
(defun rst-insert-list-continue (ind tag tab prefer-roman)
;; testcover: ok.
@@ -2682,7 +2655,6 @@ rst-toc-indent
Also used for formatting insertion, when numbering is disabled."
:type 'integer
:group 'rst-toc)
-(rst-testcover-defcustom)
(defcustom rst-toc-insert-style 'fixed
"Insertion style for table-of-contents.
@@ -2697,19 +2669,16 @@ rst-toc-insert-style
(const aligned)
(const listed))
:group 'rst-toc)
-(rst-testcover-defcustom)
(defcustom rst-toc-insert-number-separator " "
"Separator that goes between the TOC number and the title."
:type 'string
:group 'rst-toc)
-(rst-testcover-defcustom)
(defcustom rst-toc-insert-max-level nil
"If non-nil, maximum depth of the inserted TOC."
:type '(choice (const nil) integer)
:group 'rst-toc)
-(rst-testcover-defcustom)
(defconst rst-toc-link-keymap
(let ((map (make-sparse-keymap)))
@@ -3174,35 +3143,30 @@ rst-indent-width
"Indentation when there is no more indentation point given."
:group 'rst-indent
:type '(integer))
-(rst-testcover-defcustom)
(defcustom rst-indent-field 3
"Indentation for first line after a field or 0 to always indent for content."
:group 'rst-indent
:package-version '(rst . "1.1.0")
:type '(integer))
-(rst-testcover-defcustom)
(defcustom rst-indent-literal-normal 3
"Default indentation for literal block after a markup on an own line."
:group 'rst-indent
:package-version '(rst . "1.1.0")
:type '(integer))
-(rst-testcover-defcustom)
(defcustom rst-indent-literal-minimized 2
"Default indentation for literal block after a minimized markup."
:group 'rst-indent
:package-version '(rst . "1.1.0")
:type '(integer))
-(rst-testcover-defcustom)
(defcustom rst-indent-comment 3
"Default indentation for first line of a comment."
:group 'rst-indent
:package-version '(rst . "1.1.0")
:type '(integer))
-(rst-testcover-defcustom)
;; FIXME: Must consider other tabs:
;; * Line blocks
@@ -3652,7 +3616,6 @@ rst-block-face
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-block-face
"customize the face `rst-block' instead."
"24.1")
@@ -3667,7 +3630,6 @@ rst-external-face
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-external-face
"customize the face `rst-external' instead."
"24.1")
@@ -3682,7 +3644,6 @@ rst-definition-face
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-definition-face
"customize the face `rst-definition' instead."
"24.1")
@@ -3699,7 +3660,6 @@ rst-directive-face
"Directives and roles."
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-directive-face
"customize the face `rst-directive' instead."
"24.1")
@@ -3714,7 +3674,6 @@ rst-comment-face
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-comment-face
"customize the face `rst-comment' instead."
"24.1")
@@ -3729,7 +3688,6 @@ rst-emphasis1-face
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-emphasis1-face
"customize the face `rst-emphasis1' instead."
"24.1")
@@ -3743,7 +3701,6 @@ rst-emphasis2-face
"Double emphasis."
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-emphasis2-face
"customize the face `rst-emphasis2' instead."
"24.1")
@@ -3758,7 +3715,6 @@ rst-literal-face
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-literal-face
"customize the face `rst-literal' instead."
"24.1")
@@ -3773,7 +3729,6 @@ rst-reference-face
:version "24.1"
:group 'rst-faces
:type '(face))
-(rst-testcover-defcustom)
(make-obsolete-variable 'rst-reference-face
"customize the face `rst-reference' instead."
"24.1")
@@ -3856,7 +3811,6 @@ rst-adornment-faces-alist
(const :tag "transitions" t)
(const :tag "section title adornment" nil))
:value-type (face)))
-(rst-testcover-defcustom)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -4353,7 +4307,6 @@ rst-compile-toolsets
(string :tag "Options"))))
:group 'rst-compile
:package-version "1.2.0")
-(rst-testcover-defcustom)
;; FIXME: Must be defcustom.
(defvar rst-compile-primary-toolset 'html
diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el
index edb539f4c2..d8b8192748 100644
--- a/test/lisp/emacs-lisp/testcover-resources/testcases.el
+++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el
@@ -53,7 +53,6 @@
;; ==== constants-bug-25316 ====
"Testcover doesn't splotch constants."
-:expected-result :failed
;; ====
(defconst testcover-testcase-const "apples")
(defun testcover-testcase-zero () 0)
@@ -76,7 +75,6 @@ testcover-testcase-add-to-const-list
;; ==== customize-defcustom-bug-25326 ====
"Testcover doesn't prevent testing of defcustom values."
-:expected-result :failed
;; ====
(defgroup testcover-testcase nil
"Test case for testcover"
@@ -135,7 +133,6 @@ testcover-testcase-launch-2
;; ==== 1-value-symbol-bug-25316 ====
"Wrapping a form with 1value prevents splotching."
-:expected-result :failed
;; ====
(defun testcover-testcase-always-zero (num)
(- num%%% num%%%)%%%)
@@ -230,7 +227,6 @@ testcover-testcase-cc
;; ==== quotes-within-backquotes-bug-25316 ====
"Forms to instrument are found within quotes within backquotes."
-:expected-result :failed
;; ====
(defun testcover-testcase-make-list ()
(list 'defun 'defvar))
@@ -296,7 +292,6 @@ testcover-testcase-label
;; ==== backquote-1value-bug-24509 ====
"Commas within backquotes are recognized as non-1value."
-:expected-result :failed
;; ====
(defmacro testcover-testcase-lambda (&rest body)
`(lambda () ,@body))
@@ -320,7 +315,6 @@ testcover-testcase-example-2
;; ==== pcase-bug-24688 ====
"Testcover copes with condition-case within backquoted list."
-:expected-result :failed
;; ====
(defun testcover-testcase-pcase (form)
(pcase form%%%
@@ -335,7 +329,6 @@ testcover-testcase-pcase
;; ==== defun-in-backquote-bug-11307-and-24743 ====
"Testcover handles defun forms within backquoted list."
-:expected-result :failed
;; ====
(defmacro testcover-testcase-defun (name &rest body)
(declare (debug (symbolp def-body)))
@@ -348,7 +341,6 @@ testcover-testcase-defun
;; ==== closure-1value-bug ====
"Testcover does not mark closures as 1value."
-:expected-result :failed
;; ====
;; -*- lexical-binding:t -*-
(setq testcover-testcase-foo nil)
@@ -396,9 +388,16 @@ testcover-testcase-dotted-bq
(should (equal '(a b c) (testcover-testcase-dotted-bq nil '(d e))))
(should (equal '(a b c d e) (testcover-testcase-dotted-bq t '(d e))))
+;; ==== quoted-backquote ====
+"Testcover correctly instruments the quoted backquote symbol."
+;; ====
+(defun testcover-testcase-special-symbols ()
+ (list '\` '\, '\,@))
+
+(should (equal '(\` \, \,@) (testcover-testcase-special-symbols)))
+
;; ==== backquoted-vector-bug-25316 ====
"Testcover reinstruments within backquoted vectors."
-:expected-result :failed
;; ====
(defun testcover-testcase-vec (a b c)
`[,a%%% ,(list b%%% c%%%)%%%]%%%)
@@ -415,7 +414,6 @@ testcover-testcase-vec-arg
;; ==== vector-in-macro-spec-bug-25316 ====
"Testcover reinstruments within vectors."
-:expected-result :failed
;; ====
(defmacro testcover-testcase-nth-case (arg vec)
(declare (indent 1)
@@ -435,7 +433,6 @@ testcover-testcase-use-nth-case
;; ==== mapcar-is-not-compose ====
"Mapcar with 1value arguments is not 1value."
-:expected-result :failed
;; ====
(defvar testcover-testcase-num 0)
(defun testcover-testcase-add-num (n)
@@ -450,10 +447,10 @@ testcover-testcase-mapcar-sides
;; ==== function-with-edebug-spec-bug-25316 ====
"Functions can have edebug specs too.
-See c-make-font-lock-search-function for an example in the Emacs
-sources. The other issue is that it's ok to use quote in an
-edebug spec, so testcover needs to cope with that."
-:expected-result :failed
+See `c-make-font-lock-search-function' for an example in the
+Emacs sources. `c-make-font-lock-search-function''s Edebug spec
+also contains a quote. See comment in `testcover-analyze-coverage'
+regarding the odd-looking coverage result for the quoted form."
;; ====
(defun testcover-testcase-make-function (forms)
`(lambda (flag) (if flag 0 ,@forms%%%))%%%)
@@ -462,7 +459,7 @@ testcover-testcase-make-function
(("quote" (&rest def-form))))
(defun testcover-testcase-thing ()
- (testcover-testcase-make-function '((+ 1 (+ 2 (+ 3 (+ 4 5))))))%%%)
+ (testcover-testcase-make-function '(!!!(+ 1 !!!(+ 2 !!!(+ 3 !!!(+ 4 5)%%%)%%%)%%%)%%%))%%%)
(defun testcover-testcase-use-thing ()
(funcall (testcover-testcase-thing)%%% nil)%%%)
diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el
index 0f0ee9a509..2e03488b30 100644
--- a/test/lisp/emacs-lisp/testcover-tests.el
+++ b/test/lisp/emacs-lisp/testcover-tests.el
@@ -124,14 +124,12 @@ testcover-tests-skeleton
(save-current-buffer
(set-buffer (find-file-noselect tempfile))
;; Fail the test if the debugger tries to become active,
- ;; which will happen if Testcover's reinstrumentation
- ;; leaves an edebug-enter in the code. This will also
- ;; prevent debugging these tests using Edebug.
- (cl-letf (((symbol-function #'edebug-enter)
+ ;; which can happen if Testcover fails to attach itself
+ ;; correctly. Note that this will prevent debugging
+ ;; these tests using Edebug.
+ (cl-letf (((symbol-function #'edebug-default-enter)
(lambda (&rest _args)
- (ert-fail
- (concat "Debugger invoked during test run "
- "(possible edebug-enter not replaced)")))))
+ (ert-fail "Debugger invoked during test run"))))
(dolist (byte-compile '(t nil))
(testcover-tests-unmarkup-region (point-min) (point-max))
(unwind-protect
--
2.14.1
next prev parent reply other threads:[~2017-10-03 19:17 UTC|newest]
Thread overview: 8+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-01-01 0:39 bug#25316: 26.0.50; Bugs in testcover-reinstrument Gemini Lasswell
2017-09-25 22:04 ` bug#25316: Patch for " Gemini Lasswell
2017-09-29 10:05 ` Eli Zaretskii
2017-10-03 19:17 ` Gemini Lasswell [this message]
2017-10-04 5:55 ` Eli Zaretskii
2017-09-30 14:40 ` Noam Postavsky
2017-10-03 17:32 ` Gemini Lasswell
2017-10-08 23:38 ` Gemini Lasswell
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=871smkrqg1.fsf@runbox.com \
--to=gazally@runbox.com \
--cc=25316@debbugs.gnu.org \
--cc=eliz@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).