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.

2 files changed, 132 insertions, 4 deletions

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))