bug#47677: [PATCH] condition-case success continuation

["Mattias Engdegård" <mattiase@acm.org>]

[-- Attachment #1: Type: text/plain, Size: 904 bytes --]

Here is an updated patch that reduces some code duplication in the compiler and fixes an embarrassing bug, and as a bonus, an experimental add-on that allows catching throws in condition-case using the handler syntax

  ((:catch TAG) BODY...)

Unfortunately but unsurprisingly the decision to evaluate the TAG expressions made everything much messier than anticipated. It does work, though, and if you would like to redefine `catch` as the macro

(defmacro catch (tag &rest body)
  (let ((var (gensym)))
    `(condition-case ,var (progn ,@body) ((:catch ,tag) ,var))))

then that will work, too (with minor byte-code inefficiency that could easily be addressed).
Any combination of error, :catch and :success handlers is permitted, making this a very versatile construct.

It may be a good idea to do away with the TAG evaluation since that flexibility isn't likely to be in high demand.


[-- Attachment #2: 0001-Add-condition-case-success-handler-bug-47677.patch --]
[-- Type: application/octet-stream, Size: 17120 bytes --]

From 864e56e63b45a05cb7ff274f33a2b4c9ee45746e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
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                               |   5 +
 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, 218 insertions(+), 33 deletions(-)

diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index 3388102f69..22b665bc93 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -2012,7 +2012,8 @@ Handling Errors
 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 @@ Handling Errors
 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 7483a6e5b7..4ce33f06f0 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -2922,6 +2922,11 @@ 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 executed whenever the protected form terminates without error,
+with the specified variable bound to the returned value.
+
 \f
 * 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 0babbbb978..4f91f0d5de 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -4621,10 +4621,15 @@ byte-compile-unwind-protect
 (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 @@ byte-compile-condition-case
 
     (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 68211ec410..b7e5be95bc 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2144,7 +2144,9 @@ cl--self-tco
             ((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 ddaa8edd81..fd93f5b9e1 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 @@ DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
 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 @@ syms_of_eval (void)
   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 a11832d805..c9ab3ec1f1 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -444,6 +444,65 @@ bytecomp-tests--test-cases
        (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 @@ bytecomp-string-vs-docstring
   (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 5c3e603b92..f4e2e46a01 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -630,12 +630,13 @@ cl-macs--labels
                             (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.21.1 (Apple Git-122.3)


[-- Attachment #3: catch-in-condition-case.diff --]
[-- Type: application/octet-stream, Size: 10325 bytes --]

diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 4f91f0d5de..82e0edd772 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -4636,22 +4636,34 @@ byte-compile-condition-case
       (byte-compile-warn
        "`%s' is not a variable-name or nil (in condition-case)" var))
 
-    (dolist (clause (reverse clauses))
-      (let ((condition (nth 1 clause)))
-        (unless (consp condition) (setq condition (list condition)))
-        (dolist (c condition)
-          (unless (and c (symbolp c))
-            (byte-compile-warn
-             "`%S' is not a condition name (in condition-case)" c))
-          ;; In reality, the `error-conditions' property is only required
-          ;; for the argument to `signal', not to `condition-case'.
-          ;;(unless (consp (get c 'error-conditions))
-          ;;  (byte-compile-warn
-          ;;   "`%s' is not a known condition name (in condition-case)"
-          ;;   c))
-          )
-        (byte-compile-push-constant condition))
-      (byte-compile-goto 'byte-pushconditioncase (car clause)))
+    (let ((initial-depth byte-compile-depth)
+          (push-ops nil))
+      ;; Push all conditions and tags in left-to-right order first,
+      ;; since tags need to be evaluated outside the scope of the handlers.
+      (dolist (clause clauses)
+        (let ((condition (nth 1 clause)))
+          (pcase condition
+            (`(:catch ,tag-expr)
+             (byte-compile-form tag-expr)
+             (push (cons 'byte-pushcatch (car clause)) push-ops))
+            (`(:catch . ,_)
+             (error "malformed :catch clause: `%S'" (cdr clause)))
+            (_             ; error clause
+             (unless (consp condition)
+               (setq condition (list condition)))
+             (dolist (c condition)
+               (unless (and c (symbolp c))
+                 (byte-compile-warn
+                  "`%S' is not a condition name (in condition-case)" c)))
+             (byte-compile-push-constant condition)
+             (push (cons 'byte-pushconditioncase (car clause)) push-ops)))))
+      ;; Then emit the handler activations in reverse order so that the
+      ;; first handler becomes the innermost.
+      (dolist (op push-ops)
+        ;; Use the depth at which the jumps will take place in the tag.
+        (setq byte-compile-depth (1+ initial-depth))
+        (byte-compile-goto (car op) (cdr op)))
+      (cl-assert (equal byte-compile-depth initial-depth)))
 
     (byte-compile-form body) ;; byte-compile--for-effect
     (dolist (_ clauses) (byte-compile-out 'byte-pophandler))
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index b37cfebab3..1651e47cfe 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -510,14 +510,18 @@ cconv-convert
                newprotform)
           ,@(mapcar
              (lambda (handler)
-               `(,(car handler)
-                 ,@(let ((body
-                          (mapcar (lambda (form)
-                                    (cconv-convert form newenv extend))
-                                  (cdr handler))))
-                     (if (not (eq class :captured+mutated))
-                         body
-                       `((let ((,var (list ,var))) ,@body))))))
+               (let ((head (pcase (car handler)
+                             (`(:catch ,tag-exp)
+                              `(:catch ,(cconv-convert tag-exp env extend)))
+                             (h h))))
+                 `(,head
+                   ,@(let ((body
+                            (mapcar (lambda (form)
+                                      (cconv-convert form newenv extend))
+                                    (cdr handler))))
+                       (if (not (eq class :captured+mutated))
+                           body
+                         `((let ((,var (list ,var))) ,@body)))))))
              handlers))))
 
     (`(unwind-protect ,form . ,body)
@@ -736,6 +740,10 @@ cconv-analyze-form
     (`(function . ,_) nil)              ; same as quote
 
     (`(condition-case ,var ,protected-form . ,handlers)
+     (dolist (handler handlers)
+       (pcase handler
+         (`((:catch ,tag-exp) . ,_)
+          (cconv-analyze-form tag-exp env))))
      (cconv-analyze-form protected-form env)
      (when (and var (symbolp var) (byte-compile-not-lexical-var-p var))
        (byte-compile-warn
diff --git a/src/eval.c b/src/eval.c
index fd93f5b9e1..8a7676ec7a 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1351,6 +1351,7 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
   CHECK_SYMBOL (var);
 
   Lisp_Object success_handler = Qnil;
+  Lisp_Object tags = Qnil;	/* Evaluated catch tags in reverse order. */
 
   for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail))
     {
@@ -1361,10 +1362,21 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
 		     || CONSP (XCAR (tem))))))
 	error ("Invalid condition handler: %s",
 	       SDATA (Fprin1_to_string (tem, Qt)));
-      if (EQ (XCAR (tem), QCsuccess))
+      Lisp_Object head = XCAR (tem);
+      if (EQ (head, QCsuccess))
 	success_handler = XCDR (tem);
       else
-	clausenb++;
+	{
+	  if (CONSP (head) && EQ (XCAR (head), QCcatch))
+	    {
+	      if (NILP (XCDR (head)) || !NILP (XCDR (XCDR (head))))
+		error ("Invalid condition handler: %s",
+		       SDATA (Fprin1_to_string (tem, Qt)));
+	      Lisp_Object tag = eval_sub (XCAR (XCDR (head)));
+	      tags = Fcons (tag, tags);
+	    }
+	  clausenb++;
+	}
     }
 
   /* The first clause is the one that should be checked first, so it
@@ -1386,7 +1398,15 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
       Lisp_Object condition = CONSP (clause) ? XCAR (clause) : Qnil;
       if (!CONSP (condition))
 	condition = list1 (condition);
-      struct handler *c = push_handler (condition, CONDITION_CASE);
+      struct handler *c;
+      if (EQ (XCAR (condition), QCcatch))
+	{
+	  Lisp_Object tag = XCAR (tags);
+	  tags = XCDR (tags);
+	  c = push_handler (tag, CATCHER);
+	}
+      else
+	c = push_handler (condition, CONDITION_CASE);
       if (sys_setjmp (c->jmp))
 	{
 	  Lisp_Object val = handlerlist->val;
@@ -4409,6 +4429,7 @@ syms_of_eval (void)
   defsubr (&Sunwind_protect);
   defsubr (&Scondition_case);
   DEFSYM (QCsuccess, ":success");
+  DEFSYM (QCcatch, ":catch");
   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 c9ab3ec1f1..af02810f31 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -503,6 +503,38 @@ bytecomp-tests--test-cases
                  (:success 'good))
                (1+ x))))
       (funcall f 3))
+
+    ;; Catching throws.
+    (let ((g (lambda (f)
+               (let ((tags (list 'a 'b)))
+                 (condition-case x
+                     (funcall f)
+                   ((:catch (prog1 (car tags) (setq tags (cdr tags))))
+                    (list 'catch-a x))
+                   ((:catch (prog1 (car tags) (setq tags (cdr tags))))
+                    (list 'catch-b x))
+                   (:success (list 'ok x)))))))
+      (list (funcall g (lambda () 2))
+            (funcall g (lambda () (throw 'a 3)))
+            (funcall g (lambda () (throw 'b 5)))))
+
+    ;; Catching throws and errors.
+    (let ((g (lambda (f)
+               (let ((tags (list 'a 'b)))
+                 (condition-case x
+                     (funcall f)
+                   ((:catch (prog1 (car tags) (setq tags (cdr tags))))
+                    (list 'catch-a x))
+                   (arith-error (list 'arith x))
+                   ((:catch (prog1 (car tags) (setq tags (cdr tags))))
+                    (list 'catch-b x))
+                   (error (list 'err x))
+                   (:success (list 'ok x)))))))
+      (list (funcall g (lambda () 2))
+            (funcall g (lambda () (throw 'a 3)))
+            (funcall g (lambda () (throw 'b 5)))
+            (funcall g (lambda () (/ 1 0)))
+            (funcall g (lambda () (signal 'error nil)))))
     )
   "List of expressions for cross-testing interpreted and compiled code.")
 
@@ -1310,7 +1342,45 @@ bytecomp-condition-case-success
                               (:success 'good))
                             (1+ x))))
                    (funcall f 3))
-                 4)))
+                 4))
+
+  ;; Catching throws.
+  (should (equal
+           (let ((g (lambda (f)
+                      (let ((tags (list 'a 'b)))
+                        (condition-case x
+                            (funcall f)
+                          ((:catch (prog1 (car tags) (setq tags (cdr tags))))
+                           (list 'catch-a x))
+                          ((:catch (prog1 (car tags) (setq tags (cdr tags))))
+                           (list 'catch-b x))
+                          (:success (list 'ok x)))))))
+             (list (funcall g (lambda () 2))
+                   (funcall g (lambda () (throw 'a 3)))
+                   (funcall g (lambda () (throw 'b 5)))))
+                 '((ok 2) (catch-a 3) (catch-b 5))))
+
+  ;; Catching throws and errors.
+  (should (equal
+           (let ((g (lambda (f)
+                      (let ((tags (list 'a 'b)))
+                        (condition-case x
+                            (funcall f)
+                          ((:catch (prog1 (car tags) (setq tags (cdr tags))))
+                           (list 'catch-a x))
+                          (arith-error (list 'arith x))
+                          ((:catch (prog1 (car tags) (setq tags (cdr tags))))
+                           (list 'catch-b x))
+                          (error (list 'err x))
+                          (:success (list 'ok x)))))))
+             (list (funcall g (lambda () 2))
+                   (funcall g (lambda () (throw 'a 3)))
+                   (funcall g (lambda () (throw 'b 5)))
+                   (funcall g (lambda () (/ 1 0)))
+                   (funcall g (lambda () (signal 'error nil)))))
+                 '((ok 2) (catch-a 3) (catch-b 5)
+                   (arith (arith-error)) (err (error)))))
+  )
 
 ;; Local Variables:
 ;; no-byte-compile: t

[-- Attachment #4: Type: text/plain, Size: 2 bytes --]