From 3dc99ded842532056f5590d551f42f01024104ca Mon Sep 17 00:00:00 2001 From: Noam Postavsky 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