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

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

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

21 apr. 2021 kl. 16.13 skrev Stefan Kangas <stefan@marxist.se>:

> Should this be closed, or is there more to do here?

There's the business of fixing `catch` in the same way. (A new bug could be opened for it, but since it's intimately related we might as well do it here.) As mentioned, `catch` has three problems:

- no way to execute code when a throw is caught
- no way to execute code when the body terminates normally
- no way to catch both throws and errors

since neither `catch` nor `condition-case` compose with themselves or each other.
For example, it would be useful to have `pcase` match both the value of an expression as well as throws and errors from it.

Here is a proper patch, essentially a polished version of the previously posted diff. It adds `condition-case` clauses on the form

((:catch TAG-EXPR) BODY...)

where TAG-EXPR is evaluated before the protected form to a tag value, and BODY is executed when that tag is thrown, with the variable bound to the thrown value.


[-- Attachment #2: 0001-catch-handlers-in-condition-case-bug-47677.patch --]
[-- Type: application/octet-stream, Size: 12716 bytes --]

From 218db91619430d0f26ca3e17839e6669fd291e76 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Mon, 12 Apr 2021 20:40:23 +0200
Subject: [PATCH] `catch` handlers in `condition-case` (bug#47677)

Add handlers on the form

  ((:catch TAG) BODY...)

where TAG is an expression that is evaluated prior to the protected
form and yields a catch tag that is handled by BODY with the variable
bound to the thrown value.  For example,

  (condition-case x
      (throw 'meep 2)
    ((:catch 'meep) (+ x 3)))
  => 5

Multiple catch and error handlers can be mixed freely in the same
`condition-case` form, which can also include a :success clause.

In other words, this change remedies three problems: `catch` lacking
separate code branches for the throw and fall-through cases, and the
lack of composability with `condition-case` and `catch`.

* src/eval.c (internal_lisp_condition_case, syms_of_eval): Implement
in interpreter.
* lisp/emacs-lisp/cconv.el (cconv-convert, cconv-analyze-form):
* lisp/emacs-lisp/bytecomp.el (byte-compile-condition-case): Implement
in byte-compiler.
* test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-tests--test-cases)
(bytecomp-condition-case-success): Add tests.
---
 lisp/emacs-lisp/bytecomp.el            | 44 ++++++++-----
 lisp/emacs-lisp/cconv.el               | 24 ++++---
 src/eval.c                             | 27 +++++++-
 test/lisp/emacs-lisp/bytecomp-tests.el | 91 +++++++++++++++++++++++++-
 4 files changed, 158 insertions(+), 28 deletions(-)

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 f663710902..f92f9b7ed8 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..d4ed746458 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 catch 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..fb123ab600 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -503,6 +503,46 @@ bytecomp-tests--test-cases
                  (:success 'good))
                (1+ x))))
       (funcall f 3))
+
+    ;; Catching throws, simple.
+    (condition-case x
+        (throw 'z 7)
+      ((:catch 'z) (list 'got-z x)))
+    (condition-case x
+        (list 8)
+      ((:catch 'z) (list 'got-z x)))
+
+    ;; 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 +1350,56 @@ bytecomp-condition-case-success
                               (:success 'good))
                             (1+ x))))
                    (funcall f 3))
-                 4)))
+                 4))
+
+  ;; Catching throws, simple.
+  (should (equal (condition-case x
+                     (throw 'z 7)
+                   ((:catch 'z) (list 'got-z x)))
+                 '(got-z 7)))
+
+  (should (equal (condition-case x
+                     (list 8)
+                   ((:catch 'z) (list 'got-z x)))
+                 '(8)))
+
+  ;; 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
-- 
2.21.1 (Apple Git-122.3)