procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add condition-case success handler (bug#47677)

Browse source 
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.
This commit is contained in:
Mattias Engdegård 2021-04-07 11:31:07 +02:00
parent 31f8ae53be
commit 7893945cc8
7 changed files with 218 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
doc/lispref/control.texi
View file

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

6
etc/NEWS
View file

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

61
lisp/emacs-lisp/bytecomp.el
View file

@ -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)))
(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-out-tag endtag)))
(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))))

4
lisp/emacs-lisp/cl-macs.el
View file

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

34
src/eval.c
View file

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

127
test/lisp/emacs-lisp/bytecomp-tests.el
View file

@ -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:

9
test/lisp/emacs-lisp/cl-macs-tests.el
View file

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