From 7893945cc8f9421d0be5b07b9ed404bdf25ce140 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Mattias=20Engdeg=C3=A5rd?= Date: Wed, 7 Apr 2021 11:31:07 +0200 Subject: [PATCH] Add condition-case success handler (bug#47677) Allow a condition-case handler on the form (:success BODY) to be specified as the success continuation of the protected form, with the specified variable bound to its result. * src/eval.c (Fcondition_case): Update the doc string. (internal_lisp_condition_case): Implement in interpreter. (syms_of_eval): Defsym :success. * lisp/emacs-lisp/bytecomp.el (byte-compile-condition-case): Implement in byte-compiler. * lisp/emacs-lisp/cl-macs.el (cl--self-tco): Allow self-TCO from success handler. * doc/lispref/control.texi (Handling Errors): Update manual. * etc/NEWS: Announce. * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-tests--test-cases) (bytecomp-condition-case-success): * test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs--labels): Add test cases. --- doc/lispref/control.texi | 9 +- etc/NEWS | 6 ++ lisp/emacs-lisp/bytecomp.el | 63 +++++++----- lisp/emacs-lisp/cl-macs.el | 4 +- src/eval.c | 34 ++++++- test/lisp/emacs-lisp/bytecomp-tests.el | 127 +++++++++++++++++++++++++ test/lisp/emacs-lisp/cl-macs-tests.el | 9 +- 7 files changed, 219 insertions(+), 33 deletions(-) diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 3388102f694..22b665bc931 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -2012,7 +2012,8 @@ that can be handled). This special form establishes the error handlers @var{handlers} around the execution of @var{protected-form}. If @var{protected-form} executes without error, the value it returns becomes the value of the -@code{condition-case} form; in this case, the @code{condition-case} has +@code{condition-case} form (in the absence of a success handler; see below). +In this case, the @code{condition-case} has no effect. The @code{condition-case} form makes a difference when an error occurs during @var{protected-form}. @@ -2062,6 +2063,12 @@ error description. If @var{var} is @code{nil}, that means no variable is bound. Then the error symbol and associated data are not available to the handler. +@cindex success handler +As a special case, one of the @var{handlers} can be a list of the +form @code{(:success @var{body}@dots{})}, where @var{body} is executed +with @var{var} (if non-@code{nil}) bound to the return value of +@var{protected-form} when that expression terminates without error. + @cindex rethrow a signal Sometimes it is necessary to re-throw a signal caught by @code{condition-case}, for some outer-level handler to catch. Here's diff --git a/etc/NEWS b/etc/NEWS index d4f942bafe3..6113aa6fb22 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2935,6 +2935,12 @@ arrays nor objects. The special events 'dbus-event' and 'file-notify' are now ignored in 'while-no-input' when added to this variable. ++++ +** 'condition-case' now allows for a success handler. +It is written as (:success BODY...) where BODY is executed whenever +the protected form terminates without error, with the specified +variable bound to the the value of the protected form. + * Changes in Emacs 28.1 on Non-Free Operating Systems diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 0babbbb978d..4f91f0d5dea 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4621,10 +4621,15 @@ binding slots have been popped." (defun byte-compile-condition-case (form) (let* ((var (nth 1 form)) (body (nth 2 form)) + (handlers (nthcdr 3 form)) (depth byte-compile-depth) + (success-handler (assq :success handlers)) + (failure-handlers (if success-handler + (remq success-handler handlers) + handlers)) (clauses (mapcar (lambda (clause) (cons (byte-compile-make-tag) clause)) - (nthcdr 3 form))) + failure-handlers)) (endtag (byte-compile-make-tag))) (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) @@ -4650,30 +4655,40 @@ binding slots have been popped." (byte-compile-form body) ;; byte-compile--for-effect (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) - (byte-compile-goto 'byte-goto endtag) - (while clauses - (let ((clause (pop clauses)) - (byte-compile-bound-variables byte-compile-bound-variables) - (byte-compile--lexical-environment - byte-compile--lexical-environment)) - (setq byte-compile-depth (1+ depth)) - (byte-compile-out-tag (pop clause)) - (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) - (cond - ((null var) (byte-compile-discard)) - (lexical-binding - (push (cons var (1- byte-compile-depth)) - byte-compile--lexical-environment)) - (t (byte-compile-dynamic-variable-bind var))) - (byte-compile-body (cdr clause)) ;; byte-compile--for-effect - (cond - ((null var) nil) - (lexical-binding (byte-compile-discard 1 'preserve-tos)) - (t (byte-compile-out 'byte-unbind 1))) - (byte-compile-goto 'byte-goto endtag))) - - (byte-compile-out-tag endtag))) + (let ((compile-handler-body + (lambda (body) + (let ((byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile--lexical-environment + byte-compile--lexical-environment)) + (cond + ((null var) (byte-compile-discard)) + (lexical-binding + (push (cons var (1- byte-compile-depth)) + byte-compile--lexical-environment)) + (t (byte-compile-dynamic-variable-bind var))) + + (byte-compile-body body) ;; byte-compile--for-effect + + (cond + ((null var)) + (lexical-binding (byte-compile-discard 1 'preserve-tos)) + (t (byte-compile-out 'byte-unbind 1))))))) + + (when success-handler + (funcall compile-handler-body (cdr success-handler))) + + (byte-compile-goto 'byte-goto endtag) + + (while clauses + (let ((clause (pop clauses))) + (setq byte-compile-depth (1+ depth)) + (byte-compile-out-tag (pop clause)) + (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) + (funcall compile-handler-body (cdr clause)) + (byte-compile-goto 'byte-goto endtag))) + + (byte-compile-out-tag endtag)))) (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 68211ec4106..b7e5be95bc3 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2144,7 +2144,9 @@ Like `cl-flet' but the definitions can refer to previous ones. ((and `(condition-case ,err-var ,bodyform . ,handlers) (guard (not (eq err-var var)))) `(condition-case ,err-var - (progn (setq ,retvar ,bodyform) nil) + ,(if (assq :success handlers) + bodyform + `(progn (setq ,retvar ,bodyform) nil)) . ,(mapcar (lambda (h) (cons (car h) (funcall opt-exps (cdr h)))) handlers))) diff --git a/src/eval.c b/src/eval.c index ddaa8edd817..fd93f5b9e1f 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1301,7 +1301,7 @@ DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0, doc: /* Regain control when an error is signaled. Executes BODYFORM and returns its value if no error happens. Each element of HANDLERS looks like (CONDITION-NAME BODY...) -where the BODY is made of Lisp expressions. +or (:success BODY...), where the BODY is made of Lisp expressions. A handler is applicable to an error if CONDITION-NAME is one of the error's condition names. Handlers may also apply when non-error @@ -1323,6 +1323,10 @@ with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error. Then the value of the last BODY form is returned from the `condition-case' expression. +The special handler (:success BODY...) is invoked if BODYFORM terminated +without signalling an error. BODY is then evaluated with VAR bound to +the value returned by BODYFORM. + See also the function `signal' for more info. usage: (condition-case VAR BODYFORM &rest HANDLERS) */) (Lisp_Object args) @@ -1346,16 +1350,21 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform, CHECK_SYMBOL (var); + Lisp_Object success_handler = Qnil; + for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail)) { Lisp_Object tem = XCAR (tail); - clausenb++; if (! (NILP (tem) || (CONSP (tem) && (SYMBOLP (XCAR (tem)) || CONSP (XCAR (tem)))))) error ("Invalid condition handler: %s", SDATA (Fprin1_to_string (tem, Qt))); + if (EQ (XCAR (tem), QCsuccess)) + success_handler = XCDR (tem); + else + clausenb++; } /* The first clause is the one that should be checked first, so it @@ -1369,7 +1378,8 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform, Lisp_Object volatile *clauses = alloca (clausenb * sizeof *clauses); clauses += clausenb; for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail)) - *--clauses = XCAR (tail); + if (!EQ (XCAR (XCAR (tail)), QCsuccess)) + *--clauses = XCAR (tail); for (ptrdiff_t i = 0; i < clausenb; i++) { Lisp_Object clause = clauses[i]; @@ -1409,6 +1419,23 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform, Lisp_Object result = eval_sub (bodyform); handlerlist = oldhandlerlist; + if (!NILP (success_handler)) + { + if (NILP (var)) + return Fprogn (success_handler); + + Lisp_Object handler_var = var; + if (!NILP (Vinternal_interpreter_environment)) + { + result = Fcons (Fcons (var, result), + Vinternal_interpreter_environment); + handler_var = Qinternal_interpreter_environment; + } + + ptrdiff_t count = SPECPDL_INDEX (); + specbind (handler_var, result); + return unbind_to (count, Fprogn (success_handler)); + } return result; } @@ -4381,6 +4408,7 @@ alist of active lexical bindings. */); defsubr (&Sthrow); defsubr (&Sunwind_protect); defsubr (&Scondition_case); + DEFSYM (QCsuccess, ":success"); defsubr (&Ssignal); defsubr (&Scommandp); defsubr (&Sautoload); diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index a11832d805e..c9ab3ec1f1b 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -444,6 +444,65 @@ (arith-error (prog1 (lambda (y) (+ y x)) (setq x 10)))) 4) + + ;; No error, no success handler. + (condition-case x + (list 42) + (error (cons 'bad x))) + ;; Error, no success handler. + (condition-case x + (/ 1 0) + (error (cons 'bad x))) + ;; No error, success handler. + (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (cons 'good x))) + ;; Error, success handler. + (condition-case x + (/ 1 0) + (error (cons 'bad x)) + (:success (cons 'good x))) + ;; Verify that the success code is not subject to the error handlers. + (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (/ (car x) 0))) + ;; Check variable scoping on success. + (let ((x 2)) + (condition-case x + (list x) + (error (list 'bad x)) + (:success (list 'good x)))) + ;; Check variable scoping on failure. + (let ((x 2)) + (condition-case x + (/ 1 0) + (error (list 'bad x)) + (:success (list 'good x)))) + ;; Check capture of mutated result variable. + (funcall + (condition-case x + 3 + (:success (prog1 (lambda (y) (+ y x)) + (setq x 10)))) + 4) + ;; Check for-effect context, on error. + (let ((f (lambda (x) + (condition-case nil + (/ 1 0) + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + ;; Check for-effect context, on success. + (let ((f (lambda (x) + (condition-case nil + nil + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) ) "List of expressions for cross-testing interpreted and compiled code.") @@ -1185,6 +1244,74 @@ compiled correctly." (let ((lexical-binding t)) (should (equal (funcall (byte-compile '(lambda (x) "foo")) 'dummy) "foo")))) +(ert-deftest bytecomp-condition-case-success () + ;; No error, no success handler. + (should (equal (condition-case x + (list 42) + (error (cons 'bad x))) + '(42))) + ;; Error, no success handler. + (should (equal (condition-case x + (/ 1 0) + (error (cons 'bad x))) + '(bad arith-error))) + ;; No error, success handler. + (should (equal (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (cons 'good x))) + '(good 42))) + ;; Error, success handler. + (should (equal (condition-case x + (/ 1 0) + (error (cons 'bad x)) + (:success (cons 'good x))) + '(bad arith-error))) + ;; Verify that the success code is not subject to the error handlers. + (should-error (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (/ (car x) 0))) + :type 'arith-error) + ;; Check variable scoping. + (let ((x 2)) + (should (equal (condition-case x + (list x) + (error (list 'bad x)) + (:success (list 'good x))) + '(good (2)))) + (should (equal (condition-case x + (/ 1 0) + (error (list 'bad x)) + (:success (list 'good x))) + '(bad (arith-error))))) + ;; Check capture of mutated result variable. + (should (equal (funcall + (condition-case x + 3 + (:success (prog1 (lambda (y) (+ y x)) + (setq x 10)))) + 4) + 14)) + ;; Check for-effect context, on error. + (should (equal (let ((f (lambda (x) + (condition-case nil + (/ 1 0) + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + 4)) + ;; Check for-effect context, on success. + (should (equal (let ((f (lambda (x) + (condition-case nil + nil + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + 4))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 5c3e603b92e..f4e2e46a019 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -630,12 +630,13 @@ collection clause." (and xs (progn (setq n1 (1+ n)) (len2 (cdr xs) n1)))))) - ;; Tail call in error handler. + ;; Tail calls in error and success handlers. (len3 (xs n) (if xs - (condition-case nil - (/ 1 0) - (arith-error (len3 (cdr xs) (1+ n)))) + (condition-case k + (/ 1 (logand n 1)) + (arith-error (len3 (cdr xs) (1+ n))) + (:success (len3 (cdr xs) (+ n k)))) n))) (should (equal (len nil 0) 0)) (should (equal (len2 nil 0) 0)) -- 2.39.5