mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-09 15:50:40 -08:00
Code Issues Projects Releases Wiki Activity

* lisp/emacs-lisp/cl-macs.el (cl--sm-macroexpand): Fix handling of

Browse source 
re-binding a symbol that has a symbol-macro.

Fixes: debbugs:12119
This commit is contained in:
Stefan Monnier 2012-08-06 15:53:45 -04:00
parent 2b90362b19
commit ea3768613f
2 changed files with 79 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1668,31 +1668,86 @@ This is like `cl-flet', but for macros instead of functions.
cl--old-macroexpand
(symbol-function 'macroexpand)))
(defun cl--sm-macroexpand (cl-macro &optional cl-env)
(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."
(let ((macroexpand-all-environment cl-env))
(let ((macroexpand-all-environment env))
(while
(progn
(setq cl-macro (funcall cl--old-macroexpand cl-macro cl-env))
(cond
((symbolp cl-macro)
;; Perform symbol-macro expansion.
(when (cdr (assq (symbol-name cl-macro) cl-env))
(setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))))
((eq 'setq (car-safe cl-macro))
;; Convert setq to setf if required by symbol-macro expansion.
(let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f cl-env))
(cdr cl-macro)))
(p args))
(while (and p (symbolp (car p))) (setq p (cddr p)))
(if p (setq cl-macro (cons 'setf args))
(setq cl-macro (cons 'setq args))
;; Don't loop further.
nil))))))
cl-macro))
(setq exp (funcall cl--old-macroexpand exp env))
(pcase exp
((pred symbolp)
;; Perform symbol-macro expansion.
(when (cdr (assq (symbol-name exp) env))
(setq exp (cadr (assq (symbol-name exp) env)))))
(`(setq . ,_)
;; Convert setq to setf if required by symbol-macro expansion.
(let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f env))
(cdr exp)))
(p args))
(while (and p (symbolp (car p))) (setq p (cddr p)))
(if p (setq exp (cons 'setf args))
(setq exp (cons 'setq args))
;; Don't loop further.
nil)))
(`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare))
;; CL's symbol-macrolet treats 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.
(let ((letf nil) (found nil) (nbs ()))
(dolist (binding bindings)
(let* ((var (if (symbolp binding) binding (car binding)))
(sm (assq (symbol-name var) env)))
(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)))))
;; FIXME: The behavior of CL made sense in a dynamically scoped
;; language, but for lexical scoping, Common-Lisp's behavior might
;; make more sense (and indeed, CL behaves like Common-Lisp w.r.t
;; lexical-let), so maybe we should adjust the behavior based on
;; the use of lexical-binding.
;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare))
;; (let ((nbs ()) (found nil))
;; (dolist (binding bindings)
;; (let* ((var (if (symbolp binding) binding (car binding)))
;; (name (symbol-name var))
;; (val (and found (consp binding) (eq 'let* (car exp))
;; (list (macroexpand-all (cadr binding)
;; env)))))
;; (push (if (assq name env)
;; ;; This binding should hide its symbol-macro,
;; ;; but given the way macroexpand-all works, we
;; ;; can't prevent application of `env' to the
;; ;; sub-expressions, so we need to α-rename this
;; ;; variable instead.
;; (let ((nvar (make-symbol
;; (copy-sequence name))))
;; (setq found t)
;; (push (list name nvar) 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))
)))
exp))
;;;###autoload
(defmacro cl-symbol-macrolet (bindings &rest body)