* bug#25316: 26.0.50; Bugs in testcover-reinstrument
@ 2017-01-01 0:39 Gemini Lasswell
2017-09-25 22:04 ` bug#25316: Patch for " Gemini Lasswell
0 siblings, 1 reply; 8+ messages in thread
From: Gemini Lasswell @ 2017-01-01 0:39 UTC (permalink / raw)
To: 25316
I'm working on tests for testcover.el and a refactoring of
testcover-reinstrument to use pcase. In the process I've found these
bugs. The refactoring will fix these as well as make
testcover-reinstrument easier to read and modify.
Since testcover-start requires the code it works on to be saved in a
file, the instructions to reproduce the bugs below all assume that you
have saved the code snippet given in a file called bug.el. If you are
running Emacs 25 and testcover-start doesn't work, load it with this:
M-: (require 'testcover) RET
I've reproduced all of these using emacs -Q.
1. Wrapping forms in 1value suppresses more splotches than it should.
(defun my-bug (num)
(1value (- num num (- num 3) (* num -1) 3)))
To reproduce:
M-x testcover-start RET bug.el RET
M-: (my-bug 5) RET
M-x testcover-mark-all RET RET
Result: The form (- num 3) does not have the tan splotch that it should
have. (* num -1) does get a splotch.
2. Testcover splotches backquoted expressions containing only constants.
(defconst my-const "apples")
(defun my-bug ()
`(,my-const "oranges"))
To reproduce:
M-x testcover-start RET bug.el RET
M-: (my-bug) RET
M-x testcover-mark-all RET RET
Result: The form `(,my-const "oranges") has a tan splotch. But
since it will always evaluate to ("apples" "oranges"), Testcover should
mark it as 1value and not splotch it.
3. Testcover fails to reinstrument inside vectors and backquoted vectors.
(defun my-bug (a b c)
`[,a ,(list b c)])
(defmacro my-nth-case (arg vec)
(declare (indent 1)
(debug (form (vector &rest form))))
`(eval (aref ,vec ,arg)))
(defun my-bug-2 (choice val)
(my-nth-case choice
[(+ 1 val)
(- 1 val)
(* 7 val)
(/ 4 val)]))
To reproduce:
M-x testcover-start RET bug.el RET
Followed by either one of these:
M-: (my-bug 1 2 3) RET
M-: (my-bug-2 2 6) RET
Result in both cases: void-variable edebug-freq-count or
wrong-type-argument consp nil depending on if you are running the
current master or not. The errors happen in an edebug-after that did not
get replaced by a testcover-after.
4. Testcover incorrectly parses quoted forms within backquotes.
(defun my-make-list ()
(list 'defun 'defvar))
(defmacro my-bq-macro (fun)
(declare (debug (symbolp)))
`(memq ,fun '(defconst ,@(my-make-list))))
(defun my-use-bq-macro (fun)
(my-bq-macro fun))
To reproduce:
M-x testcover-start RET bug.el RET
Result: void-variable edebug-freq-count or wrong-type-argument consp
nil, another error from an edebug-after not replaced during
reinstrumentation. C-h v testcover-module-constants RET will show that
testcover was trying to reinstrument the list beginning with defconst as
a top-level form.
5. Testcover doesn't correctly reinstrument code matching an Edebug spec
containing a quote. See c-make-font-lock-search-function for an example
of an Edebug spec containing a quote in the Emacs sources.
(defun my-make-function (forms)
`(lambda (flag) (if flag 0 ,@forms)))
(def-edebug-spec my-make-function
(("quote" (&rest def-form))))
(defun my-thing ()
(my-make-function '((+ 1 (+ 2 (+ 3 (+ 4 5)))))))
(defun my-use-thing ()
(funcall (my-thing) nil))
To reproduce:
M-x testcover-start RET bug.el RET
M-: (my-use-thing) RET
Result: Emacs will give you the debugger prompt inside the definition of
my-thing, because an edebug-enter didn't get changed to a
testcover-enter in the instrumentation.
^ permalink raw reply [flat|nested] 8+ messages in thread* bug#25316: Patch for bug#25316: 26.0.50; Bugs in testcover-reinstrument 2017-01-01 0:39 bug#25316: 26.0.50; Bugs in testcover-reinstrument Gemini Lasswell @ 2017-09-25 22:04 ` Gemini Lasswell 2017-09-29 10:05 ` Eli Zaretskii ` (2 more replies) 0 siblings, 3 replies; 8+ messages in thread From: Gemini Lasswell @ 2017-09-25 22:04 UTC (permalink / raw) To: 25316 [-- Attachment #1: Type: text/plain, Size: 1159 bytes --] The attached patches fix the 5 bugs in this bug report, as well as 11307, 24509, 24688, 24743 and 25326. testcover-reinstrument is a code walker which rewrites Edebug's instrumented code replacing Edebug's functions edebug-enter, edebug-before and edebug-after with Testcover's functions (some with different call signatures), and at the same time determining which forms might only return a single value and treating them differently. Since it uses car and cdr to parse and rewrite the code, it is consequently difficult to read and modify. My original goal was to change testcover-reinstrument to use pcase, but along the way I realized that I could simplify it and not only fix all the bugs where one of Edebug's functions gets left in the instrumented code, but remove the possibility of undiscovered or future ones by not doing code rewriting and instead adding a hook mechanism to make Edebug's functions call Testcover's. So in these patches testcover-reinstrument has become testcover-analyze-coverage, which uses pcase to walk Edebug's instrumented code and save the results of its analysis of single-value forms in Edebug's code coverage vector. [-- Attachment #2: 0001-Allow-Edebug-s-instrumentation-to-be-used-for-other-.patch --] [-- Type: text/plain, Size: 9987 bytes --] From c0e8293a9b4919b22e3d409acddc9bde49021bc8 Mon Sep 17 00:00:00 2001 From: Gemini Lasswell <gazally@runbox.com> Date: Sat, 16 Sep 2017 14:23:35 -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. (edebug-default-enter): New name for edebug-enter. (edebug-enter): New function which changes behavior of Edebug based on symbol property 'edebug-behavior and edebug-behavior-alist. (edebug-run-slow, edebug-run-fast): Modify edebug-behavior-alist. --- lisp/emacs-lisp/edebug.el | 154 ++++++++++++++++++++++++++++++---------------- 1 file changed, 100 insertions(+), 54 deletions(-) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index dbc56e272f..ca1f55cb6a 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1065,6 +1065,29 @@ 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 +1147,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? @@ -1330,10 +1354,7 @@ edebug-make-form-wrapper form-data-entry edebug-def-name ;; in case name is changed form-begin form-end)) - ;; (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. (setq edebug-offset-list (vconcat (nreverse edebug-offset-list))) @@ -1358,9 +1379,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 +2194,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 +2239,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 +2358,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: 48714 bytes --] From 233f4e2f4b1fce0704ded33407e9c617a5a62311 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. * 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. --- etc/NEWS | 7 + 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 | 21 +- test/lisp/emacs-lisp/testcover-tests.el | 12 +- 7 files changed, 391 insertions(+), 362 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 040d265f75..78f638d517 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -812,6 +812,13 @@ breakpoint (e.g. with "f" and "o") by customizing the new option This allows to enlarge the maximum recursion depth when instrumenting code. +** Testcover + +--- +*** If you've tried to use Testcover before and were blocked by +unhelpful error messages, give it another try. Many bugs have been +fixed. + ** Eshell --- 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..d9c0d085e5 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) + + ((or `(\` ,bq-form) `(\` . ,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) + ((or `(\` ,bq-form) `(\` . ,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..61a457ac36 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) @@ -398,7 +390,6 @@ testcover-testcase-dotted-bq ;; ==== 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 +406,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 +425,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 +439,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 +451,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 ^ permalink raw reply related [flat|nested] 8+ messages in thread
* bug#25316: Patch for bug#25316: 26.0.50; Bugs in testcover-reinstrument 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 2017-09-30 14:40 ` Noam Postavsky 2017-10-08 23:38 ` Gemini Lasswell 2 siblings, 1 reply; 8+ messages in thread From: Eli Zaretskii @ 2017-09-29 10:05 UTC (permalink / raw) To: Gemini Lasswell; +Cc: 25316 > From: Gemini Lasswell <gazally@runbox.com> > Date: Mon, 25 Sep 2017 15:04:58 -0700 > > The attached patches fix the 5 bugs in this bug report, as well as > 11307, 24509, 24688, 24743 and 25326. > > testcover-reinstrument is a code walker which rewrites Edebug's > instrumented code replacing Edebug's functions edebug-enter, > edebug-before and edebug-after with Testcover's functions (some with > different call signatures), and at the same time determining which > forms might only return a single value and treating them > differently. Since it uses car and cdr to parse and rewrite the code, > it is consequently difficult to read and modify. Thanks, I have a few comments below. Please let others to comment for a week or so before installing on master. > > My original goal was to change testcover-reinstrument to use pcase, > but along the way I realized that I could simplify it and not only fix > all the bugs where one of Edebug's functions gets left in the > instrumented code, but remove the possibility of undiscovered or > future ones by not doing code rewriting and instead adding a hook > mechanism to make Edebug's functions call Testcover's. So in these > patches testcover-reinstrument has become testcover-analyze-coverage, > which uses pcase to walk Edebug's instrumented code and save the > results of its analysis of single-value forms in Edebug's code > coverage vector. > > > [2:text/plain Hide Save:0001-Allow-Edebug-s-instrumentation-to-be-used-for-other-.patch (10kB)] > > >From c0e8293a9b4919b22e3d409acddc9bde49021bc8 Mon Sep 17 00:00:00 2001 > From: Gemini Lasswell <gazally@runbox.com> > Date: Sat, 16 Sep 2017 14:23:35 -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. > (edebug-default-enter): New name for edebug-enter. > (edebug-enter): New function which changes behavior of Edebug based > on symbol property 'edebug-behavior and edebug-behavior-alist. > (edebug-run-slow, edebug-run-fast): Modify edebug-behavior-alist. > --- > lisp/emacs-lisp/edebug.el | 154 ++++++++++++++++++++++++++++++---------------- > 1 file changed, 100 insertions(+), 54 deletions(-) > > diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el > index dbc56e272f..ca1f55cb6a 100644 > --- a/lisp/emacs-lisp/edebug.el > +++ b/lisp/emacs-lisp/edebug.el > @@ -1065,6 +1065,29 @@ 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.") These hooks should be documented in the ELisp manual and in NEWS. Also, please have an empty line between the defvar's. > @@ -1330,10 +1354,7 @@ edebug-make-form-wrapper > form-data-entry edebug-def-name ;; in case name is changed > form-begin form-end)) > > - ;; (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) Why are you removing this? It looks like debugging code that could be useful to someone, no? > +(defun edebug-announce-definition (def-name) > + "Announce Edebug's processing of DEF-NAME." > + (message "Edebug: %s" def-name)) This new function is not mentioned in the commit log message. > -(defun edebug-enter (function args body) > +(defun edebug-enter (func args body) This function is indicated as "new" in the commit log, but it isn't new. > +(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.") These are not in the commit log. > +** Testcover > + > +--- > +*** If you've tried to use Testcover before and were blocked by > +unhelpful error messages, give it another try. Many bugs have been > +fixed. Please make this a more informative entry. I would remove the 1st sentence, and instead describe what new features are available and what could users do with them. Since this is not documented in the manuals (and you suggest to leave it at that with the "---" marker), the NEWS entry should do a better job describing the changes. (You don't need to describe which bugs were fixed, only the new and changed behavior.) > +;;; 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. This text uses one space between sentences, whereas our convention is to use 2. Thanks again for working on this. ^ permalink raw reply [flat|nested] 8+ messages in thread
* bug#25316: Patch for bug#25316: 26.0.50; Bugs in testcover-reinstrument 2017-09-29 10:05 ` Eli Zaretskii @ 2017-10-03 19:17 ` Gemini Lasswell 2017-10-04 5:55 ` Eli Zaretskii 0 siblings, 1 reply; 8+ messages in thread From: Gemini Lasswell @ 2017-10-03 19:17 UTC (permalink / raw) To: Eli Zaretskii; +Cc: 25316 [-- 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 ^ permalink raw reply related [flat|nested] 8+ messages in thread
* bug#25316: Patch for bug#25316: 26.0.50; Bugs in testcover-reinstrument 2017-10-03 19:17 ` Gemini Lasswell @ 2017-10-04 5:55 ` Eli Zaretskii 0 siblings, 0 replies; 8+ messages in thread From: Eli Zaretskii @ 2017-10-04 5:55 UTC (permalink / raw) To: Gemini Lasswell; +Cc: 25316 > From: Gemini Lasswell <gazally@runbox.com> > Cc: 25316@debbugs.gnu.org > Date: Tue, 03 Oct 2017 12:17:50 -0700 > > 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. Thanks, this LGTM. ^ permalink raw reply [flat|nested] 8+ messages in thread
* bug#25316: Patch for bug#25316: 26.0.50; Bugs in testcover-reinstrument 2017-09-25 22:04 ` bug#25316: Patch for " Gemini Lasswell 2017-09-29 10:05 ` Eli Zaretskii @ 2017-09-30 14:40 ` Noam Postavsky 2017-10-03 17:32 ` Gemini Lasswell 2017-10-08 23:38 ` Gemini Lasswell 2 siblings, 1 reply; 8+ messages in thread From: Noam Postavsky @ 2017-09-30 14:40 UTC (permalink / raw) To: Gemini Lasswell; +Cc: 25316 Gemini Lasswell <gazally@runbox.com> writes: > (edebug-enter): New function which changes behavior of Edebug based > on symbol property 'edebug-behavior and edebug-behavior-alist. Those should be wrapped in quotes as in `edebug-behavior' and `edebug-behavior-alist'. > -(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))) Overriding the function-definition of edebug-before and edebug-after doesn't seem very clean. It would be better to have an edebug-before-function which is `funcall'ed I think (I know your patch didn't introduce this, it just makes it more obvious. Perhaps it could be addressed later). > (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))) > +(defun testcover-analyze-coverage (form) > + (pcase form > + (`(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) Missed double spacing again. > + ((or `(\` ,bq-form) `(\` . ,bq-form)) Isn't only the first of these is needed? (read "`foo") ;=> (\` foo) > +(defun testcover-analyze-coverage-wrapped-form (form) > + (pcase form > + ((or `(\` ,bq-form) `(\` . ,bq-form)) As above. ^ permalink raw reply [flat|nested] 8+ messages in thread
* bug#25316: Patch for bug#25316: 26.0.50; Bugs in testcover-reinstrument 2017-09-30 14:40 ` Noam Postavsky @ 2017-10-03 17:32 ` Gemini Lasswell 0 siblings, 0 replies; 8+ messages in thread From: Gemini Lasswell @ 2017-10-03 17:32 UTC (permalink / raw) To: Noam Postavsky; +Cc: 25316 Noam Postavsky writes: > Overriding the function-definition of edebug-before and edebug-after > doesn't seem very clean. It would be better to have an > edebug-before-function which is `funcall'ed I think (I know your patch > didn't introduce this, it just makes it more obvious. Perhaps it could > be addressed later). An advantage to using an overridden function-definition is that it makes backtraces of instrumented code easier to read. >> + ((or `(\` ,bq-form) `(\` . ,bq-form)) > > Isn't only the first of these is needed? (read "`foo") ;=> (\` foo) Yes, only the first is needed, so I'll fix this in both places. ^ permalink raw reply [flat|nested] 8+ messages in thread
* bug#25316: Patch for bug#25316: 26.0.50; Bugs in testcover-reinstrument 2017-09-25 22:04 ` bug#25316: Patch for " Gemini Lasswell 2017-09-29 10:05 ` Eli Zaretskii 2017-09-30 14:40 ` Noam Postavsky @ 2017-10-08 23:38 ` Gemini Lasswell 2 siblings, 0 replies; 8+ messages in thread From: Gemini Lasswell @ 2017-10-08 23:38 UTC (permalink / raw) To: 25316-done I've pushed these patches to master. ^ permalink raw reply [flat|nested] 8+ messages in thread
end of thread, other threads:[~2017-10-08 23:38 UTC | newest] Thread overview: 8+ messages (download: mbox.gz follow: Atom feed -- links below jump to the message on this page -- 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 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
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).