master 2a78f06ef4: cl-symbol-macrolet: Fix recent regression

[Stefan Monnier]

branch: master
commit 2a78f06ef4d303b383749be3dabd0f9a68547e5e
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    cl-symbol-macrolet: Fix recent regression
    
    The recent fix for bug#57397 introduced a regression, breaking
    the `cl-lib-symbol-macrolet-hide` test.  It turned out that the
    origin of the problem was that `gv.el` uses `macroexpand-1` which
    does not (can't) use `macroexpand` but `cl-symbol-macrolet` failed
    to advise `macroexpand-1` the way it advised `macroexpand`.
    
    To fix this, we change `cl-symbol-macrolet` so it advises both, and we
    do that with a new `macroexpand` advice which delegates the bulk of
    the work to `macroexpand-1`.
    
    Along the way, I bumped into another bug in the interaction between
    `cl-letf` and `cl-symbol-macrolet`, which I tried to fix in `cl-letf`.
    
    I hear the war on `cl-symbol-macrolet` was a failure.
    Maybe ... just say no?
    
    * lisp/emacs-lisp/cl-macs.el (cl--sm-macroexpand-1): New function,
    extracted from `cl--sm-macroexpand`.
    (cl--sm-macroexpand): Rewrite completely.
    (cl-symbol-macrolet): Advise both `macroexpand` and `macroexpand-1`.
    (cl--letf): Don't use the "simple variable" code for symbol macros.
    
    * test/lisp/emacs-lisp/cl-lib-tests.el (cl-lib-symbol-macrolet-hide):
    Revert last change because the test was right.
    
    * test/lisp/emacs-lisp/cl-macs-tests.el
    (cl-macs-test--symbol-macrolet): Add a test case.
---
 lisp/emacs-lisp/cl-macs.el            | 266 +++++++++++++++++-----------------
 test/lisp/emacs-lisp/cl-lib-tests.el  |   3 -
 test/lisp/emacs-lisp/cl-macs-tests.el |   9 +-
 3 files changed, 141 insertions(+), 137 deletions(-)

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 9755c2636d..f8fdc50251 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2261,139 +2261,131 @@ This is like `cl-flet', but for macros instead of 
functions.
                                      (eval `(function (lambda ,@res)) t))
                               macroexpand-all-environment))))))
 
-(defun cl--sm-macroexpand (orig-fun exp &optional env)
+(defun cl--sm-macroexpand (exp &optional env)
+  "Special macro expander used inside `cl-symbol-macrolet'."
+  ;; FIXME: Arguably, this should be the official definition of `macroexpand'.
+  (while (not (eq exp (setq exp (macroexpand-1 exp env)))))
+  exp)
+
+(defun cl--sm-macroexpand-1 (orig-fun exp &optional env)
   "Special macro expander advice used inside `cl-symbol-macrolet'.
-This function extends `macroexpand' during macro expansion
+This function extends `macroexpand-1' during macro expansion
 of `cl-symbol-macrolet' to additionally expand symbol macros."
-  (let ((macroexpand-all-environment env)
+  (let ((exp (funcall orig-fun exp env))
         (venv (alist-get :cl-symbol-macros env)))
-    (while
-        (progn
-          (setq exp (funcall orig-fun exp env))
-          (pcase exp
-            ((pred symbolp)
-             ;; Perform symbol-macro expansion.
-             (let ((symval (assq exp venv)))
-               (when symval
-                 (setq exp (cadr symval)))))
-            (`(setq . ,args)
-             ;; Convert setq to setf if required by symbol-macro expansion.
-             (let ((convert nil)
-                   (rargs nil))
-               (while args
-                 (let ((place (pop args)))
-                   ;; Here, we know `place' should be a symbol.
-                   (while
-                       (let ((symval (assq place venv)))
-                         (when symval
-                           (setq place (cadr symval))
-                           (if (symbolp place)
-                               t        ;Repeat.
-                             (setq convert t)
-                             nil))))
-                   (push place rargs)
-                   (push (pop args) rargs)))
-               (setq exp (cons (if convert 'setf 'setq)
-                               (nreverse rargs)))
-               convert))
-            ;; CL's symbol-macrolet used to treat re-bindings as candidates for
-            ;; expansion (turning the let into a letf if needed), contrary to
-            ;; Common-Lisp where such re-bindings hide the symbol-macro.
-            ;; Not sure if there actually is code out there which depends
-            ;; on this behavior (haven't found any yet).
-            ;; Such code should explicitly use `cl-letf' instead, I think.
-            ;;
-            ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) 
pcase--dontcare))
-            ;;  (let ((letf nil) (found nil) (nbs ()))
-            ;;    (dolist (binding bindings)
-            ;;      (let* ((var (if (symbolp binding) binding (car binding)))
-            ;;             (sm (assq var venv)))
-            ;;        (push (if (not (cdr sm))
-            ;;                  binding
-            ;;                (let ((nexp (cadr sm)))
-            ;;                  (setq found t)
-            ;;                  (unless (symbolp nexp) (setq letf t))
-            ;;                  (cons nexp (cdr-safe binding))))
-            ;;              nbs)))
-            ;;    (when found
-            ;;      (setq exp `(,(if letf
-            ;;                       (if (eq (car exp) 'let) 'cl-letf 
'cl-letf*)
-            ;;                     (car exp))
-            ;;                  ,(nreverse nbs)
-            ;;                  ,@body)))))
-            ;;
-            ;; We implement the Common-Lisp behavior, instead (see bug#26073):
-            ;; The behavior of CL made sense in a dynamically scoped
-            ;; language, but nowadays, lexical scoping semantics is more often
-            ;; expected.
-            (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) pcase--dontcare))
-             (let ((nbs ()) (found nil))
-               (dolist (binding bindings)
-                 (let* ((var (if (symbolp binding) binding (car binding)))
-                        (val (and found (consp binding) (eq 'let* (car exp))
-                                  (list (macroexpand-all (cadr binding)
-                                                         env)))))
-                   (push (if (assq var venv)
-                             ;; This binding should hide "its" surrounding
-                             ;; symbol-macro, but given the way macroexpand-all
-                             ;; works (i.e. the `env' we receive as input will
-                             ;; be (re)applied to the code we return), we can't
-                             ;; prevent application of `env' to the
-                             ;; sub-expressions, so we need to α-rename this
-                             ;; variable instead.
-                             (let ((nvar (make-symbol (symbol-name var))))
-                               (setq found t)
-                               (push (list var nvar) venv)
-                               (push (cons :cl-symbol-macros venv) env)
-                               (cons nvar (or val (cdr-safe binding))))
-                           (if val (cons var val) binding))
-                         nbs)))
-               (when found
-                 (setq exp `(,(car exp)
-                             ,(nreverse nbs)
-                             ,@(macroexp-unprogn
-                                (macroexpand-all (macroexp-progn body)
-                                                 env)))))
-               nil))
-            ;; Do the same as for `let' but for variables introduced
-            ;; via other means, such as `lambda' and `condition-case'.
-            (`(function (lambda ,args . ,body))
-             (let ((nargs ()) (found nil))
-               (dolist (var args)
-                 (push (cond
-                        ((memq var '(&optional &rest)) var)
-                        ((assq var venv)
-                         (let ((nvar (make-symbol (symbol-name var))))
-                           (setq found t)
-                           (push (list var nvar) venv)
-                           (push (cons :cl-symbol-macros venv) env)
-                           nvar))
-                        (t var))
-                       nargs))
-               (when found
-                 (setq exp `(function
-                             (lambda ,(nreverse nargs)
-                               . ,(mapcar (lambda (exp)
-                                            (macroexpand-all exp env))
-                                          body)))))
-               nil))
-            ((and `(condition-case ,var ,exp . ,clauses)
-                  (guard (assq var venv)))
-             (let ((nvar (make-symbol (symbol-name var))))
-               (push (list var nvar) venv)
-               (push (cons :cl-symbol-macros venv) env)
-               (setq exp
-                     `(condition-case ,nvar ,(macroexpand-all exp env)
-                        . ,(mapcar
-                            (lambda (clause)
-                              `(,(car clause)
-                                . ,(mapcar (lambda (exp)
-                                             (macroexpand-all exp env))
-                                           (cdr clause))))
-                            clauses)))
-               nil))
-            )))
-    exp))
+    (pcase exp
+      ((pred symbolp)
+       ;; Try symbol-macro expansion.
+       (let ((symval (assq exp venv)))
+         (if symval (cadr symval) exp)))
+      (`(setq . ,args)
+       ;; Convert setq to setf if required by symbol-macro expansion.
+       (let ((convert nil))
+         (while args
+           (let* ((place (pop args))
+                  ;; Here, we know `place' should be a symbol.
+                  (symval (assq place venv)))
+             (pop args)
+             (when symval
+               (setq convert t))))
+         (if convert
+             (cons 'setf (cdr exp))
+           exp)))
+      ;; CL's symbol-macrolet used to treat re-bindings as candidates for
+      ;; expansion (turning the let into a letf if needed), contrary to
+      ;; Common-Lisp where such re-bindings hide the symbol-macro.
+      ;; Not sure if there actually is code out there which depends
+      ;; on this behavior (haven't found any yet).
+      ;; Such code should explicitly use `cl-letf' instead, I think.
+      ;;
+      ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) pcase--dontcare))
+      ;;  (let ((letf nil) (found nil) (nbs ()))
+      ;;    (dolist (binding bindings)
+      ;;      (let* ((var (if (symbolp binding) binding (car binding)))
+      ;;             (sm (assq var venv)))
+      ;;        (push (if (not (cdr sm))
+      ;;                  binding
+      ;;                (let ((nexp (cadr sm)))
+      ;;                  (setq found t)
+      ;;                  (unless (symbolp nexp) (setq letf t))
+      ;;                  (cons nexp (cdr-safe binding))))
+      ;;              nbs)))
+      ;;    (when found
+      ;;      (setq exp `(,(if letf
+      ;;                       (if (eq (car exp) 'let) 'cl-letf 'cl-letf*)
+      ;;                     (car exp))
+      ;;                  ,(nreverse nbs)
+      ;;                  ,@body)))))
+      ;;
+      ;; We implement the Common-Lisp behavior, instead (see bug#26073):
+      ;; The behavior of CL made sense in a dynamically scoped
+      ;; language, but nowadays, lexical scoping semantics is more often
+      ;; expected.
+      (`(,(or 'let 'let*) . ,(or `(,bindings . ,body) pcase--dontcare))
+       (let ((nbs ()) (found nil))
+         (dolist (binding bindings)
+           (let* ((var (if (symbolp binding) binding (car binding)))
+                  (val (and found (consp binding) (eq 'let* (car exp))
+                            (list (macroexpand-all (cadr binding)
+                                                   env)))))
+             (push (if (assq var venv)
+                       ;; This binding should hide "its" surrounding
+                       ;; symbol-macro, but given the way macroexpand-all
+                       ;; works (i.e. the `env' we receive as input will
+                       ;; be (re)applied to the code we return), we can't
+                       ;; prevent application of `env' to the
+                       ;; sub-expressions, so we need to α-rename this
+                       ;; variable instead.
+                       (let ((nvar (make-symbol (symbol-name var))))
+                         (setq found t)
+                         (push (list var nvar) venv)
+                         (push (cons :cl-symbol-macros venv) env)
+                         (cons nvar (or val (cdr-safe binding))))
+                     (if val (cons var val) binding))
+                   nbs)))
+         (if found
+             `(,(car exp)
+               ,(nreverse nbs)
+               ,@(macroexp-unprogn
+                  (macroexpand-all (macroexp-progn body)
+                                   env)))
+           exp)))
+      ;; Do the same as for `let' but for variables introduced
+      ;; via other means, such as `lambda' and `condition-case'.
+      (`(function (lambda ,args . ,body))
+       (let ((nargs ()) (found nil))
+         (dolist (var args)
+           (push (cond
+                  ((memq var '(&optional &rest)) var)
+                  ((assq var venv)
+                   (let ((nvar (make-symbol (symbol-name var))))
+                     (setq found t)
+                     (push (list var nvar) venv)
+                     (push (cons :cl-symbol-macros venv) env)
+                     nvar))
+                  (t var))
+                 nargs))
+         (if found
+             `(function
+               (lambda ,(nreverse nargs)
+                 . ,(mapcar (lambda (exp)
+                              (macroexpand-all exp env))
+                            body)))
+           exp)))
+      ((and `(condition-case ,var ,exp . ,clauses)
+            (guard (assq var venv)))
+       (let ((nvar (make-symbol (symbol-name var))))
+         (push (list var nvar) venv)
+         (push (cons :cl-symbol-macros venv) env)
+         `(condition-case ,nvar ,(macroexpand-all exp env)
+            . ,(mapcar
+                (lambda (clause)
+                  `(,(car clause)
+                    . ,(mapcar (lambda (exp)
+                                 (macroexpand-all exp env))
+                               (cdr clause))))
+                clauses))))
+      (_ exp))))
 
 ;;;###autoload
 (defmacro cl-symbol-macrolet (bindings &rest body)
@@ -2412,7 +2404,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf 
EXPANSION ...).
     (unwind-protect
         (progn
           (unless advised
-            (advice-add 'macroexpand :around #'cl--sm-macroexpand))
+            (advice-add 'macroexpand :override #'cl--sm-macroexpand)
+            (advice-add 'macroexpand-1 :around #'cl--sm-macroexpand-1))
           (let* ((venv (cdr (assq :cl-symbol-macros
                                   macroexpand-all-environment)))
                  (expansion
@@ -2428,7 +2421,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf 
EXPANSION ...).
                    expansion nil nil rev-malformed-bindings))
               expansion)))
       (unless advised
-        (advice-remove 'macroexpand #'cl--sm-macroexpand)))))
+        (advice-remove 'macroexpand   #'cl--sm-macroexpand)
+        (advice-remove 'macroexpand-1 #'cl--sm-macroexpand-1)))))
 
 ;;;###autoload
 (defmacro cl-with-gensyms (names &rest body)
@@ -2765,8 +2759,14 @@ Each PLACE may be a symbol, or any generalized variable 
allowed by `setf'.
            (place (car binding)))
       (gv-letplace (getter setter) place
         (macroexp-let2 nil vnew (cadr binding)
-          (if (symbolp place)
+          (if (and (symbolp place)
+                   ;; `place' could be some symbol-macro.
+                   (eq place getter))
               ;; Special-case for simple variables.
+              ;; FIXME: We currently only use this special case when `place'
+              ;; is a simple var.  Should we also use it when the
+              ;; macroexpansion of `place' is a simple var (i.e. when
+              ;; getter+setter is the same as that of a simple var)?
               (cl--letf (cdr bindings)
                         (cons `(,getter ,(if (cdr binding) vnew getter))
                               simplebinds)
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el 
b/test/lisp/emacs-lisp/cl-lib-tests.el
index 8d2b187e33..b19494af74 100644
--- a/test/lisp/emacs-lisp/cl-lib-tests.el
+++ b/test/lisp/emacs-lisp/cl-lib-tests.el
@@ -511,9 +511,6 @@
 
 
 (ert-deftest cl-lib-symbol-macrolet-hide ()
-  :expected-result :failed
-  ;; FIXME -- it's unclear what the semantics here should be, but
-  ;; 2dd1c2ab19f7fb99ecee flipped them.
   ;; bug#26325, bug#26073
   (should (equal (let ((y 5))
                    (cl-symbol-macrolet ((x y))
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el 
b/test/lisp/emacs-lisp/cl-macs-tests.el
index 2a647e0830..68898720d9 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -552,7 +552,14 @@ collection clause."
                          x)
                        x))
              (error err))
-           '(1 7 3))))
+           '(1 7 3)))
+  (should (equal
+           (let ((x (list 42)))
+             (cl-symbol-macrolet ((m (car x)))
+               (list m
+                     (cl-letf ((m 5)) m)
+                     m)))
+           '(42 5 42))))
 
 (ert-deftest cl-macs-loop-conditional-step-clauses ()
   "These tests failed under the initial fixes in #bug#29799."