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

Split variable macro env from function env

Browse source 
* lisp/emacs-lisp/cl-macs.el (cl--sm-macroexpand): Remove.
(cl-symbol-macrolet): Instead of adding each binding directly into the
main environment with a special key format, put all symbol macro
bindings into a single entry in the main environment under
`:cl-symbol-macros'.
(cl--sm-macroexpand): Look up symbol bindings in the
`:cl-symbol-macros' entry of the environment.
This commit is contained in:
Noam Postavsky 2017-04-21 23:37:05 -04:00
parent b52e40d756
commit 0648edf3e0
1 changed files with 28 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -2047,28 +2047,22 @@ This is like `cl-flet', but for macros instead of functions.
cl--old-macroexpand
(symbol-function 'macroexpand)))
(defun cl--symbol-macro-key (sym)
"Return the key used in `macroexpand-all-environment' for symbol macro SYM."
;; In the past we've used `symbol-name' instead, but that doesn't
;; preserve the `eq'uality between different symbols of the same name.
`(:cl-symbol-macro . ,sym))
(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 env))
(let ((macroexpand-all-environment env)
(venv (alist-get :cl-symbol-macros env)))
(while
(progn
(setq exp (funcall cl--old-macroexpand exp env))
(pcase exp
((pred symbolp)
;; Perform symbol-macro expansion.
;; FIXME: Calling `cl--symbol-macro-key' for every var reference
;; is a bit more costly than I'd like.
(when (cdr (assoc (cl--symbol-macro-key exp) env))
(setq exp (cadr (assoc (cl--symbol-macro-key exp) env)))))
(let ((symval (assq exp venv)))
(when symval
(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))
@ -2086,7 +2080,7 @@ except that it additionally expands symbol macros."
(let ((letf nil) (found nil) (nbs ()))
(dolist (binding bindings)
(let* ((var (if (symbolp binding) binding (car binding)))
(sm (assoc (cl--symbol-macro-key var) env)))
(sm (assq var venv)))
(push (if (not (cdr sm))
binding
(let ((nexp (cadr sm)))
@ -2144,30 +2138,28 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
\(fn ((NAME EXPANSION) ...) FORM...)"
(declare (indent 1) (debug ((&rest (symbolp sexp)) cl-declarations body)))
(cond
((cdr bindings)
`(cl-symbol-macrolet (,(car bindings))
(cl-symbol-macrolet ,(cdr bindings) ,@body)))
((null bindings) (macroexp-progn body))
(t
(let ((previous-macroexpand (symbol-function 'macroexpand)))
(unwind-protect
(progn
(fset 'macroexpand #'cl--sm-macroexpand)
(let ((expansion
;; FIXME: For N bindings, this will traverse `body' N times!
(macroexpand-all (macroexp-progn body)
(cons (list (cl--symbol-macro-key
(caar bindings))
(cl-cadar bindings))
macroexpand-all-environment))))
(if (or (null (cdar bindings)) (cl-cddar bindings))
(macroexp--warn-and-return
(format-message "Malformed `cl-symbol-macrolet' binding: %S"
(car bindings))
expansion)
expansion)))
(fset 'macroexpand previous-macroexpand))))))
(let ((previous-macroexpand (symbol-function 'macroexpand))
(malformed-bindings nil))
(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)))
(expansion
(macroexpand-all (macroexp-progn body)
(cons (cons :cl-symbol-macros
(append bindings venv))
macroexpand-all-environment))))
(if malformed-bindings
(macroexp--warn-and-return
(format-message "Malformed `cl-symbol-macrolet' binding(s): %S"
(nreverse malformed-bindings))
expansion)
expansion)))
(fset 'macroexpand previous-macroexpand))))
;;; Multiple values.