From 6b183f85e02ae1b8527c1bbfa8c5e2c914d28f7c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 8 Feb 2018 21:40:46 -0500 Subject: [PATCH] * lisp/emacs-lisp/cl-macs.el (cl--sm-macroexpand): Handle lambda! (cl--old-macroexpand): Remove. (cl--sm-macroexpand): Change its calling convention, so it can use advice-add. Extend re-binding treatment of vars so it applies to all var-introducing forms rather than only to 'let'. (cl-symbol-macrolet): Use advice-add rather than fset. --- lisp/emacs-lisp/cl-macs.el | 78 +++++++++++++++++++++++++----------- test/lisp/emacs-lisp/cl-lib-tests.el | 7 ++-- 2 files changed, 59 insertions(+), 26 deletions(-) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 4aed1f26624..4d4640cbe0d 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2089,23 +2089,15 @@ This is like `cl-flet', but for macros instead of functions. (eval `(cl-function (lambda ,@(cdr res))) t)) macroexpand-all-environment)))))) -(defconst cl--old-macroexpand - (if (and (boundp 'cl--old-macroexpand) - (eq (symbol-function 'macroexpand) - #'cl--sm-macroexpand)) - cl--old-macroexpand - (symbol-function 'macroexpand))) - -(defun cl--sm-macroexpand (exp &optional env) - "Special macro expander used inside `cl-symbol-macrolet'. -This function replaces `macroexpand' during macro expansion -of `cl-symbol-macrolet', and does the same thing as `macroexpand' -except that it additionally expands symbol macros." +(defun cl--sm-macroexpand (orig-fun exp &optional env) + "Special macro expander advice used inside `cl-symbol-macrolet'. +This function extends `macroexpand' during macro expansion +of `cl-symbol-macrolet' to additionally expand symbol macros." (let ((macroexpand-all-environment env) (venv (alist-get :cl-symbol-macros env))) (while (progn - (setq exp (funcall cl--old-macroexpand exp env)) + (setq exp (funcall orig-fun exp env)) (pcase exp ((pred symbolp) ;; Perform symbol-macro expansion. @@ -2114,7 +2106,7 @@ except that it additionally expands symbol macros." (setq exp (cadr symval))))) (`(setq . ,_) ;; Convert setq to setf if required by symbol-macro expansion. - (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f env)) + (let* ((args (mapcar (lambda (f) (macroexpand f env)) (cdr exp))) (p args)) (while (and p (symbolp (car p))) (setq p (cddr p))) @@ -2160,10 +2152,10 @@ except that it additionally expands symbol macros." (list (macroexpand-all (cadr binding) env))))) (push (if (assq var venv) - ;; This binding should hide its 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 + ;; 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. @@ -2181,6 +2173,43 @@ except that it additionally expands symbol macros." (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)) @@ -2192,16 +2221,18 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" (declare (indent 1) (debug ((&rest (symbolp sexp)) cl-declarations body))) - (let ((previous-macroexpand (symbol-function 'macroexpand)) - (malformed-bindings nil)) + (let ((malformed-bindings nil) + (advised (advice-member-p #'cl--sm-macroexpand 'macroexpand))) (dolist (binding bindings) (unless (and (consp binding) (symbolp (car binding)) (consp (cdr binding)) (null (cddr binding))) (push binding malformed-bindings))) (unwind-protect (progn - (fset 'macroexpand #'cl--sm-macroexpand) - (let* ((venv (cdr (assq :cl-symbol-macros macroexpand-all-environment))) + (unless advised + (advice-add 'macroexpand :around #'cl--sm-macroexpand)) + (let* ((venv (cdr (assq :cl-symbol-macros + macroexpand-all-environment))) (expansion (macroexpand-all (macroexp-progn body) (cons (cons :cl-symbol-macros @@ -2213,7 +2244,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (nreverse malformed-bindings)) expansion) expansion))) - (fset 'macroexpand previous-macroexpand)))) + (unless advised + (advice-remove 'macroexpand #'cl--sm-macroexpand))))) ;;; Multiple values. diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 69d0a747105..f100e8c6c5f 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -518,13 +518,14 @@ (ert-deftest cl-lib-symbol-macrolet-hide () - ;; bug#26325 + ;; bug#26325, bug#26073 (should (equal (let ((y 5)) (cl-symbol-macrolet ((x y)) (list x (let ((x 6)) (list x y)) - (cl-letf ((x 6)) (list x y))))) - '(5 (6 5) (6 6))))) + (cl-letf ((x 6)) (list x y)) + (apply (lambda (x) (+ x 1)) (list 8))))) + '(5 (6 5) (6 6) 9)))) (defun cl-lib-tests--dummy-function () ;; Dummy function to see if the file is compiled. -- 2.11.4.GIT