From: Stefan Monnier <monnier@iro.umontreal.ca>
Date: Fri, 23 Jun 2023 15:37:12 +0000 (-0400)
Subject: cl-defsubst: Use static scoping for args
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=e2ee646b162b87e832c8032b9d90577bd21f21f8;p=emacs.git

cl-defsubst: Use static scoping for args

* 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.
---

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 007be1c9b08..4caa573ea9d 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -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.
 
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index 44fc7264a0a..01ca56386e3 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -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