* bug#30745: 26.0.91; ert should macros nest strangely
2018-03-08 8:54 ` Phillip Lord
@ 2018-08-15 0:47 ` Noam Postavsky
2019-06-24 18:54 ` Lars Ingebrigtsen
0 siblings, 1 reply; 11+ messages in thread
From: Noam Postavsky @ 2018-08-15 0:47 UTC (permalink / raw)
To: Phillip Lord; +Cc: 30745, 24402
[-- Attachment #1: Type: text/plain, Size: 919 bytes --]
block 30745 by 24618
tags 30745 + patch
quit
phillip.lord@russet.org.uk (Phillip Lord) writes:
> Unfortunately, yes. I didn't try nesting two ert-deftest macros, just
> two should's. As the original bug report suggests it's for testing a
> test library (https://github.com/phillord/assess).
>
> I do have a work around now (which is to unnest the shoulds); and
> fortunately, this work-around is backward compatible which is important
> for me. I still have another test failure in my library,
> though. Probably caused by the same thing but I haven't worked on it
> yet.
I have a patch for ert which removes it's (ab)use of the debugger, it
seems to fix this case (and also Bug#11218). Note that it relies on my
patch in #24618 for a catch-all condition-case handler clause.
https://debbugs.gnu.org/cgi/bugreport.cgi?bug=24618;filename=0001-Allow-t-as-a-catch-all-condition-case-handler-Bug-24.patch;msg=8;att=1
[-- Attachment #2: patch --]
[-- Type: text/plain, Size: 24076 bytes --]
From e08577437af595325c950dad261a912093af76af Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Mon, 13 Aug 2018 21:33:04 -0400
Subject: [PATCH v1 1/3] Use signal-hook-function in ert, not debugger
Stop (ab)using the `debugger' in ert.el for backtrace recording.
Instead, use `signal-hook-function' for this purpose, which makes
ert's behavior independent of `debug-on-error'.
* lisp/emacs-lisp/ert.el (ert--should-signal-hook): Remove.
(ert--expand-should-1): Don't bind signal-hook-function.
(ert-debug-on-error): Obsolete, alias to debug-on-error (replace all
uses accordingly).
(ert--test-execution-info): Remove exit-continuation, next-debugger,
and ert-debug-on-error fields.
(ert--run-test-debugger): Remove.
(ert--store-backtrace): New function, to replace it.
(ert--run-test-internal): Use condition-case and bind
`signal-hook-function' rather than binding `debugger'.
(ert-run-test): Remove the `cl-block' for the now removed
exit-continuation.
* test/lisp/emacs-lisp/ert-tests.el
(ert-test-fail-debug-nested-with-debugger): Remove.
(ert-nested-should): New test (Bug#30745).
(ert-with-demoted-errors): New test (Bug#11218).
---
lisp/emacs-lisp/ert.el | 224 ++++++++++++++----------------------
test/lisp/emacs-lisp/ert-tests.el | 101 +++++++---------
test/lisp/emacs-lisp/ert-x-tests.el | 2 +-
3 files changed, 130 insertions(+), 197 deletions(-)
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index eb9695d0c1..09b0240c90 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -266,14 +266,6 @@ ert--signal-should-execution
(when ert--should-execution-observer
(funcall ert--should-execution-observer form-description)))
-;; See Bug#24402 for why this exists
-(defun ert--should-signal-hook (error-symbol data)
- "Stupid hack to stop `condition-case' from catching ert signals.
-It should only be stopped when ran from inside ert--run-test-internal."
- (when (and (not (symbolp debugger)) ; only run on anonymous debugger
- (memq error-symbol '(ert-test-failed ert-test-skipped)))
- (funcall debugger 'error data)))
-
(defun ert--special-operator-p (thing)
"Return non-nil if THING is a symbol naming a special operator."
(and (symbolp thing)
@@ -319,8 +311,7 @@ ert--expand-should-1
(default-value (gensym "ert-form-evaluation-aborted-")))
`(let* ((,fn (function ,fn-name))
(,args (condition-case err
- (let ((signal-hook-function #'ert--should-signal-hook))
- (list ,@arg-forms))
+ (list ,@arg-forms)
(error (progn (setq ,fn #'signal)
(list (car err)
(cdr err)))))))
@@ -658,7 +649,7 @@ ert--infos
;;; Facilities for running a single test.
-(defvar ert-debug-on-error nil
+(define-obsolete-variable-alias 'ert-debug-on-error 'debug-on-error "27.1"
"Non-nil means enter debugger when a test fails or terminates with an error.")
;; The data structures that represent the result of running a test.
@@ -682,109 +673,68 @@ ert-debug-on-error
;; environment data needed during its execution.
(cl-defstruct ert--test-execution-info
(test (cl-assert nil))
- (result (cl-assert nil))
- ;; A thunk that may be called when RESULT has been set to its final
- ;; value and test execution should be terminated. Should not
- ;; return.
- (exit-continuation (cl-assert nil))
- ;; The binding of `debugger' outside of the execution of the test.
- next-debugger
- ;; The binding of `ert-debug-on-error' that is in effect for the
- ;; execution of the current test. We store it to avoid being
- ;; affected by any new bindings the test itself may establish. (I
- ;; don't remember whether this feature is important.)
- ert-debug-on-error)
-
-(defun ert--run-test-debugger (info args)
- "During a test run, `debugger' is bound to a closure that calls this function.
-
-This function records failures and errors and either terminates
-the test silently or calls the interactive debugger, as
-appropriate.
+ (result (cl-assert nil)))
+(defun ert--store-backtrace (info error-symbol data)
+ "Record backtrace into INFO.
INFO is the ert--test-execution-info corresponding to this test
-run. ARGS are the arguments to `debugger'."
- (cl-destructuring-bind (first-debugger-arg &rest more-debugger-args)
- args
- (cl-ecase first-debugger-arg
- ((lambda debug t exit nil)
- (apply (ert--test-execution-info-next-debugger info) args))
- (error
- (let* ((condition (car more-debugger-args))
- (type (cl-case (car condition)
- ((quit) 'quit)
- ((ert-test-skipped) 'skipped)
- (otherwise 'failed)))
- ;; We store the backtrace in the result object for
- ;; `ert-results-pop-to-backtrace-for-test-at-point'.
- ;; This means we have to limit `print-level' and
- ;; `print-length' when printing result objects. That
- ;; might not be worth while when we can also use
- ;; `ert-results-rerun-test-debugging-errors-at-point',
- ;; (i.e., when running interactively) but having the
- ;; backtrace ready for printing is important for batch
- ;; use.
- ;;
- ;; Grab the frames above the debugger.
- (backtrace (cdr (backtrace-get-frames debugger)))
- (infos (reverse ert--infos)))
- (setf (ert--test-execution-info-result info)
- (cl-ecase type
- (quit
- (make-ert-test-quit :condition condition
- :backtrace backtrace
- :infos infos))
- (skipped
- (make-ert-test-skipped :condition condition
- :backtrace backtrace
- :infos infos))
- (failed
- (make-ert-test-failed :condition condition
- :backtrace backtrace
- :infos infos))))
- ;; Work around Emacs's heuristic (in eval.c) for detecting
- ;; errors in the debugger.
- (cl-incf num-nonmacro-input-events)
- ;; FIXME: We should probably implement more fine-grained
- ;; control a la non-t `debug-on-error' here.
- (cond
- ((ert--test-execution-info-ert-debug-on-error info)
- (apply (ert--test-execution-info-next-debugger info) args))
- (t))
- (funcall (ert--test-execution-info-exit-continuation info)))))))
+run. ERROR-SYMBOL and DATA are the same as for `signal'."
+ (let* (;; We store the backtrace in the result object for
+ ;; `ert-results-pop-to-backtrace-for-test-at-point'.
+ ;; This means we have to limit `print-level' and
+ ;; `print-length' when printing result objects. That
+ ;; might not be worth while when we can also use
+ ;; `ert-results-rerun-test-debugging-errors-at-point',
+ ;; (i.e., when running interactively) but having the
+ ;; backtrace ready for printing is important for batch
+ ;; use.
+ ;;
+ ;; Drop frames starting from the closure which calls this
+ ;; function (see lambda in `ert--run-test-internal').
+ (backtrace (cddr (backtrace-get-frames #'ert--store-backtrace)))
+ (condition (cons error-symbol data))
+ (infos (reverse ert--infos)))
+ (setf (ert--test-execution-info-result info)
+ (cl-case error-symbol
+ ((quit)
+ (make-ert-test-quit :condition condition
+ :backtrace backtrace
+ :infos infos))
+ ((ert-test-skipped)
+ (make-ert-test-skipped :condition condition
+ :backtrace backtrace
+ :infos infos))
+ (otherwise
+ (make-ert-test-failed :condition condition
+ :backtrace backtrace
+ :infos infos))))))
(defun ert--run-test-internal (test-execution-info)
"Low-level function to run a test according to TEST-EXECUTION-INFO.
This mainly sets up debugger-related bindings."
- (setf (ert--test-execution-info-next-debugger test-execution-info) debugger
- (ert--test-execution-info-ert-debug-on-error test-execution-info)
- ert-debug-on-error)
- (catch 'ert--pass
- ;; For now, each test gets its own temp buffer and its own
- ;; window excursion, just to be safe. If this turns out to be
- ;; too expensive, we can remove it.
- (with-temp-buffer
- (save-window-excursion
- ;; FIXME: Use `signal-hook-function' instead of `debugger' to
- ;; handle ert errors. Once that's done, remove
- ;; `ert--should-signal-hook'. See Bug#24402 and Bug#11218 for
- ;; details.
- (let ((debugger (lambda (&rest args)
- (ert--run-test-debugger test-execution-info
- args)))
- (debug-on-error t)
- (debug-on-quit t)
- ;; FIXME: Do we need to store the old binding of this
- ;; and consider it in `ert--run-test-debugger'?
- (debug-ignored-errors nil)
- (ert--infos '()))
- (funcall (ert-test-body (ert--test-execution-info-test
- test-execution-info))))))
- (ert-pass))
- (setf (ert--test-execution-info-result test-execution-info)
- (make-ert-test-passed))
- nil)
+ (condition-case-unless-debug ()
+ (progn
+ (catch 'ert--pass
+ ;; For now, each test gets its own temp buffer and its own
+ ;; window excursion, just to be safe. If this turns out to be
+ ;; too expensive, we can remove it.
+ (with-temp-buffer
+ (save-window-excursion
+ (let ((signal-hook-function
+ (lambda (errsym errdata)
+ ;; Rebind `signal-hook-function' to avoid
+ ;; accidental recursion.
+ (let ((signal-hook-function nil))
+ (ert--store-backtrace test-execution-info
+ errsym errdata))))
+ (ert--infos '()))
+ (funcall (ert-test-body (ert--test-execution-info-test
+ test-execution-info))))))
+ (ert-pass))
+ (setf (ert--test-execution-info-result test-execution-info)
+ (make-ert-test-passed)))
+ (t nil)))
(defun ert--force-message-log-buffer-truncation ()
"Immediately truncate *Messages* buffer according to `message-log-max'.
@@ -822,35 +772,32 @@ ert-run-test
Returns the result and stores it in ERT-TEST's `most-recent-result' slot."
(setf (ert-test-most-recent-result ert-test) nil)
- (cl-block error
- (let ((begin-marker
- (with-current-buffer (messages-buffer)
- (point-max-marker))))
- (unwind-protect
- (let ((info (make-ert--test-execution-info
- :test ert-test
- :result
- (make-ert-test-aborted-with-non-local-exit)
- :exit-continuation (lambda ()
- (cl-return-from error nil))))
- (should-form-accu (list)))
- (unwind-protect
- (let ((ert--should-execution-observer
- (lambda (form-description)
- (push form-description should-form-accu)))
- (message-log-max t)
- (ert--running-tests (cons ert-test ert--running-tests)))
- (ert--run-test-internal info))
- (let ((result (ert--test-execution-info-result info)))
- (setf (ert-test-result-messages result)
- (with-current-buffer (messages-buffer)
- (buffer-substring begin-marker (point-max))))
- (ert--force-message-log-buffer-truncation)
- (setq should-form-accu (nreverse should-form-accu))
- (setf (ert-test-result-should-forms result)
- should-form-accu)
- (setf (ert-test-most-recent-result ert-test) result))))
- (set-marker begin-marker nil))))
+ (let ((begin-marker
+ (with-current-buffer (messages-buffer)
+ (point-max-marker))))
+ (unwind-protect
+ (let ((info (make-ert--test-execution-info
+ :test ert-test
+ :result
+ (make-ert-test-aborted-with-non-local-exit)))
+ (should-form-accu (list)))
+ (unwind-protect
+ (let ((ert--should-execution-observer
+ (lambda (form-description)
+ (push form-description should-form-accu)))
+ (message-log-max t)
+ (ert--running-tests (cons ert-test ert--running-tests)))
+ (ert--run-test-internal info))
+ (let ((result (ert--test-execution-info-result info)))
+ (setf (ert-test-result-messages result)
+ (with-current-buffer (messages-buffer)
+ (buffer-substring begin-marker (point-max))))
+ (ert--force-message-log-buffer-truncation)
+ (setq should-form-accu (nreverse should-form-accu))
+ (setf (ert-test-result-should-forms result)
+ should-form-accu)
+ (setf (ert-test-most-recent-result ert-test) result))))
+ (set-marker begin-marker nil)))
(ert-test-most-recent-result ert-test))
(defun ert-running-test ()
@@ -2424,11 +2371,10 @@ ert-results-rerun-test-at-point
(goto-char point))))))
(defun ert-results-rerun-test-at-point-debugging-errors ()
- "Re-run the test at point with `ert-debug-on-error' bound to t.
-
+ "Re-run the test at point with `debug-on-error' bound to t.
To be used in the ERT results buffer."
(interactive)
- (let ((ert-debug-on-error t))
+ (let ((debug-on-error t))
(ert-results-rerun-test-at-point)))
(defun ert-results-pop-to-backtrace-for-test-at-point ()
diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el
index 1fe5b79ef3..ac516135ca 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -85,7 +85,7 @@ ert-self-test-and-exit
(ert-deftest ert-test-fail ()
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
- (let ((result (let ((ert-debug-on-error nil))
+ (let ((result (let ((debug-on-error nil))
(ert-run-test test))))
(cl-assert (ert-test-failed-p result) t)
(cl-assert (equal (ert-test-result-with-condition-condition result)
@@ -94,51 +94,29 @@ ert-self-test-and-exit
(ert-deftest ert-test-fail-debug-with-condition-case ()
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
- (condition-case condition
- (progn
- (let ((ert-debug-on-error t))
- (ert-run-test test))
- (cl-assert nil))
- ((error)
- (cl-assert (equal condition '(ert-test-failed "failure message")) t)))))
+ (should (equal (ert-test-result-with-condition-condition
+ (let ((debug-on-error t))
+ (ert-run-test test)))
+ '(ert-test-failed "failure message")))))
(ert-deftest ert-test-fail-debug-with-debugger-1 ()
- (let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
- (let ((debugger (lambda (&rest _args)
- (cl-assert nil))))
- (let ((ert-debug-on-error nil))
- (ert-run-test test)))))
+ (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))
+ (debugger (lambda (&rest _) (cl-assert nil)))
+ (debug-on-error nil))
+ (ert-run-test test)))
(ert-deftest ert-test-fail-debug-with-debugger-2 ()
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
(cl-block nil
(let ((debugger (lambda (&rest _args)
- (cl-return-from nil nil))))
- (let ((ert-debug-on-error t))
- (ert-run-test test))
+ (cl-return-from nil nil)))
+ (debug-on-error t))
+ (ert-run-test test)
(cl-assert nil)))))
-(ert-deftest ert-test-fail-debug-nested-with-debugger ()
- (let ((test (make-ert-test :body (lambda ()
- (let ((ert-debug-on-error t))
- (ert-fail "failure message"))))))
- (let ((debugger (lambda (&rest _args)
- (cl-assert nil nil "Assertion a"))))
- (let ((ert-debug-on-error nil))
- (ert-run-test test))))
- (let ((test (make-ert-test :body (lambda ()
- (let ((ert-debug-on-error nil))
- (ert-fail "failure message"))))))
- (cl-block nil
- (let ((debugger (lambda (&rest _args)
- (cl-return-from nil nil))))
- (let ((ert-debug-on-error t))
- (ert-run-test test))
- (cl-assert nil nil "Assertion b")))))
-
(ert-deftest ert-test-error ()
(let ((test (make-ert-test :body (lambda () (error "Error message")))))
- (let ((result (let ((ert-debug-on-error nil))
+ (let ((result (let ((debug-on-error nil))
(ert-run-test test))))
(cl-assert (ert-test-failed-p result) t)
(cl-assert (equal (ert-test-result-with-condition-condition result)
@@ -147,19 +125,18 @@ ert-self-test-and-exit
(ert-deftest ert-test-error-debug ()
(let ((test (make-ert-test :body (lambda () (error "Error message")))))
- (condition-case condition
- (progn
- (let ((ert-debug-on-error t))
- (ert-run-test test))
- (cl-assert nil))
- ((error)
- (cl-assert (equal condition '(error "Error message")) t)))))
+ (let ((debug-on-error t)
+ (debugger #'ignore)) ; Don't print backtrace.
+ (should
+ (equal (ert-test-result-with-condition-condition
+ (ert-run-test test))
+ '(error "Error message"))))))
;;; Test that `should' works.
(ert-deftest ert-test-should ()
(let ((test (make-ert-test :body (lambda () (should nil)))))
- (let ((result (let ((ert-debug-on-error nil))
+ (let ((result (let ((debug-on-error nil))
(ert-run-test test))))
(cl-assert (ert-test-failed-p result) t)
(cl-assert (equal (ert-test-result-with-condition-condition result)
@@ -175,7 +152,7 @@ ert-self-test-and-exit
(ert-deftest ert-test-should-not ()
(let ((test (make-ert-test :body (lambda () (should-not t)))))
- (let ((result (let ((ert-debug-on-error nil))
+ (let ((result (let ((debug-on-error nil))
(ert-run-test test))))
(cl-assert (ert-test-failed-p result) t)
(cl-assert (equal (ert-test-result-with-condition-condition result)
@@ -190,7 +167,7 @@ ert-self-test-and-exit
(let ((test (make-ert-test :body (lambda ()
(cl-macrolet ((foo () `(progn t nil)))
(should (foo)))))))
- (let ((result (let ((ert-debug-on-error nil))
+ (let ((result (let ((debug-on-error nil))
(ert-run-test test))))
(should (ert-test-failed-p result))
(should (equal
@@ -202,7 +179,7 @@ ert-self-test-and-exit
(ert-deftest ert-test-should-error ()
;; No error.
(let ((test (make-ert-test :body (lambda () (should-error (progn))))))
- (let ((result (let ((ert-debug-on-error nil))
+ (let ((result (let ((debug-on-error nil))
(ert-run-test test))))
(should (ert-test-failed-p result))
(should (equal (ert-test-result-with-condition-condition result)
@@ -345,13 +322,23 @@ ert--test-my-list
(error "Foo")))
do
(let ((test (make-ert-test :body body)))
- (condition-case actual-condition
- (progn
- (let ((ert-debug-on-error t))
- (ert-run-test test))
- (cl-assert nil))
- ((error)
- (should (equal actual-condition expected-condition)))))))
+ (should (equal (ert-test-result-with-condition-condition
+ (let ((debug-on-error nil))
+ (ert-run-test test)))
+ expected-condition)))))
+
+(ert-deftest ert-nested-should ()
+ "Test (dynamically) nested `should' forms (Bug#30745)."
+ (let ((test (make-ert-test :body (lambda () (should (eq 1 2))))))
+ (should (equal (ert-test-result-with-condition-condition
+ (ert-run-test test))
+ '(ert-test-failed
+ ((should (eq 1 2)) :form (eq 1 2) :value nil))))))
+
+(ert-deftest ert-with-demoted-errors ()
+ "An error which is caught shouldn't fail the test (Bug#11218)."
+ (should (progn (with-demoted-errors (error "error!"))
+ t)))
(defun ert-test--which-file ()
"Dummy function to help test `symbol-file' for tests.")
@@ -518,7 +505,7 @@ ert-test--which-file
(skipped-test (make-ert-test :name 'skipped-test
:body (lambda () (ert-skip
"skip message")))))
- (let ((ert-debug-on-error nil))
+ (let ((debug-on-error nil))
(let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*"))
(messages nil)
(mock-message-fn
@@ -566,7 +553,7 @@ ert-test--which-file
(should (null '()))
(should nil)
(should t)))))
- (let ((result (let ((ert-debug-on-error nil))
+ (let ((result (let ((debug-on-error nil))
(ert-run-test test))))
(should (equal (ert-test-result-should-forms result)
'(((should t) :form t :value t)
@@ -581,7 +568,7 @@ ert-test--which-file
(should t)))))
(let ((result (ert-run-test test2)))
(should (ert-test-passed-p result))))))))
- (let ((result (let ((ert-debug-on-error nil))
+ (let ((result (let ((debug-on-error nil))
(ert-run-test test))))
(should (ert-test-passed-p result))
(should (eql (length (ert-test-result-should-forms result))
@@ -593,7 +580,7 @@ ert-test--which-file
(should (equal obj '(a)))
(setf (car obj) 'b)
(should (equal obj '(b))))))))
- (let ((result (let ((ert-debug-on-error nil))
+ (let ((result (let ((debug-on-error nil))
(ert-run-test test))))
(should (ert-test-passed-p result))
(should (equal (ert-test-result-should-forms result)
diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el
index 9798f0c824..16b4751a38 100644
--- a/test/lisp/emacs-lisp/ert-x-tests.el
+++ b/test/lisp/emacs-lisp/ert-x-tests.el
@@ -114,7 +114,7 @@ ert--hash-table-to-alist
(skipped-test (make-ert-test :name 'skipped-test
:body (lambda () (ert-skip
"skip message"))))
- (ert-debug-on-error nil)
+ (debug-on-error nil)
(buffer-name (generate-new-buffer-name "*ert-test-run-tests*"))
(messages nil)
(mock-message-fn
--
2.11.0
[-- Attachment #3: Type: text/plain, Size: 281 bytes --]
But it bumps into another bug lurking in process.c, which just happened
to work okay previously because ert would bind debug-on-error while
running tests. There is only one test in the Emacs test suite which
triggers this, we can work around it by binding debug-on-error there:
[-- Attachment #4: patch --]
[-- Type: text/plain, Size: 2021 bytes --]
From d586f0e4e0ec057be047b13aea53a05009ece3cf Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Tue, 14 Aug 2018 20:21:26 -0400
Subject: [PATCH v1 2/3] Work around (should-error ... accept-process-output)
bug
This is needed to let the test `json-el-cant-serialize-this' pass with
the previous change. That test expects a signal to propogate up from
accept-process-output. This did happen previously because ert used to
bind `debug-on-error' while running, but since the previous change it
no longer does so. The function read_and_dispose_of_process_output
would catch errors if `debug-on-error' is nil.
* test/lisp/jsonrpc-tests.el (json-el-cant-serialize-this): Let-bind
debug-on-error around the should-error body.
---
test/lisp/jsonrpc-tests.el | 9 +++++++--
1 file changed, 7 insertions(+), 2 deletions(-)
diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el
index 1a84c30e33..f541c67313 100644
--- a/test/lisp/jsonrpc-tests.el
+++ b/test/lisp/jsonrpc-tests.el
@@ -152,11 +152,16 @@ jsonrpc--call-with-emacsrpc-fixture
(ert-deftest json-el-cant-serialize-this ()
"Can't serialize a response that is half-vector/half-list."
+ ;; We need to let-bind `debug-on-error' due a bug in
+ ;; read_and_dispose_of_process_output of process.c, which would
+ ;; otherwise catch errors (see the FIXME on the
+ ;; internal_condition_case_1 call).
(jsonrpc--with-emacsrpc-fixture (conn)
(should-error
;; (append [1 2 3] [3 4 5]) => (1 2 3 . [3 4 5]), which can't be
- ;; serialized
- (jsonrpc-request conn 'append [[1 2 3] [3 4 5]]))))
+ ;; serialized.
+ (let ((debug-on-error t))
+ (jsonrpc-request conn 'append [[1 2 3] [3 4 5]])))))
(cl-defmethod jsonrpc-connection-ready-p
((conn jsonrpc--test-client) what)
--
2.11.0
[-- Attachment #5: Type: text/plain, Size: 136 bytes --]
This third patch is not really needed to fix the bug, but I had to
simplify the code in order to figure out what was going on anyway.
[-- Attachment #6: patch --]
[-- Type: text/plain, Size: 13281 bytes --]
From 3dc99ded842532056f5590d551f42f01024104ca Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Mon, 13 Aug 2018 22:22:43 -0400
Subject: [PATCH v1 3/3] Simplify ert `should'-expansion macro machinery
* lisp/emacs-lisp/ert.el (ert--should-execution-observer): Default to
`ignore'.
(ert--signal-should-execution): Now we don't need to check if
ert--should-execution-observer is nil.
(ert--last-should-execution): New function.
(ert--special-operator-p): Remove, replace usage with special-form-p.
(ert--do-form): New function.
(ert--expand-should, ert--expand-should-1): Coalesce, remove the
latter.
(should, should-not, should-error, ert--skip-unless): Simplify
accordingly.
(ert-run-test): Adjust `ert--should-execution-observer' to make
`ert--last-should-execution' work.
* test/lisp/emacs-lisp/ert-tests.el (ert-test-special-operator-p):
Move to...
* test/lisp/subr-tests.el (special-form-p): ...here.
---
lisp/emacs-lisp/ert.el | 185 ++++++++++++++------------------------
test/lisp/emacs-lisp/ert-tests.el | 9 --
test/lisp/subr-tests.el | 9 ++
3 files changed, 77 insertions(+), 126 deletions(-)
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 09b0240c90..d91d64a885 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -259,24 +259,39 @@ ert-skip
;;; The `should' macros.
-(defvar ert--should-execution-observer nil)
+(defvar ert--should-execution-observer #'ignore)
(defun ert--signal-should-execution (form-description)
- "Tell the current `should' form observer (if any) about FORM-DESCRIPTION."
- (when ert--should-execution-observer
- (funcall ert--should-execution-observer form-description)))
-
-(defun ert--special-operator-p (thing)
- "Return non-nil if THING is a symbol naming a special operator."
- (and (symbolp thing)
- (let ((definition (indirect-function thing)))
- (and (subrp definition)
- (eql (cdr (subr-arity definition)) 'unevalled)))))
-
-;; FIXME: Code inside of here should probably be evaluated like it is
-;; outside of tests, with the sole exception of error handling
-(defun ert--expand-should-1 (whole form inner-expander)
- "Helper function for the `should' macro and its variants."
+ "Tell the current `should' form observer about FORM-DESCRIPTION."
+ (funcall ert--should-execution-observer form-description))
+
+(defun ert--last-should-execution ()
+ "Ask the `should' form observer for the last FORM-DESCRIPTION."
+ (funcall ert--should-execution-observer))
+
+(defun ert--do-form (whole form-args-fun form-fun &optional fn-name)
+ "Helper function, used in `ert-expand-should' output."
+ (let ((form-desc (list whole)))
+ (unwind-protect
+ (let ((args (funcall form-args-fun)))
+ (cl-callf nconc form-desc (list :form (if fn-name
+ (cons fn-name args)
+ args)))
+ (let ((val (apply form-fun (and (listp args) args))))
+ (cl-callf nconc form-desc
+ (list :value val)
+ (let ((explainer (and (symbolp fn-name)
+ (get fn-name 'ert-explainer))))
+ (when explainer
+ (list :explanation (apply explainer args)))))
+ val))
+ (ert--signal-should-execution form-desc))))
+
+(defun ert--expand-should (whole form)
+ "Helper function for the `should' macro and its variants.
+Analyzes FORM and returns an expression that has the same
+semantics under evaluation but records additional debugging
+information."
(let ((form
;; catch macroexpansion errors
(condition-case err
@@ -290,94 +305,39 @@ ert--expand-should-1
cl-macro-environment))))
(error `(signal ',(car err) ',(cdr err))))))
(cond
- ((or (atom form) (ert--special-operator-p (car form)))
- (let ((value (gensym "value-")))
- `(let ((,value (gensym "ert-form-evaluation-aborted-")))
- ,(funcall inner-expander
- `(setq ,value ,form)
- `(list ',whole :form ',form :value ,value)
- value)
- ,value)))
+ ((atom form)
+ `(ert--do-form ',whole
+ (lambda () ',form)
+ (lambda (&rest _) ,form)))
+ ((special-form-p (car form))
+ `(ert--do-form ',whole
+ (lambda () ',(cdr form))
+ (lambda (&rest _) ,form)
+ ',(car form)))
(t
(let ((fn-name (car form))
(arg-forms (cdr form)))
- (cl-assert (or (symbolp fn-name)
- (and (consp fn-name)
- (eql (car fn-name) 'lambda)
- (listp (cdr fn-name)))))
- (let ((fn (gensym "fn-"))
- (args (gensym "args-"))
- (value (gensym "value-"))
- (default-value (gensym "ert-form-evaluation-aborted-")))
- `(let* ((,fn (function ,fn-name))
- (,args (condition-case err
- (list ,@arg-forms)
- (error (progn (setq ,fn #'signal)
- (list (car err)
- (cdr err)))))))
- (let ((,value ',default-value))
- ,(funcall inner-expander
- `(setq ,value (apply ,fn ,args))
- `(nconc (list ',whole)
- (list :form `(,,fn ,@,args))
- (unless (eql ,value ',default-value)
- (list :value ,value))
- (let ((-explainer-
- (and (symbolp ',fn-name)
- (get ',fn-name 'ert-explainer))))
- (when -explainer-
- (list :explanation
- (apply -explainer- ,args)))))
- value)
- ,value))))))))
-
-(defun ert--expand-should (whole form inner-expander)
- "Helper function for the `should' macro and its variants.
-
-Analyzes FORM and returns an expression that has the same
-semantics under evaluation but records additional debugging
-information.
-
-INNER-EXPANDER should be a function and is called with two
-arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM
-is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is
-an expression that returns a description of FORM. INNER-EXPANDER
-should return code that calls INNER-FORM and performs the checks
-and error signaling specific to the particular variant of
-`should'. The code that INNER-EXPANDER returns must not call
-FORM-DESCRIPTION-FORM before it has called INNER-FORM."
- (ert--expand-should-1
- whole form
- (lambda (inner-form form-description-form value-var)
- (let ((form-description (gensym "form-description-")))
- `(let (,form-description)
- ,(funcall inner-expander
- `(unwind-protect
- ,inner-form
- (setq ,form-description ,form-description-form)
- (ert--signal-should-execution ,form-description))
- `,form-description
- value-var))))))
+ (cl-assert (or (symbolp fn-name) (functionp fn-name)))
+ `(ert--do-form ',whole
+ (lambda () (list ,@arg-forms))
+ #',fn-name
+ #',fn-name))))))
(cl-defmacro should (form)
"Evaluate FORM. If it returns nil, abort the current test as failed.
Returns the value of FORM."
(declare (debug t))
- (ert--expand-should `(should ,form) form
- (lambda (inner-form form-description-form _value-var)
- `(unless ,inner-form
- (ert-fail ,form-description-form)))))
+ `(or ,(ert--expand-should `(should ,form) form)
+ (ert-fail (ert--last-should-execution))))
(cl-defmacro should-not (form)
"Evaluate FORM. If it returns non-nil, abort the current test as failed.
Returns nil."
(declare (debug t))
- (ert--expand-should `(should-not ,form) form
- (lambda (inner-form form-description-form _value-var)
- `(unless (not ,inner-form)
- (ert-fail ,form-description-form)))))
+ `(and ,(ert--expand-should `(should-not ,form) form)
+ (ert-fail (ert--last-should-execution))))
(defun ert--should-error-handle-error (form-description-fn
condition type exclude-subtypes)
@@ -423,37 +383,26 @@ ert--should-error-handle-error
failed."
(declare (debug t))
(unless type (setq type ''error))
- (ert--expand-should
- `(should-error ,form ,@keys)
- form
- (lambda (inner-form form-description-form value-var)
- (let ((errorp (gensym "errorp"))
- (form-description-fn (gensym "form-description-fn-")))
- `(let ((,errorp nil)
- (,form-description-fn (lambda () ,form-description-form)))
- (condition-case -condition-
- ,inner-form
- ;; We can't use ,type here because we want to evaluate it.
- (error
- (setq ,errorp t)
- (ert--should-error-handle-error ,form-description-fn
- -condition-
- ,type ,exclude-subtypes)
- (setq ,value-var -condition-)))
- (unless ,errorp
- (ert-fail (append
- (funcall ,form-description-fn)
- (list
- :fail-reason "did not signal an error")))))))))
+ `(or (condition-case -condition-
+ (progn ,(ert--expand-should `(should-error ,form ,@keys) form)
+ nil)
+ ;; We can't use ,TYPE here because we want to evaluate it.
+ (error
+ (ert--should-error-handle-error #'ert--last-should-execution
+ -condition-
+ ,type ,exclude-subtypes)
+ -condition-))
+ (ert-fail (append
+ (ert--last-should-execution)
+ (list
+ :fail-reason "did not signal an error")))))
(cl-defmacro ert--skip-unless (form)
"Evaluate FORM. If it returns nil, skip the current test.
Errors during evaluation are caught and handled like nil."
(declare (debug t))
- (ert--expand-should `(skip-unless ,form) form
- (lambda (inner-form form-description-form _value-var)
- `(unless (ignore-errors ,inner-form)
- (ert-skip ,form-description-form)))))
+ `(or (ignore-errors ,(ert--expand-should `(skip-unless ,form) form))
+ (ert-skip (ert--last-should-execution))))
;;; Explanation of `should' failures.
@@ -783,8 +732,10 @@ ert-run-test
(should-form-accu (list)))
(unwind-protect
(let ((ert--should-execution-observer
- (lambda (form-description)
- (push form-description should-form-accu)))
+ (lambda (&optional form-description)
+ (if form-description
+ (push form-description should-form-accu)
+ (car should-form-accu))))
(message-log-max t)
(ert--running-tests (cons ert-test ert--running-tests)))
(ert--run-test-internal info))
diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el
index ac516135ca..12ff4c040a 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -538,15 +538,6 @@ ert-test--which-file
(when (get-buffer buffer-name)
(kill-buffer buffer-name))))))))
-(ert-deftest ert-test-special-operator-p ()
- (should (ert--special-operator-p 'if))
- (should-not (ert--special-operator-p 'car))
- (should-not (ert--special-operator-p 'ert--special-operator-p))
- (let ((b (cl-gensym)))
- (should-not (ert--special-operator-p b))
- (fset b 'if)
- (should (ert--special-operator-p b))))
-
(ert-deftest ert-test-list-of-should-forms ()
(let ((test (make-ert-test :body (lambda ()
(should t)
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 86938d5dbe..fbdcf70560 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -360,5 +360,14 @@ subr-test--frames-1
(shell-quote-argument "%ca%")))
"without-caret %ca%"))))
+(ert-deftest special-form-p ()
+ (should (special-form-p 'if))
+ (should-not (special-form-p 'car))
+ (should-not (special-form-p 'special-form-p))
+ (let ((b (gensym)))
+ (should-not (special-form-p b))
+ (fset b 'if)
+ (should (special-form-p b))))
+
(provide 'subr-tests)
;;; subr-tests.el ends here
--
2.11.0
^ permalink raw reply related [flat|nested] 11+ messages in thread