unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
* bug#47677: [PATCH] condition-case success continuation
@ 2021-04-09 20:26 Mattias Engdegård
  2021-04-10 23:52 ` Stefan Monnier
  2021-04-26 21:57 ` Gregory Heytings
  0 siblings, 2 replies; 31+ messages in thread
From: Mattias Engdegård @ 2021-04-09 20:26 UTC (permalink / raw)
  To: 47677

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

This patch adds the condition-case handler syntax

  (:success BODY)

for code executed when the protected form terminates without error. BODY is then executed with the variable bound to the result of the protected form, and the result of BODY is then the value of the condition-case form as usual.

This plugs an annoying hole in elisp: there hasn't been any direct access to the success continuation which forced programmers to resort to various hacks such as tagging the returned value and then immediately testing that tag, as in

(let ((input (condition-case _
                 (cons 'ok (read buffer))
               (end-of-file 'eof))))
  (when (consp input)
    (use (cdr input))))

Now we can write

(condition-case result
    (read buffer)
  (end-of-file 'eof)
  (:success (use result)))

which is more concise, elegant and performant.

Like all condition-case handlers (but in contrast to the protected form), the success handler is in the tail position and the limited self-tail-recursion of cl-labels (and named-let) works there as expected.

Details of the syntax can be changed if there is a very good reason for it. Many other languages have more or less independently added equivalent constructs. Common Lisp's `handler-case` has a very similar feature (:no-error).

It would be nice to give `catch` the same treatment. A particularly flexible solution would be to add `catch` handlers to `condition-case`, which would then be able to handle everything. Unless there is a strong reason for doing it right away, it can be seen as a later improvement.


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

From 952fc7ea3878d3d71a82d669a1499aee0d1f8c55 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

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            | 28 ++++++++-
 lisp/emacs-lisp/cl-macs.el             |  4 +-
 src/eval.c                             | 34 ++++++++++-
 test/lisp/emacs-lisp/bytecomp-tests.el | 78 ++++++++++++++++++++++++++
 test/lisp/emacs-lisp/cl-macs-tests.el  |  9 +--
 7 files changed, 157 insertions(+), 10 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 a0f05d8cf1..fa82e2872f 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -2898,6 +2898,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..ce3a759487 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,6 +4655,27 @@ byte-compile-condition-case
 
     (byte-compile-form body) ;; byte-compile--for-effect
     (dolist (_ clauses) (byte-compile-out 'byte-pophandler))
+
+    (when success-handler
+      (let ((success-body (cdr success-handler)))
+        (cond
+         ((null var)
+          (byte-compile-discard)
+          (byte-compile-body success-body byte-compile--for-effect))
+         (lexical-binding
+          (let ((byte-compile--lexical-environment
+                 byte-compile--lexical-environment))
+            (push (cons var (1- byte-compile-depth))
+                  byte-compile--lexical-environment)
+            (byte-compile-body success-body byte-compile--for-effect)
+            (byte-compile-discard 1 'preserve-tos)))
+         (t
+          (let ((byte-compile-bound-variables
+                 byte-compile-bound-variables))
+            (byte-compile-dynamic-variable-bind var)
+            (byte-compile-body success-body byte-compile--for-effect)
+            (byte-compile-out 'byte-unbind 1))))))
+
     (byte-compile-goto 'byte-goto endtag)
 
     (while clauses
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..41c4cd1637 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 94e33a7770..3ec443e04d 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -437,6 +437,42 @@ bytecomp-tests--test-cases
                   (/ 1 0)
                 (arith-error x))))
       (list x y))
+
+    ;; 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))))
     )
   "List of expressions for cross-testing interpreted and compiled code.")
 
@@ -1178,6 +1214,48 @@ 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))))))
+
 ;; 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)


^ permalink raw reply related	[flat|nested] 31+ messages in thread
end of thread, other threads:[~2021-04-29 12:45 UTC | newest]

Thread overview: 31+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-04-09 20:26 bug#47677: [PATCH] condition-case success continuation Mattias Engdegård
2021-04-10 23:52 ` Stefan Monnier
2021-04-11 11:13   ` Mattias Engdegård
2021-04-12  8:49     ` Lars Ingebrigtsen
2021-04-12 15:10       ` Stefan Monnier
2021-04-12 19:20         ` Mattias Engdegård
2021-04-13  7:38           ` Lars Ingebrigtsen
2021-04-13  8:52             ` Mattias Engdegård
2021-04-14  9:29               ` Lars Ingebrigtsen
2021-04-15 13:54                 ` Mattias Engdegård
2021-04-16  5:13                   ` Richard Stallman
2021-04-16  5:13                   ` Richard Stallman
2021-04-21 14:13                   ` Stefan Kangas
2021-04-22 13:58                     ` Mattias Engdegård
2021-04-23  4:18                       ` Richard Stallman
2021-04-24 17:02                         ` Mattias Engdegård
2021-04-25  4:44                           ` Richard Stallman
2021-04-25  7:35                             ` Eli Zaretskii
2021-04-25 18:21                               ` bug#47677: [External] : " Drew Adams
2021-04-25 18:24                                 ` Eli Zaretskii
2021-04-26  4:40                               ` Richard Stallman
2021-04-26 12:44                                 ` Eli Zaretskii
2021-04-27  3:46                                   ` Richard Stallman
2021-04-26 15:12                           ` Filipp Gunbin
2021-04-27 15:31                             ` Mattias Engdegård
2021-04-27 19:00                               ` Gregory Heytings
2021-04-29 12:45                               ` Filipp Gunbin
2021-04-25 16:45                       ` Lars Ingebrigtsen
2021-04-26 11:53                         ` Mattias Engdegård
2021-04-27  3:46                           ` Richard Stallman
2021-04-26 21:57 ` Gregory Heytings

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).