mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-24 06:20:43 -08:00
Code Issues Projects Releases Wiki Activity

(cl-flet, cl-labels): Fix bug#74870

Browse source 
* lisp/emacs-lisp/cl-macs.el (cl-flet, cl-labels): Wrap function
bodies in `cl-block`.

* test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs--test-flet-block): New test.
This commit is contained in:
Stefan Monnier 2024-12-21 11:13:07 -05:00
parent a1d08d2c13
commit 4764261681
2 changed files with 41 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -2071,7 +2071,8 @@ Each definition can take the form (FUNC EXP) where
FUNC is the function name, and EXP is an expression that returns the FUNC is the function name, and EXP is an expression that returns the
function value to which it should be bound, or it can take the more common function value to which it should be bound, or it can take the more common
form (FUNC ARGLIST BODY...) which is a shorthand form (FUNC ARGLIST BODY...) which is a shorthand
for (FUNC (lambda ARGLIST BODY)). for (FUNC (lambda ARGLIST BODY)) where BODY is wrapped in
a `cl-block' named FUNC.
FUNC is defined only within FORM, not BODY, so you can't write FUNC is defined only within FORM, not BODY, so you can't write
recursive function definitions. Use `cl-labels' for that. See recursive function definitions. Use `cl-labels' for that. See
@ -2096,15 +2097,22 @@ info node `(cl) Function Bindings' for details.
cl-declarations body))) cl-declarations body)))
(let ((binds ()) (newenv macroexpand-all-environment)) (let ((binds ()) (newenv macroexpand-all-environment))
(dolist (binding bindings) (dolist (binding bindings)
(let ((var (make-symbol (format "--cl-%s--" (car binding)))) (let* ((var (make-symbol (format "--cl-%s--" (car binding))))
(args-and-body (cdr binding))) (args-and-body (cdr binding))
(if (and (= (length args-and-body) 1) (args (car args-and-body))
(macroexp-copyable-p (car args-and-body))) (body (cdr args-and-body)))
(if (and (null body)
(macroexp-copyable-p args))
;; Optimize (cl-flet ((fun var)) body). ;; Optimize (cl-flet ((fun var)) body).
(setq var (car args-and-body)) (setq var args)
(push (list var (if (= (length args-and-body) 1) (push (list var (if (null body)
(car args-and-body) args
`(cl-function (lambda . ,args-and-body)))) (let ((parsed-body (macroexp-parse-body body)))
`(cl-function
(lambda ,args
,@(car parsed-body)
(cl-block ,(car binding)
,@(cdr parsed-body)))))))
binds)) binds))
(push (cons (car binding) (push (cons (car binding)
(lambda (&rest args) (lambda (&rest args)
@ -2271,10 +2279,11 @@ BINDINGS is a list of definitions of the form either (FUNC EXP)
where EXP is a form that should return the function to bind to the where EXP is a form that should return the function to bind to the
function name FUNC, or (FUNC ARGLIST BODY...) where function name FUNC, or (FUNC ARGLIST BODY...) where
FUNC is the function name, ARGLIST its arguments, and BODY the FUNC is the function name, ARGLIST its arguments, and BODY the
forms of the function body. FUNC is in scope in any BODY or EXP, as well forms of the function body. BODY is wrapped in a `cl-block' named FUNC.
as FORM, so you can write recursive and mutually recursive FUNC is in scope in any BODY or EXP, as well as in FORM, so you can write
function definitions, with the caveat that EXPs are evaluated in sequence recursive and mutually recursive function definitions, with the caveat
and you cannot call a FUNC before its EXP has been evaluated. that EXPs are evaluated in sequence and you cannot call a FUNC before its
EXP has been evaluated.
See info node `(cl) Function Bindings' for details. See info node `(cl) Function Bindings' for details.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
@ -2282,7 +2291,7 @@ See info node `(cl) Function Bindings' for details.
(let ((binds ()) (newenv macroexpand-all-environment)) (let ((binds ()) (newenv macroexpand-all-environment))
(dolist (binding bindings) (dolist (binding bindings)
(let ((var (make-symbol (format "--cl-%s--" (car binding))))) (let ((var (make-symbol (format "--cl-%s--" (car binding)))))
(push (cons var (cdr binding)) binds) (push (cons var binding) binds)
(push (cons (car binding) (push (cons (car binding)
(lambda (&rest args) (lambda (&rest args)
(if (eq (car args) cl--labels-magic) (if (eq (car args) cl--labels-magic)
@ -2295,12 +2304,18 @@ See info node `(cl) Function Bindings' for details.
;; Perform self-tail call elimination. ;; Perform self-tail call elimination.
`(letrec ,(mapcar `(letrec ,(mapcar
(lambda (bind) (lambda (bind)
(pcase-let* ((`(,var ,sargs . ,sbody) bind)) (pcase-let* ((`(,var ,fun ,sargs . ,sbody) bind))
`(,var ,(cl--self-tco-on-form `(,var ,(cl--self-tco-on-form
var (macroexpand-all var (macroexpand-all
(if (null sbody) (if (null sbody)
sargs ;A (FUNC EXP) definition. sargs ;A (FUNC EXP) definition.
`(cl-function (lambda ,sargs . ,sbody))) (let ((parsed-body
(macroexp-parse-body sbody)))
`(cl-function
(lambda ,sargs
,@(car parsed-body)
(cl-block ,fun
,@(cdr parsed-body))))))
newenv))))) newenv)))))
(nreverse binds)) (nreverse binds))
. ,(macroexp-unprogn . ,(macroexp-unprogn

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

@ -718,6 +718,16 @@ collection clause."
(f lex-var))))) (f lex-var)))))
(should (equal (f nil) 'a))))) (should (equal (f nil) 'a)))))
(ert-deftest cl-macs--test-flet-block ()
(should (equal (cl-block f1
(cl-flet ((f1 (a) (cons (cl-return-from f1 a) 6)))
(cons (f1 5) 6)))
'(5 . 6)))
(should (equal (cl-block f1
(cl-labels ((f1 (a) (cons (cl-return-from f1 a) 6)))
(cons (f1 7) 8)))
'(7 . 8))))
(ert-deftest cl-flet/edebug () (ert-deftest cl-flet/edebug ()
"Check that we can instrument `cl-flet' forms (bug#65344)." "Check that we can instrument `cl-flet' forms (bug#65344)."
(with-temp-buffer (with-temp-buffer