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

cl-defsubst: Use static scoping for args

Browse source 
* lisp/emacs-lisp/cl-macs.el (cl--slet): New function, partly extracted
from `cl--slet*`.
(cl--slet*): Use it.
(cl--defsubst-expand): Use it to fix bug#47552.

* test/lisp/emacs-lisp/cl-macs-tests.el (cl-defstruct-dynbound-label):
New test.
This commit is contained in:
Stefan Monnier 2023-06-23 11:37:12 -04:00
parent 37a09a4c00
commit e2ee646b16
2 changed files with 31 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -243,17 +243,24 @@ The name is made by appending a number to PREFIX, default \"T\"."
(defvar cl--bind-enquote) ;Non-nil if &cl-quote was in the formal arglist!
(defvar cl--bind-lets) (defvar cl--bind-forms)
(defun cl--slet (bindings body)
"Like `cl--slet*' but for \"parallel let\"."
(cond
((seq-some (lambda (binding) (macroexp--dynamic-variable-p (car binding)))
bindings)
;; FIXME: We use `identity' to obfuscate the code enough to
;; circumvent the known bug in `macroexp--unfold-lambda' :-(
`(funcall (identity (lambda (,@(mapcar #'car bindings))
,@(macroexp-unprogn body)))
,@(mapcar #'cadr bindings)))
((null (cdr bindings))
(macroexp-let* bindings body))
(t `(let ,bindings ,@(macroexp-unprogn body)))))
(defun cl--slet* (bindings body)
"Like `macroexp-let*' but uses static scoping for all the BINDINGS."
(pcase-exhaustive bindings
('() body)
(`((,var ,exp) . ,bindings)
(let ((rest (cl--slet* bindings body)))
(if (macroexp--dynamic-variable-p var)
;; FIXME: We use `identity' to obfuscate the code enough to
;; circumvent the known bug in `macroexp--unfold-lambda' :-(
`(funcall (identity (lambda (,var) ,@(macroexp-unprogn rest))) ,exp)
(macroexp-let* `((,var ,exp)) rest))))))
(if (null bindings) body
(cl--slet `(,(car bindings)) (cl--slet* (cdr bindings) body))))
(defun cl--transform-lambda (form bind-block)
"Transform a function form FORM of name BIND-BLOCK.
@ -349,8 +356,7 @@ FORM is of the form (ARGS . BODY)."
(list '&rest (car (pop cl--bind-lets))))))))
`((,@(nreverse simple-args) ,@rest-args)
,@header
;; Make sure that function arguments are unconditionally statically
;; scoped (bug#47552).
;; Function arguments are unconditionally statically scoped (bug#47552).
,(cl--slet* cl--bind-lets
(macroexp-progn
`(,@(nreverse cl--bind-forms)
@ -2910,9 +2916,10 @@ The function's arguments should be treated as immutable.
(cl-defun ,name ,args ,@body))))
(defun cl--defsubst-expand (argns body _simple whole _unsafe &rest argvs)
(if (and whole (not (cl--safe-expr-p (cons 'progn argvs))))
(if (and whole (not (cl--safe-expr-p (macroexp-progn argvs))))
whole
`(let ,(cl-mapcar #'list argns argvs) ,body)))
;; Function arguments are unconditionally statically scoped (bug#47552).
(cl--slet (cl-mapcar #'list argns argvs) body)))
;;; Structures.

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

@ -803,18 +803,28 @@ See Bug#57915."
(macroexpand form)
(should (string-empty-p messages))))))))
(defvar cl--test-a)
(ert-deftest cl-&key-arguments ()
(cl-flet ((fn (&key x) x))
(should-error (fn :x))
(should (eq (fn :x :a) :a)))
;; In ELisp function arguments are always statically scoped (bug#47552).
(defvar cl--test-a)
(let ((cl--test-a 'dyn)
;; FIXME: How do we silence the "Lexical argument shadows" warning?
(f (cl-function (lambda (&key cl--test-a b)
(list cl--test-a (symbol-value 'cl--test-a) b)))))
(should (equal (funcall f :cl--test-a 'lex :b 2) '(lex dyn 2)))))
(cl-defstruct cl--test-s
cl--test-a b)
(ert-deftest cl-defstruct-dynbound-label-47552 ()
"Check that labels can have the same name as dynbound vars."
(let ((cl--test-a 'dyn))
(let ((x (make-cl--test-s :cl--test-a 4 :b cl--test-a)))
(should (cl--test-s-p x))
(should (equal (cl--test-s-cl--test-a x) 4))
(should (equal (cl--test-s-b x) 'dyn)))))
;;; cl-macs-tests.el ends here