[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH, RFC] Macros expansion changes, robust symbol macros, and constan
|
From: |
Daniel Colascione |
|
Subject: |
[PATCH, RFC] Macros expansion changes, robust symbol macros, and constant propagation |
|
Date: |
Tue, 17 Sep 2013 09:33:27 -0700 |
|
User-agent: |
Mozilla/5.0 (Macintosh; Intel Mac OS X 10.6; rv:17.0) Gecko/20130801 Thunderbird/17.0.8 |
Below, you'll find a patch that:
- removes Fmacroexpand and implements macroexpand-1 and macroexpand in lisp
- adds a facility for telling macroexpand-all not to re-expand macros
(effectively, providing for a variable macro expansion order)
- adds a facility for adding arbitrary hooks to the macro environment
(instead of having to bind fset)
- re-implements symbol-macros using this new facility
* no more problems with EQ symbol names
* shadowable and non-shadowable (let becomes letf) varieties
* lexical-binding code defaults to shadowable; dynamic code,
non-shadowable
* macros expanded only once, so no need to rename symbols
- adds symbol-macros to the core, in macroexp
- adds variable-capture analysis to macroexp
- changes cl-defsubst so that it works like regular defsubst
- fixes various cl-lib bugs using the new macrexp features and symbol-macros
- makes the generic variable support expand one macro at a time
- adds new byte-optimize code for `let' and `let*' that uses
symbol-macros to perform constant propagation
- adds tests for much of the above
Please take a look. The change needs a bit of polish, but it works
for me.
=== modified file 'lisp/emacs-lisp/byte-opt.el'
--- lisp/emacs-lisp/byte-opt.el 2013-09-05 03:46:34 +0000
+++ lisp/emacs-lisp/byte-opt.el 2013-09-17 14:10:48 +0000
@@ -1095,12 +1095,48 @@
(put 'let 'byte-optimizer 'byte-optimize-letX)
(put 'let* 'byte-optimizer 'byte-optimize-letX)
+
+(defun byte-optimize-do-constant-propagation (let-form)
+ (let* ((bindings (cadr let-form))
+ (body (cddr let-form))
+ (const-bindings)
+ (nonconst-bindings))
+ ;; Split bindings into const, nonconst sets. We'll collapse
+ ;; redundant nonconst bindings in the `symbol-macrolet'.
+ (let ((bc bindings))
+ (while bc
+ (let* ((binding (pop bc))
+ (var (or (car-safe binding) binding))
+ (val (and (consp binding) (cadr binding))))
+ (cond ((and (not (special-variable-p var))
+ (macroexp-const-p val))
+ (push (list var val) const-bindings))
+ ((and (eq (car let-form) 'let*)
+ const-bindings
+ nonconst-bindings)
+ ;; Handle the rest of the let* forms as a child;
+ ;; we'll combine the nested let*s later.
+ (setq body `((let* (,binding ,@bc) ,@body)))
+ (setq bc nil))
+ (t (push binding nonconst-bindings))))))
+ (if (not const-bindings)
+ form
+ `(,(car let-form)
+ ,nonconst-bindings
+ ,@(macroexp-unprogn
+ (macroexpand-all
+ `(symbol-macrolet-shadowable
+ ,(nreverse const-bindings)
+ ,@body)))))))
+
(defun byte-optimize-letX (form)
(cond ((null (nth 1 form))
;; No bindings
(cons 'progn (cdr (cdr form))))
((or (nth 2 form) (nthcdr 3 form))
- form)
+ (if lexical-binding
+ (byte-optimize-do-constant-propagation form)
+ form))
;; The body is nil
((eq (car form) 'let)
(append '(progn) (mapcar 'car-safe (mapcar 'cdr-safe (nth 1 form)))
@@ -1219,7 +1255,7 @@
window-left-child window-left-column window-margins window-minibuffer-p
window-next-buffers window-next-sibling window-new-normal
window-new-total window-normal-size window-parameter window-parameters
- window-parent window-pixel-edges window-point window-prev-buffers
+ window-parent window-pixel-edges window-point window-prev-buffers
window-prev-sibling window-redisplay-end-trigger window-scroll-bars
window-start window-text-height window-top-child window-top-line
window-total-height window-total-width window-use-time window-vscroll
=== modified file 'lisp/emacs-lisp/cl-macs.el'
--- lisp/emacs-lisp/cl-macs.el 2013-08-29 03:49:10 +0000
+++ lisp/emacs-lisp/cl-macs.el 2013-09-17 16:12:47 +0000
@@ -139,22 +139,14 @@
(defun cl--expr-contains (x y)
"Count number of times X refers to Y. Return nil for 0 times."
- ;; FIXME: This is naive, and it will cl-count Y as referred twice in
- ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on
- ;; non-macroexpanded code, so it may also miss some occurrences that would
- ;; only appear in the expanded code.
- (cond ((equal y x) 1)
- ((and (consp x) (not (memq (car x) '(quote function cl-function))))
- (let ((sum 0))
- (while (consp x)
- (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0))))
- (setq sum (+ sum (or (cl--expr-contains x y) 0)))
- (and (> sum 0) sum)))
- (t nil)))
+ (let ((info (assq y (macroexp-analyze-free-variables x))))
+ (and info (max 1 (cl-fourth info)))))
(defun cl--expr-contains-any (x y)
- (while (and y (not (cl--expr-contains x (car y)))) (pop y))
- y)
+ "Does X contain any variable in Y?"
+ (cl-loop for (v . _) in (macroexp-analyze-free-variables x)
+ if (memq v y)
+ return t))
(defun cl--expr-depends-p (x y)
"Check whether X may depend on any of the symbols in Y."
@@ -864,7 +856,7 @@
(setq body (list (cl--loop-let lets body nil))))))
(if cl--loop-symbol-macs
(setq body
- (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body))))
+ (list `(symbol-macrolet ,cl--loop-symbol-macs ,@body))))
`(cl-block ,cl--loop-name ,@body)))))
;; Below is a complete spec for cl-loop, in several parts that correspond
@@ -1056,10 +1048,7 @@
(let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
(ands nil))
(while
- ;; Use `cl-gensym' rather than `make-symbol'. It's important that
- ;; (not (eq (symbol-name var1) (symbol-name var2))) because
- ;; these vars get added to the macro-environment.
- (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--"))))
+ (let ((var (or (pop cl--loop-args) (make-symbol "--cl-var--"))))
(setq word (pop cl--loop-args))
(if (eq word 'being) (setq word (pop cl--loop-args)))
(if (memq word '(the each)) (setq word (pop cl--loop-args)))
@@ -1446,11 +1435,12 @@
(if (eq word 'unless) (setq then (prog1 else (setq else then))))
(let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
(if simple (nth 1 else) (list (nth 2 else))))))
- (if (cl--expr-contains form 'it)
+ (if (cl--expr-contains (macroexp-progn form) 'it)
(let ((temp (make-symbol "--cl-var--")))
(push (list temp) cl--loop-bindings)
(setq form `(if (setq ,temp ,cond)
- ,@(cl-subst temp 'it form))))
+ (symbol-macrolet-shadowable ((it ,temp))
+ ,@form))))
(setq form `(if ,cond ,@form)))
(push (if simple `(progn ,form t) form) cl--loop-body))))
@@ -1814,8 +1804,6 @@
(if (assq 'function newenv) newenv
(cons (cons 'function #'cl--labels-convert) newenv)))))
-;; The following ought to have a better definition for use with newer
-;; byte compilers.
;;;###autoload
(defmacro cl-macrolet (bindings &rest body)
"Make temporary macro definitions.
@@ -1837,118 +1825,7 @@
(cons (cons name `(lambda ,@(cdr res)))
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."
- (let ((macroexpand-all-environment env))
- (while
- (progn
- (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)
- "Make symbol macro definitions.
-Within the body FORMs, references to the variable NAME will be replaced
-by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
-
-\(fn ((NAME EXPANSION) ...) FORM...)"
- (declare (indent 1) (debug ((&rest (symbol 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)
- ;; FIXME: For N bindings, this will traverse `body' N times!
- (macroexpand-all (cons 'progn body)
- (cons (list (symbol-name (caar bindings))
- (cl-cadar bindings))
- macroexpand-all-environment)))
- (fset 'macroexpand previous-macroexpand))))))
+(defalias 'cl-symbol-macrolet 'symbol-macrolet)
;;; Multiple values.
@@ -2153,85 +2030,8 @@
(macroexp-let* `((,temp ,getter))
`(progn ,(funcall setter form) nil))))))
-;; FIXME: `letf' is unsatisfactory because it does not really "restore" the
-;; previous state. If the getter/setter loses information, that info is
-;; not recovered.
-
-(defun cl--letf (bindings simplebinds binds body)
- ;; It's not quite clear what the semantics of cl-letf should be.
- ;; E.g. in (cl-letf ((PLACE1 VAL1) (PLACE2 VAL2)) BODY), while it's clear
- ;; that the actual assignments ("bindings") should only happen after
- ;; evaluating VAL1 and VAL2, it's not clear when the sub-expressions of
- ;; PLACE1 and PLACE2 should be evaluated. Should we have
- ;; PLACE1; VAL1; PLACE2; VAL2; bind1; bind2
- ;; or
- ;; VAL1; VAL2; PLACE1; PLACE2; bind1; bind2
- ;; or
- ;; VAL1; VAL2; PLACE1; bind1; PLACE2; bind2
- ;; Common-Lisp's `psetf' does the first, so we'll do the same.
- (if (null bindings)
- (if (and (null binds) (null simplebinds)) (macroexp-progn body)
- `(let* (,@(mapcar (lambda (x)
- (pcase-let ((`(,vold ,getter ,_setter ,_vnew) x))
- (list vold getter)))
- binds)
- ,@simplebinds)
- (unwind-protect
- ,(macroexp-progn
- (append
- (delq nil
- (mapcar (lambda (x)
- (pcase x
- ;; If there's no vnew, do nothing.
- (`(,_vold ,_getter ,setter ,vnew)
- (funcall setter vnew))))
- binds))
- body))
- ,@(mapcar (lambda (x)
- (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x))
- (funcall setter vold)))
- binds))))
- (let ((binding (car bindings)))
- (gv-letplace (getter setter) (car binding)
- (macroexp-let2 nil vnew (cadr binding)
- (if (symbolp (car binding))
- ;; Special-case for simple variables.
- (cl--letf (cdr bindings)
- (cons `(,getter ,(if (cdr binding) vnew getter))
- simplebinds)
- binds body)
- (cl--letf (cdr bindings) simplebinds
- (cons `(,(make-symbol "old") ,getter ,setter
- ,@(if (cdr binding) (list vnew)))
- binds)
- body)))))))
-
-;;;###autoload
-(defmacro cl-letf (bindings &rest body)
- "Temporarily bind to PLACEs.
-This is the analogue of `let', but with generalized variables (in the
-sense of `setf') for the PLACEs. Each PLACE is set to the corresponding
-VALUE, then the BODY forms are executed. On exit, either normally or
-because of a `throw' or error, the PLACEs are set back to their original
-values. Note that this macro is *not* available in Common Lisp.
-As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
-the PLACE is not modified before executing BODY.
-
-\(fn ((PLACE VALUE) ...) BODY...)"
- (declare (indent 1) (debug ((&rest (gate gv-place &optional form)) body)))
- (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
- `(let ,bindings ,@body)
- (cl--letf bindings () () body)))
-
-;;;###autoload
-(defmacro cl-letf* (bindings &rest body)
- "Temporarily bind to PLACEs.
-Like `cl-letf' but where the bindings are performed one at a time,
-rather than all at the end (i.e. like `let*' rather than like `let')."
- (declare (indent 1) (debug cl-letf))
- (dolist (binding (reverse bindings))
- (setq body (list `(cl-letf (,binding) ,@body))))
- (macroexp-progn body))
+(defalias 'cl-letf 'letf)
+(defalias 'cl-letf* 'letf*)
;;;###autoload
(defmacro cl-callf (func place &rest args)
@@ -2264,6 +2064,28 @@
;;; Structures.
;;;###autoload
+(defun cl--struct-setf-expander (x name accessor pred-form pos)
+ (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
+ (list (list temp) (list x) (list store)
+ `(progn
+ ,@(and pred-form
+ (list `(or ,(cl-subst temp 'cl-x pred-form)
+ (error ,(format
+ "%s storing a non-%s"
+ accessor name)))))
+ ,(if (eq (car (get name 'cl-struct-type)) 'vector)
+ `(aset ,temp ,pos ,store)
+ `(setcar
+ ,(if (<= pos 5)
+ (let ((xx temp))
+ (while (>= (setq pos (1- pos)) 0)
+ (setq xx `(cdr ,xx)))
+ xx)
+ `(nthcdr ,pos ,temp))
+ ,store)))
+ (list accessor temp))))
+
+;;;###autoload
(defmacro cl-defstruct (struct &rest descs)
"Define a struct type.
This macro defines a new data type called NAME that stores data
@@ -2448,24 +2270,20 @@
(lambda (_cl-do _cl-x)
(error "%s is a read-only slot" ',accessor)))
forms)
- ;; For normal slots, we don't need to define a setf-expander,
- ;; since gv-get can use the compiler macro to get the
- ;; same result.
- ;; (push `(gv-define-setter ,accessor (cl-val cl-x)
- ;; ;; If cl is loaded only for compilation,
- ;; ;; the call to cl--struct-setf-expander would
- ;; ;; cause a warning because it may not be
- ;; ;; defined at run time. Suppress that warning.
- ;; (progn
- ;; (declare-function
- ;; cl--struct-setf-expander "cl-macs"
- ;; (x name accessor pred-form pos))
- ;; (cl--struct-setf-expander
- ;; cl-val cl-x ',name ',accessor
- ;; ,(and pred-check `',pred-check)
- ;; ,pos)))
- ;; forms)
- )
+ (push `(define-setf-expander ,accessor (cl-x)
+ ;; If cl is loaded only for compilation,
+ ;; the call to cl--struct-setf-expander would
+ ;; cause a warning because it may not be
+ ;; defined at run time. Suppress that warning.
+ (progn
+ (declare-function
+ cl--struct-setf-expander "cl-macs"
+ (x name accessor pred-form pos))
+ (cl--struct-setf-expander
+ cl-x ',name ',accessor
+ ,(and pred-check `',pred-check)
+ ,pos)))
+ forms))
(if print-auto
(nconc print-func
(list `(princ ,(format " %s" slot) cl-s)
@@ -2679,11 +2497,10 @@
(cl-body (macroexpand-all ;Performs compiler-macro expansions.
(cons 'progn (cddr cl-form))
macroexpand-all-environment)))
- ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able
- ;; to indicate that this return value is already fully expanded.
- (if (cdr cl-entry)
- `(catch ,(nth 1 cl-form) ,@(cdr cl-body))
- cl-body)))
+ (list macroexpand-already-expanded
+ (if (cdr cl-entry)
+ `(catch ,(nth 1 cl-form) ,@(cdr cl-body))
+ cl-body))))
(cl-define-compiler-macro cl--block-throw (cl-tag cl-value)
(let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names)))
@@ -2691,37 +2508,22 @@
`(throw ,cl-tag ,cl-value))
;;;###autoload
+
(defmacro cl-defsubst (name args &rest body)
- "Define NAME as a function.
-Like `defun', except the function is automatically declared `inline' and
-the arguments are immutable.
-ARGLIST allows full Common Lisp conventions, and BODY is implicitly
-surrounded by (cl-block NAME ...).
-The function's arguments should be treated as immutable.
+ "Define NAME as an inline function.
+Like `defsubst', except that ARGLIST allows full Common Lisp
+conventions, and BODY is implicitly surrounded
+by (cl-block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(declare (debug cl-defun) (indent 2))
- (let* ((argns (cl--arglist-args args)) (p argns)
- (pbody (cons 'progn body)))
- (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p))
- `(progn
- ,(if p nil ; give up if defaults refer to earlier args
- `(cl-define-compiler-macro ,name
- ,(if (memq '&key args)
- `(&whole cl-whole &cl-quote ,@args)
- (cons '&cl-quote args))
- (cl--defsubst-expand
- ',argns '(cl-block ,name ,@body)
- ;; We used to pass `simple' as
- ;; (not (or unsafe (cl-expr-access-order pbody argns)))
- ;; But this is much too simplistic since it
- ;; does not pay attention to the argvs (and
- ;; cl-expr-access-order itself is also too naive).
- nil
- ,(and (memq '&key args) 'cl-whole) nil ,@argns)))
- (cl-defun ,name ,args ,@body))))
+ (let* ((res (cl--transform-lambda (cons args body) name))
+ (form `(defsubst ,name ,@(cdr res))))
+ (if (car res) `(progn ,(car res) ,form) form)))
-(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs)
+(defun cl--defsubst-expand (argns body simple whole unsafe &rest argvs)
+ ;; This function is obsolete and is kept only for compatibility with
+ ;; old byte-compiled files that provide substs to inline.
(if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole
(if (cl--simple-exprs-p argvs) (setq simple t))
(let* ((substs ())
@@ -2729,14 +2531,12 @@
(cl-mapcar (lambda (argn argv)
(if (or simple (macroexp-const-p argv))
(progn (push (cons argn argv) substs)
- nil)
+ (and unsafe (list argn argv)))
(list argn argv)))
argns argvs))))
- ;; FIXME: `sublis/subst' will happily substitute the symbol
- ;; `argn' in places where it's not used as a reference
- ;; to a variable.
- ;; FIXME: `sublis/subst' will happily copy `argv' to a different
- ;; scope, leading to name capture.
+ ;; The use of `cl-sublis' and `cl-subst' is incredibly unsafe,
+ ;; but since we don't use `cl--defsubst-expand' for new code,
+ ;; let's leave it be.
(setq body (cond ((null substs) body)
((null (cdr substs))
(cl-subst (cdar substs) (caar substs) body))
=== modified file 'lisp/emacs-lisp/cl.el'
--- lisp/emacs-lisp/cl.el 2013-01-30 08:07:37 +0000
+++ lisp/emacs-lisp/cl.el 2013-09-17 16:25:48 +0000
@@ -352,7 +352,7 @@
(macroexpand-all f macroexpand-all-environment))
(cddr f))))
(if (and cl-closure-vars
- (cl--expr-contains-any body cl-closure-vars))
+ (cl--expr-contains-any (macroexp-progn body) cl-closure-vars))
(let* ((new (mapcar 'cl-gensym cl-closure-vars))
(sub (cl-pairlis cl-closure-vars new)) (decls nil))
(while (or (stringp (car body))
@@ -697,27 +697,9 @@
list)
;; Used in the expansion of the old `defstruct'.
-(defun cl-struct-setf-expander (x name accessor pred-form pos)
- (declare (obsolete nil "24.3"))
- (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
- (list (list temp) (list x) (list store)
- `(progn
- ,@(and pred-form
- (list `(or ,(cl-subst temp 'cl-x pred-form)
- (error ,(format
- "%s storing a non-%s"
- accessor name)))))
- ,(if (eq (car (get name 'cl-struct-type)) 'vector)
- `(aset ,temp ,pos ,store)
- `(setcar
- ,(if (<= pos 5)
- (let ((xx temp))
- (while (>= (setq pos (1- pos)) 0)
- (setq xx `(cdr ,xx)))
- xx)
- `(nthcdr ,pos ,temp))
- ,store)))
- (list accessor temp))))
+(define-obsolete-function-alias
+ 'cl-struct-setf-expander
+ 'cl--struct-setf-expander "24.3")
(provide 'cl)
=== modified file 'lisp/emacs-lisp/gv.el'
--- lisp/emacs-lisp/gv.el 2013-09-04 20:03:52 +0000
+++ lisp/emacs-lisp/gv.el 2013-09-17 11:24:04 +0000
@@ -250,6 +250,82 @@
(while args (push `(setf ,(pop args) ,(pop args)) sets))
(cons 'progn (nreverse sets)))))
+(defun gv--letf (bindings simplebinds binds body)
+ ;; It's not quite clear what the semantics of letf should be.
+ ;; E.g. in (letf ((PLACE1 VAL1) (PLACE2 VAL2)) BODY), while it's clear
+ ;; that the actual assignments ("bindings") should only happen after
+ ;; evaluating VAL1 and VAL2, it's not clear when the sub-expressions of
+ ;; PLACE1 and PLACE2 should be evaluated. Should we have
+ ;; PLACE1; VAL1; PLACE2; VAL2; bind1; bind2
+ ;; or
+ ;; VAL1; VAL2; PLACE1; PLACE2; bind1; bind2
+ ;; or
+ ;; VAL1; VAL2; PLACE1; bind1; PLACE2; bind2
+ ;; Common-Lisp's `psetf' does the first, so we'll do the same.
+ (if (null bindings)
+ (if (and (null binds) (null simplebinds)) (macroexp-progn body)
+ `(let* (,@(mapcar (lambda (x)
+ (pcase-let ((`(,vold ,getter ,_setter ,_vnew) x))
+ (list vold getter)))
+ binds)
+ ,@simplebinds)
+ (unwind-protect
+ ,(macroexp-progn
+ (append
+ (delq nil
+ (mapcar (lambda (x)
+ (pcase x
+ ;; If there's no vnew, do nothing.
+ (`(,_vold ,_getter ,setter ,vnew)
+ (funcall setter vnew))))
+ binds))
+ body))
+ ,@(mapcar (lambda (x)
+ (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x))
+ (funcall setter vold)))
+ binds))))
+ (let ((binding (car bindings)))
+ (gv-letplace (getter setter) (car binding)
+ (macroexp-let2 nil vnew (cadr binding)
+ (if (symbolp (car binding))
+ ;; Special-case for simple variables.
+ (gv--letf (cdr bindings)
+ (cons `(,getter ,(if (cdr binding) vnew getter))
+ simplebinds)
+ binds body)
+ (gv--letf (cdr bindings) simplebinds
+ (cons `(,(make-symbol "old") ,getter ,setter
+ ,@(if (cdr binding) (list vnew)))
+ binds)
+ body)))))))
+
+;;;###autoload
+(defmacro letf (bindings &rest body)
+ "Temporarily bind to PLACEs.
+This is the analogue of `let', but with generalized variables (in the
+sense of `setf') for the PLACEs. Each PLACE is set to the corresponding
+VALUE, then the BODY forms are executed. On exit, either normally or
+because of a `throw' or error, the PLACEs are set back to their original
+values. Note that this macro is *not* available in Common Lisp.
+As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
+the PLACE is not modified before executing BODY.
+
+\(fn ((PLACE VALUE) ...) BODY...)"
+ (declare (indent 1) (debug ((&rest (gate gv-place &optional form)) body)))
+ (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
+ `(let ,bindings ,@body)
+ (gv--letf bindings () () body)))
+
+;;;###autoload
+(defmacro letf* (bindings &rest body)
+ "Temporarily bind to PLACEs.
+Like `letf' but where the bindings are performed one at a time,
+rather than all at the end (i.e. like `let*' rather than like `let')."
+ (declare (indent 1) (debug letf))
+ (dolist (binding (reverse bindings))
+ (setq body (list `(letf (,binding) ,@body))))
+ (macroexp-progn body))
+
;; (defmacro gv-pushnew! (val place)
;; "Like `gv-push!' but only adds VAL if it's not yet in PLACE.
;; Presence is checked with `member'.
=== modified file 'lisp/emacs-lisp/macroexp.el'
--- lisp/emacs-lisp/macroexp.el 2013-06-05 02:35:40 +0000
+++ lisp/emacs-lisp/macroexp.el 2013-09-17 13:37:45 +0000
@@ -119,7 +119,6 @@
(member '(declare-function . byte-compile-macroexpand-declare-function)
macroexpand-all-environment))
-
(defun macroexp--warn-and-return (msg form)
(let ((when-compiled (lambda () (byte-compile-log-warning msg t))))
(cond
@@ -144,6 +143,11 @@
(instead (format "; use `%s' instead." instead))
(t ".")))))
+(defvar XXX-debug-macroexp nil)
+(defmacro macroexp-debug (&rest forms)
+ `(when XXX-debug-macroexp
+ (funcall 'debug ,@forms)))
+
(defun macroexp--expand-all (form)
"Expand all macros in FORM.
This is an internal version of `macroexpand-all'.
@@ -157,7 +161,7 @@
macroexpand-all-environment)
;; Normal form; get its expansion, and then expand arguments.
(let ((new-form
- (macroexpand form macroexpand-all-environment)))
+ (macroexpand form macroexpand-all-environment t)))
(setq form
(if (and (not (eq form new-form)) ;It was a macro call.
(car-safe form)
@@ -175,6 +179,8 @@
new-form))
new-form)))
(pcase form
+ (`(,(pred (eq macroexpand-already-expanded)) ,expanded-form)
+ expanded-form)
(`(cond . ,clauses)
(macroexp--cons 'cond (macroexp--all-clauses clauses) form))
(`(condition-case . ,(or `(,err ,body . ,handlers) dontcare))
@@ -367,6 +373,346 @@
"Return non-nil if EXP can be copied without extra cost."
(or (symbolp exp) (macroexp-const-p exp)))
+(defun macroexp--merge-analysis (a1 a2)
+ "Merge two `macroexp-analyze-free-variables' forms.
+Returns the merged analysis. This operation is non-destructive."
+ (let (new)
+ (dolist (i1 a1)
+ (let ((i2 (assq (car i1) a2)))
+ (push
+ (if (null i2) i1
+ (list
+ ;; VAR
+ (progn (pop i1) (pop i2))
+ ;; MUTATED
+ (let ((m2 (pop i2)))
+ (or (pop i1) m2))
+ ;; USED-UNDER
+ (delete-dups (append (pop i1) (copy-sequence (pop i2))))
+ ;; TIMES-EAD
+ (+ (pop i1) (pop i2))))
+ new)))
+ (dolist (i2 a2)
+ (unless (assq (car i2) new)
+ (push i2 new)))
+ new))
+
+(defsubst macroexp-arglist-args (arglist)
+ "Return args bound by ARGLIST."
+ (remq '&optional (remq '&rest arglist)))
+
+(defun macroexp-analyze-free-variables (exp &optional bound)
+ "Analyze EXP's use of free variables.
+Return ANALYSIS. ANALYSIS is an alist (VAR . INFO), where each
+VAR is an unbound variable to which EXP refers. INFO is a
+list (MUTATED USED-UNDER TIMES-READ). MUTATED is a boolean
+indicating whther VAR was changed. USED-UNDER is a set (list) of
+variables bound by EXP at some point VAR was referenced or set.
+TIMES-READ is a count of the number of times VAR was evaluated.
+
+BOUND is used internally.
+
+EXP should already be macroexpanded."
+ (pcase exp
+ ((pred symbolp)
+ (if (or (keywordp exp)
+ (memq exp '(nil t))
+ (memq exp bound))
+ nil
+ `((,exp nil ,bound 1))))
+ (`(setq . ,args)
+ (let (info)
+ (while args
+ (let* ((var (pop args))
+ (val (pop args)))
+ (unless (memq var bound)
+ (setq info (macroexp--merge-analysis
+ info
+ `((,var t ,bound 0)))))
+ (setq info (macroexp--merge-analysis
+ info
+ (macroexp-analyze-free-variables
+ val bound)))))
+ info))
+ (`(,(or `let `let*) ,bindings . ,body)
+ (let ((is-* (eq (car exp) 'let*))
+ (orig-bound bound)
+ (info nil))
+ (dolist (binding bindings)
+ (let ((var (or (car-safe binding) binding))
+ (val (car (cdr-safe binding))))
+ (setq info
+ (macroexp--merge-analysis
+ info
+ (macroexp-analyze-free-variables
+ val
+ (if is-* bound orig-bound))))
+ (push var bound)))
+ (macroexp--merge-analysis
+ info
+ (macroexp-analyze-free-variables
+ (macroexp-progn body)
+ bound))))
+ (`(function (,(or `lambda `closure) . ,_))
+ (macroexp-analyze-free-variables
+ (cadr exp) bound))
+ (`(,(or `quote `function) . ,_) nil)
+ (`(lambda ,arglist . ,body)
+ (macroexp-analyze-free-variables
+ (macroexp-progn body)
+ (append (macroexp-arglist-args arglist) bound)))
+ (`(closure ,cells ,arglist . ,body)
+ (dolist (cell cells)
+ (when (consp cell)
+ (push (car cell) bound)))
+ (macroexp-analyze-free-variables
+ (macroexp-progn body)
+ (append (macroexp-arglist-args arglist) bound)))
+ (`(condition-case ,var ,body . ,handlers)
+ (let ((info (macroexp-analyze-free-variables body bound)))
+ (when var (push var bound))
+ (dolist (handler handlers info)
+ (setq info
+ (macroexp--merge-analysis
+ info
+ (macroexp-analyze-free-variables
+ (macroexp-progn (cdr handler))
+ bound))))))
+ (`(interactive . ,_) nil)
+ (`(,_ . ,body)
+ (let (info)
+ (dolist (form body info)
+ (setq info
+ (macroexp--merge-analysis
+ info
+ (macroexp-analyze-free-variables
+ form
+ bound))))))))
+
+
+;;; symbol-macros
+
+(defconst macroexp--sm-environment-tag
+ (if (boundp 'macroexp--sm-environment-tag)
+ (symbol-value 'macroexp--sm-environment-tag)
+ (make-symbol "--macroexp--sm-environment-tag--"))
+ "Special uninterned symbol used in macro environments to signal
+the presence of a symbol macro binding. A full symbol macro
+binding element is of the form (macroexp--sm-environment-tag VAR
+BINDING KIND), where KIND is 'symbol-macrolet-shadowable,
+'symbol-macrolet-non-shadowable, to indicate showable and
+non-shadowable bindings. If a binding is instead
+just (macroexp--sm-environment-tag VAR), the binding indicates
+the lack of a symbol macro binding and shadows any binding lower
+in the environment stack.")
+
+(defun macroexp--memq-car-and-cadr (key1 key2 alist)
+ "Find items (KEY1 KEY2 ...) in ALIST.
+Return the cons cell the car of which is that element."
+ (while (and (setq alist (memq-car key1 alist))
+ (not (eq (cadr (car alist)) key2))
+ (setq alist (cdr alist))))
+ alist)
+
+(defun macroexp--sm-assoc (var env)
+ "Find symbol macro binding for VAR in ENV.
+If VAR not in the environment, or if VAR is shadowed, return nil.
+Otherwise return a list (VALUE SHADOWABLE-FLAG)."
+ ;; Search for binding
+ (setq env (macroexp--memq-car-and-cadr
+ macroexp--sm-environment-tag var env))
+ ;; If it's a shadow binding, return nil instead.
+ (setq env (cdr (cdr (car env))))
+ (and (cadr env) env))
+
+(defun macroexp--sm-macroexpand-1 (exp &optional env)
+ "Special macro expander used inside `symbol-macrolet'.
+This function replaces `macroexpand-1' during macro expansion of
+`symbol-macrolet' and does the same thing as `macroexpand-1',
+except that it additionally expands symbol macros."
+ (pcase exp
+ ((pred symbolp)
+ ;; Perform symbol-macro expansion.
+ (pcase (macroexp--sm-assoc exp env)
+ (`(,binding . ,_) binding)
+ (_ exp)))
+ (`(setq . ,args)
+ ;; Convert setq to setf if required by symbol-macro expansion.
+ (let (complex p)
+ (setf p args)
+ (while (and p (not complex))
+ (when (macroexp--sm-assoc (car p) env)
+ (setq complex t))
+ (setq p (cddr p)))
+ (if complex
+ (let ((parts))
+ (setf p args)
+ (while p
+ (setq parts
+ (list* (let ((sm (macroexp--sm-assoc (car p) env)))
+ (if sm (car sm) (car p)))
+ (cadr p)
+ parts))
+ (setq p (cddr p)))
+ `(setf ,@parts))
+ exp)))
+ (`(,(or `let `let*) ,bindings . ,body)
+ ;; Process various kinds of shadowing and non-shadowing lets.
+ (let* ((letform (car exp))
+ (is-* (eq letform 'let*))
+ (is-any-lex nil)
+ (is-any-non-shadowable nil))
+ (dolist (binding bindings)
+ (let* ((var (or (car-safe binding) binding))
+ (sm (macroexp--sm-assoc var env)))
+ (when sm (setq is-any-lex t))
+ (when (eq (cadr sm) 'symbol-macrolet-non-shadowable)
+ (setq is-any-non-shadowable t))))
+ (cond ((not is-any-lex) exp)
+ ((and (not is-any-non-shadowable))
+ (let ((orig-env env) (new-bindings nil))
+ (dolist (binding bindings)
+ (let* ((var (or (car-safe binding) binding))
+ (newvalue
+ (and (consp binding)
+ (cadr binding)
+ (macroexpand-all (cadr binding)
+ (if is-* env orig-env)))))
+ ;; Collect new binding
+ (push (list var newvalue) new-bindings)
+ ;; Add shadow to macro environment
+ (when (macroexp--sm-assoc var env)
+ (push (list macroexp--sm-environment-tag var) env))))
+ (list macroexpand-already-expanded
+ (list letform
+ (nreverse new-bindings)
+ (macroexpand-all (macroexp-progn body) env)))))
+ ((and is-* (cdr bindings))
+ (list letform
+ (list (car bindings))
+ (append (list letform (cdr bindings)) body)))
+ ((not (cdr bindings))
+ (let* ((binding (car bindings))
+ (var (or (car-safe binding) binding))
+ (value (car (cdr-safe binding)))
+ (sm (macroexp--sm-assoc var env)))
+ `(letf ((,(car sm) ,value))
+ ,@body)))
+ (t
+ (list macroexpand-already-expanded
+ (macroexpand-all
+ (gv--letf bindings nil nil body)
+ env))))))
+ (`(lambda ,arglist . ,_)
+ ;; Lambda arguments always shadow symbol macros
+ (let* ((orig-env env))
+ (dolist (aname (macroexp-arglist-args arglist))
+ (when (macroexp--sm-assoc aname env) ; Add shadow if s-m
+ (push (list macroexp--sm-environment-tag aname) env)))
+ (if (eq orig-env env)
+ exp
+ (list macroexpand-already-expanded
+ (macroexpand-all exp env)))))
+ (`(condition-case ,var ,bodyform . ,handlers)
+ ;; Condition-case always shadows symbol macros, but only in
+ ;; condition handler forms.
+ (if (null var)
+ exp
+ (list macroexpand-already-expanded
+ `(condition-case ,var
+ ,(macroexpand-all bodyform env)
+ ,@(let (new-handlers)
+ (push (list macroexp--sm-environment-tag var) env)
+ (dolist (handler handlers new-handlers)
+ (push (cons (car handler)
+ (macroexp-unprogn
+ (macroexpand-all
+ (macroexp-progn (cdr handler))
+ env)))
+ new-handlers)))))))
+ (`(function (lambda . ,_))
+ ;; macroexpand-all has special logic to detect lambda in function
+ ;; position, so we need a special case here too.
+ (let* ((old-lambda (cadr exp))
+ (new-lambda (macroexp--sm-macroexpand-1 (cadr exp) env)))
+ (when (eq (car-safe new-lambda) macroexpand-already-expanded)
+ (setq new-lambda (cadr new-lambda)))
+ (if (eq old-lambda new-lambda)
+ exp
+ (list macroexpand-already-expanded new-lambda))))
+ (_ exp)))
+
+(defun macroexp--symbol-macrolet-full (kind bindings body)
+ (if (not bindings)
+ body
+ (let ((env macroexpand-all-environment))
+ ;; Add the symbol-macrolet expander to env if it's not
+ ;; already there.
+ (unless (macroexp--memq-car-and-cadr
+ macroexpand-environment-hook-tag
+ 'macroexp--sm-macroexpand-1
+ env)
+ (push (list macroexpand-environment-hook-tag
+ 'macroexp--sm-macroexpand-1)
+ env))
+ ;; Add the actual bindings.
+ (dolist (binding bindings)
+ (push (list macroexp--sm-environment-tag
+ (car binding)
+ (cadr binding)
+ kind)
+ env))
+ ;; Expand.
+ (list macroexpand-already-expanded
+ (macroexpand-all (cons 'progn body) env)))))
+
+;;;###autoload
+(defmacro symbol-macrolet (bindings &rest body)
+ "Make symbol macro definitions.
+Within the body FORMs, references to the variable NAME will be
+replaced by EXPANSION, and (setq NAME ...) will act like (setf
+EXPANSION ...). Additionally, if `lexical-binding' is
+nil, (let ((NAME ...)) ...) becomes (letf ((BINDING ...)) ...).
+
+If `lexical-binding' is non-nil, `let'-bindings shadow symbol
+macros, as in Common Lisp --- `symbol-macrolet' behaves as
+`symbol-macrolet-shadowable'. Otherwise, `symbol-macrolet'
+behaves like `symbol-macrolet-non-shadowable'. In all cases,
+`lambda' parameters and `condition-case' var parameter shadow
+symbol macros.
+
+For explicit control over `let'-shadowing, see
+`symbol-macrolet-shadowable' and
+`symbol-macrolet-non-shadowable'. Any combination of
+lexical-binding, symbol-macrolet-shadowable, and
+symbol-macrolet-non-shadowable works; `lexical-binding' just
+controls the default.
+
+\(fn ((NAME EXPANSION) ...) FORM...)"
+ (declare (indent 1) (debug ((&rest (symbol sexp)) declarations body)))
+ (macroexp--symbol-macrolet-full (if lexical-binding
+ 'symbol-macrolet-shadowable
+ 'symbol-macrolet-non-shadowable)
+ bindings body))
+
+;;;###autoload
+(defmacro symbol-macrolet-non-shadowable (bindings &rest body)
+ "Like `symbol-macrolet', but with unconditional non-shadowing.
+
+\(fn ((NAME EXPANSION) ...) FORM...)"
+ (declare (indent 1) (debug ((&rest (symbol sexp)) declarations body)))
+ (macroexp--symbol-macrolet-full
+ 'symbol-macrolet-non-shadowable bindings body))
+
+;;;###autoload
+(defmacro symbol-macrolet-shadowable (bindings &rest body)
+ "Like `symbol-macrolet', but `let' always shadows.
+
+\(fn ((NAME EXPANSION) ...) FORM...)"
+ (declare (indent 1) (debug ((&rest (symbol sexp)) declarations body)))
+ (macroexp--symbol-macrolet-full
+ 'symbol-macrolet-shadowable bindings body))
+
;;; Load-time macro-expansion.
;; Because macro-expansion used to be more lazy, eager macro-expansion
=== modified file 'lisp/font-lock.el'
--- lisp/font-lock.el 2013-06-21 06:37:44 +0000
+++ lisp/font-lock.el 2013-09-17 11:21:26 +0000
@@ -2309,7 +2309,10 @@
"restart-bind" "restart-case" "in-package"
"break" "ignore-errors"
"loop" "do" "do*" "dotimes" "dolist" "the" "locally"
- "proclaim" "declaim" "declare" "symbol-macrolet" "letf"
+ "proclaim" "declaim" "declare" "symbol-macrolet"
+ "symbol-macrolet-shadowable"
+ "symbol-macrolet-non-shadowable"
+ "letf"
"lexical-let" "lexical-let*" "flet" "labels" "compiler-let"
"destructuring-bind" "macrolet" "tagbody" "block" "go"
"multiple-value-bind" "multiple-value-prog1"
=== modified file 'lisp/subr.el'
--- lisp/subr.el 2013-09-12 06:37:02 +0000
+++ lisp/subr.el 2013-09-17 07:05:45 +0000
@@ -344,6 +344,165 @@
configuration."
(and (consp object)
(eq (car object) 'frame-configuration)))
+
+(defconst macroexpand-already-expanded
+ (if (boundp 'macroexpand-already-expanded)
+ (symbol-value 'macroexpand-already-expanded)
+ (make-symbol "--macroexpand-already-expanded--"))
+"Special uninterned symbol used to indicate that `macroexpand-1'
+is returning an already-expanded form and that further expansion
+is discouraged. For the sake of compatibility, `macroexpand-1'
+and `macroexpand' only return this value when called with the
+special EXTENDED parameter.
+
+Macros may always return (list macroexpand-already-expanded
+EXPANDED-FORM): `macroexpand-1' and `macroexpand' will strip the
+special macroexpand-already-expanded prefix unless callers
+specifically ask for it to be returned, and
+macroexpand-already-expanded has a function definition that makes
+it invisible to the interpreter.")
+
+;; Allow macros to return a macroexpand-already-expanded cons and
+;; execute properly during interpretation.
+(fset macroexpand-already-expanded 'identity)
+
+(defconst macroexpand-environment-hook-tag
+ (if (boundp 'macroexpand-environment-hook-tag)
+ (symbol-value 'macroexpand-environment-hook-tag)
+ (make-symbol "--macroexpand-environment-hook-tag--"))
+ "Special uninterned symbol used in macro environments to signal
+the macro expander to call one or more hook functions after
+normal macro expansion. If an entry of the
+form (macroexpand-environment-hook-tag HOOKFUNC) appears in the
+environment, HOOKFUNC is added to the set of functions called to
+implement `macroexpand-1-default'. These functions are called in
+the reverse of the order in which they appear in the environment,
+with `macroexpand-1-default' being implicitly the last entry on
+the list (and therefore the first to be called).
+
+Each function on the list is called with two arguments: first,
+the form to be expanded, and second, the top of the macro
+environment. The first value returned not EQ to the input is the
+value `macroexpand-1' returns." )
+
+;; It may seem odd to macro expansion hooks in the macro environment
+;; instead of dynamically-binding a hypothetical
+;; macroexpand-1-functions variable. The reason we do it this way is
+;; so that we can expand macros from outside the dynamic extent of a
+;; form that introduces a macro expansion hook --- e.g.,
+;; `cl-symbol-macrolet'. In the current implementation, the macro
+;; environment encapsulates the _entire_ state of the macro expansion
+;; system.
+;;
+;; We can store other state in the environment as well: all that's
+;; required for compatibility with naive users of the macro
+;; environment is to ensure that no car of any cons in the macro
+;; environment refers to a form we might try to expand. That's why
+;; all the macro tags should be uninterned.
+
+(defun macroexpand-1-default (form &optional environment)
+ "Default implementation of `macroexpand-1'."
+ (let ((expander
+ (and (consp form)
+ (let* ((def (car form)) (sym def) (tem nil))
+ ;; Trace symbols aliases to other symbols until we get
+ ;; a symbol that is not an alias. Check at each step
+ ;; whether we have an override in the environment.
+ (while (and (symbolp def)
+ (not (setq tem (assq (setq sym def)
+ environment)))
+ (setq def (symbol-function sym))))
+ ;; Now TEM is the definition from the environment; if
+ ;; TEM is nil, DEF is SYM's function definition.
+ (if tem (cdr tem)
+ ;; SYM is not mentioned in ENVIRONMENT. Look at its
+ ;; function definition.
+ (setq def (autoload-do-load def sym 'macro))
+ (and (consp def)
+ (eq (car def) 'macro)
+ (cdr def)))))))
+ (if expander (apply expander (cdr form)) form)))
+
+(defun macroexpand-1-worker (form environment hookenv)
+ "Recursive helper function for `macroexpand-1'.
+We use this routine to call macro expansion hooks in in reverse
+order without consing: we effectively store the reversed list on
+the execution stack."
+ ;; N.B. Stack depth isn't a problem. We have one frame per hook
+ ;; function, not per entry on the environment alist.
+ (setq hookenv (memq-car macroexpand-environment-hook-tag hookenv))
+ (if hookenv
+ (let ((new-form (macroexpand-1-worker
+ form
+ environment
+ (cdr hookenv))))
+ (if (eq new-form form)
+ (funcall (car (cdr (car hookenv))) form environment)
+ new-form))
+ (macroexpand-1-default form environment)))
+
+(defun macroexpand-1 (form &optional environment extended)
+ "Return result of expanding macros at top level of FORM.
+If FORM is not a macro call, it is returned unchanged.
+Otherwise, the macro is expanded once and the expansion returned.
+
+The second optional arg ENVIRONMENT specifies an environment of
+macro definitions.
+
+The third optional arg EXTENDED, if precisely `t', indicates that
+this function may return, instead of its usual value, (list
+macroexpand-already-expanded EXPANDED-FORM), indicating that
+EXPANDED-FORM is the fully expanded version of all parts of FORM
+and that no further expansion is desired.
+
+EXTENDED exists for the benefit of `macroexpand-all'. The
+default macro expansion functions never return a list of this
+form, but some advanced macro facilities temporarily override
+`macroexpand-1', and these overrides may choose to return a
+macroexpand-already-expanded list."
+ (setq form (macroexpand-1-worker form environment environment))
+ (if (and (not extended)
+ (eq (car-safe form) macroexpand-already-expanded))
+ (cadr form)
+ form))
+
+(defun macroexpand (form &optional environment extended)
+ "Return result of expanding macros at top level of FORM.
+If FORM is not a macro call, it is returned unchanged.
+Otherwise, the macro is expanded and the expansion is considered
+in place of FORM. When a non-macro-call results, it is returned.
+
+The second optional arg ENVIRONMENT specifies an environment of
+macro definitions to shadow the loaded ones for use in file
+byte-compilation.
+
+The third optional arg EXTENDED, if precisely `t', indicates that
+this function may return, instead of its usual value, (list
+macroexpand-already-expanded EXPANDED-FORM), indicating that
+EXPANDED-FORM is the fully expanded version of all parts of FORM
+and that no further expansion is desired.
+
+This facility mostly exists for the benefit of `macroexpand-all':
+it lets us avoid repeatedly expanding a form a second time when
+the macro has already called `macroexpand-all' internally.
+
+The default macro expansion functions never return a list of this
+form, but some advanced macro facilities temporarily override
+`macroexpand-1' or `macroexpand', and these overrides may choose
+to return a macroexpand-already-expanded list."
+
+ (while
+ (let ((new-form (macroexpand-1 form environment t)))
+ (prog1
+ (not (or (eq new-form form)
+ (eq (car-safe new-form)
+ macroexpand-already-expanded)))
+ (setq form new-form))))
+ (if (and (not extended)
+ (eq (car-safe form) macroexpand-already-expanded))
+ (cadr form)
+ form))
+
;;;; List functions.
@@ -479,6 +638,19 @@
;;;; Various list-search functions.
+(defun memq-car (key alist)
+ "Find cons with car KEY in ALIST.
+Like `assq', except that instead of returning
+the cons cell whose car is `eq' to KEY, it returns
+the cons cell whose car is that cons cell and whose
+cdr is the rest of the alist."
+ ;; Although this function is heavily used in macro expansion (but
+ ;; not during interpretation!), avoid the temptation to move it to
+ ;; C. The speedup is only ~2x.
+ (while (and alist (not (eq (car-safe (car alist)) key)))
+ (setq alist (cdr alist)))
+ alist)
+
(defun assoc-default (key alist &optional test default)
"Find object KEY in a pseudo-alist ALIST.
ALIST is a list of conses or objects. Each element
=== modified file 'src/eval.c'
--- src/eval.c 2013-09-10 15:30:10 +0000
+++ src/eval.c 2013-09-16 06:38:35 +0000
@@ -994,76 +994,6 @@
return Qnil;
}
-DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0,
- doc: /* Return result of expanding macros at top level of FORM.
-If FORM is not a macro call, it is returned unchanged.
-Otherwise, the macro is expanded and the expansion is considered
-in place of FORM. When a non-macro-call results, it is returned.
-
-The second optional arg ENVIRONMENT specifies an environment of macro
-definitions to shadow the loaded ones for use in file byte-compilation. */)
- (Lisp_Object form, Lisp_Object environment)
-{
- /* With cleanups from Hallvard Furuseth. */
- register Lisp_Object expander, sym, def, tem;
-
- while (1)
- {
- /* Come back here each time we expand a macro call,
- in case it expands into another macro call. */
- if (!CONSP (form))
- break;
- /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
- def = sym = XCAR (form);
- tem = Qnil;
- /* Trace symbols aliases to other symbols
- until we get a symbol that is not an alias. */
- while (SYMBOLP (def))
- {
- QUIT;
- sym = def;
- tem = Fassq (sym, environment);
- if (NILP (tem))
- {
- def = XSYMBOL (sym)->function;
- if (!NILP (def))
- continue;
- }
- break;
- }
- /* Right now TEM is the result from SYM in ENVIRONMENT,
- and if TEM is nil then DEF is SYM's function definition. */
- if (NILP (tem))
- {
- /* SYM is not mentioned in ENVIRONMENT.
- Look at its function definition. */
- struct gcpro gcpro1;
- GCPRO1 (form);
- def = Fautoload_do_load (def, sym, Qmacro);
- UNGCPRO;
- if (!CONSP (def))
- /* Not defined or definition not suitable. */
- break;
- if (!EQ (XCAR (def), Qmacro))
- break;
- else expander = XCDR (def);
- }
- else
- {
- expander = XCDR (tem);
- if (NILP (expander))
- break;
- }
- {
- Lisp_Object newform = apply1 (expander, XCDR (form));
- if (EQ (form, newform))
- break;
- else
- form = newform;
- }
- }
- return form;
-}
DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0,
doc: /* Eval BODY allowing nonlocal exits using `throw'.
@@ -3853,7 +3783,6 @@
defsubr (&Slet);
defsubr (&SletX);
defsubr (&Swhile);
- defsubr (&Smacroexpand);
defsubr (&Scatch);
defsubr (&Sthrow);
defsubr (&Sunwind_protect);
=== modified file 'test/automated/cl-lib.el'
--- test/automated/cl-lib.el 2013-07-11 16:13:38 +0000
+++ test/automated/cl-lib.el 2013-09-17 14:39:15 +0000
@@ -195,4 +195,10 @@
(should (eql (cl-mismatch "Aa" "aA") 0))
(should (eql (cl-mismatch '(a b c) '(a b d)) 2)))
+(ert-deftest cl-lib-loop-capture-it ()
+ (should (equal
+ (cl-loop for x below 1 if x
+ return (cons it (let ((it 2)) it)))
+ '(0 . 2))))
+
;;; cl-lib.el ends here
=== modified file 'test/automated/core-elisp-tests.el'
--- test/automated/core-elisp-tests.el 2013-08-03 01:47:54 +0000
+++ test/automated/core-elisp-tests.el 2013-09-17 14:42:11 +0000
@@ -36,5 +36,256 @@
c-e-x)
'(1 2)))))
+(ert-deftest core-macroexpand-1 ()
+ (defmacro test-macro-1 () `x)
+ (defmacro test-macro-2 () `(test-macro-1))
+ (let* ((orig-form '(test-macro-2))
+ (form orig-form))
+ (setf form (macroexpand-1 form))
+ (should (equal form '(test-macro-1)))
+ (setf form (macroexpand-1 form))
+ (should (equal form 'x))
+ (should (equal form (macroexpand orig-form)))
+ (should (eq (macroexpand-1 form) form))))
+
+(ert-deftest core-macroexpand-1-aliases ()
+ "Alias chasing doesn't count as a macroexpansion step."
+ (defmacro test-macro-3 () `x)
+ (defalias 'test-macro-4 'test-macro-3)
+ (let ((form '(test-macro-4)))
+ (setf form (macroexpand-1 form))
+ (should (equal form 'x))))
+
+(defvar core-macroexpand-expansion-count nil)
+
+(ert-deftest core-macroexpand-already-expanded ()
+ (defmacro test-macro-5 ()
+ (list macroexpand-already-expanded 5))
+
+ ;; The interpreter should ignore macroexpand-already-expanded.
+ (should (equal (eval '(test-macro-5)) 5))
+
+ ;; Macro-expansion functions should hide
+ ;; macroexpand-already-expanded from callers by dfault.
+ (should (equal (macroexpand-1 '(test-macro-5)) 5))
+ (should (equal (macroexpand '(test-macro-5)) 5))
+ (should (equal (macroexpand-all '(test-macro-5)) 5))
+
+ ;; But they should provide the form on request. (macroexpand-all
+ ;; doesn't because its return value is _always_ fully expanded.)
+ (should (equal (macroexpand-1 '(test-macro-5) nil t)
+ (list macroexpand-already-expanded 5)))
+ (should (equal (macroexpand '(test-macro-5) nil t)
+ (list macroexpand-already-expanded 5)))
+
+ (cl-defmacro test-macro-with-expand-marker (&environment env)
+ (list macroexpand-already-expanded
+ (macroexpand-all '(+ 7 7) env)))
+
+ (cl-defmacro test-macro-without-expand-marker (&environment env)
+ (macroexpand-all '(+ 7 7) env))
+
+ (let ((core-macroexpand-expansion-count)
+ (env (list (list macroexpand-environment-hook-tag
+ (lambda (exp &optional env)
+ (if (eql exp 7)
+ (incf core-macroexpand-expansion-count))
+ exp)))))
+ (setf core-macroexpand-expansion-count 0)
+ (macroexpand-all '(test-macro-without-expand-marker) env)
+ (should (= core-macroexpand-expansion-count 4))
+ (setf core-macroexpand-expansion-count 0)
+ (macroexpand-all '(test-macro-with-expand-marker) env)
+ (should (= core-macroexpand-expansion-count 2))))
+
+(defun test-core-normalize-variable-analysis (v)
+ "Normalize variable analysis so equal results are EQUAL."
+ (sort (mapcar (lambda (i)
+ (list
+ (pop i)
+ (pop i)
+ (sort (copy-sequence (pop i))
+ #'string<)
+ (pop i)))
+ v)
+ (lambda (i1 i2)
+ (string< (car i1) (car i2)))))
+
+(ert-deftest core-macroexp-analyze-free-variables ()
+ (let ((testcases '(((let* ((x (setq x (1+ x)))) x)
+ . ((x t nil 1)))
+ ((let* ((x x) x))
+ . ((x nil nil 1)))
+ ((let ((x x)) (setq x 1))
+ . ((x nil nil 1)))
+ ((let ((x 1) (y 2)) z)
+ . ((z nil (y x) 1)))
+ (x
+ . ((x nil nil 1)))
+ ((list x x)
+ . ((x nil nil 2)))
+ ((condition-case y x (error y))
+ . ((x nil nil 1)))
+ ((condition-case z x (error y))
+ . ((y nil (z) 1) (x nil nil 1)))
+ (:abc . nil)
+ (t . nil)
+ (nil . nil)
+ ((let ((y z) (x x)) (setq x 1))
+ . ((z nil nil 1)
+ (x nil nil 1)))
+ ((let ((x y) (p x)))
+ . ((y nil nil 1)
+ (x nil nil 1)))
+ ((let* ((x y) (p x)))
+ . ((y nil nil 1))))))
+ (dolist (testcase testcases)
+ (unless (equal (test-core-normalize-variable-analysis
+ (macroexp-analyze-free-variables
+ (car testcase)))
+ (test-core-normalize-variable-analysis
+ (cdr testcase)))
+ (error "from %S: got %S: expected %S"
+ (car testcase)
+ (macroexp-analyze-free-variables
+ (car testcase))
+ (cdr testcase))))))
+
+(ert-deftest symbol-macrolet-basic ()
+ (should (eql (symbol-macrolet ((x 1)) x) 1))
+ (should (eql (let ((y '(3 . -1)))
+ (symbol-macrolet ((x (car y)))
+ (1+ x)))
+ 4)))
+
+(ert-deftest symbol-macrolet-non-shadowable ()
+ (should (equal
+ (let ((y (cons 1 2)))
+ (symbol-macrolet-non-shadowable ((x (cdr y)))
+ (let ((x 5))
+ (list x (cdr y)))))
+ '(5 5))))
+
+(ert-deftest symbol-macrolet-shadowable ()
+ (should (equal
+ (let ((y (cons 1 2)))
+ (symbol-macrolet-shadowable ((x (cdr y)))
+ (let ((x 5))
+ (list x (cdr y)))))
+ '(5 2))))
+
+(ert-deftest symbol-macrolet-shadow-let* ()
+ (should (equal
+ (let ((y (cons 1 2)))
+ (symbol-macrolet-shadowable ((x (cdr y)))
+ (let* ((x -1)
+ (z (1+ x)))
+ (list x (cdr y) z))))
+ '(-1 2 0))))
+
+(ert-deftest symbol-macrolet-shadow-let ()
+ (should (equal
+ (let ((y (cons 1 2)))
+ (symbol-macrolet-shadowable ((x (cdr y)))
+ (let ((x -1)
+ (z (1+ x)))
+ (list x (cdr y) z))))
+ '(-1 2 3))))
+
+(ert-deftest symbol-macrolet-non-shadow-let ()
+ (should (equal
+ (let ((y (cons 1 2)))
+ (symbol-macrolet-non-shadowable ((x (cdr y)))
+ (let ((x -1)
+ (z (1+ x)))
+ (list x (cdr y) z))))
+ '(-1 -1 3))))
+
+(ert-deftest symbol-macrolet-non-shadow-let* ()
+ (should (equal
+ (let ((y (cons 1 2)))
+ (symbol-macrolet-non-shadowable ((x (cdr y)))
+ (let* ((x -1)
+ (z (1+ x)))
+ (list x (cdr y) z))))
+ '(-1 -1 0))))
+
+(ert-deftest symbol-macrolet-shadow-lambda-args ()
+ (should (equal
+ (let ((y (cons 1 2)))
+ (symbol-macrolet-shadowable ((x (car y)))
+ (funcall (lambda (x) (list (car y) x)) 3)))
+ (list 1 3))))
+
+(ert-deftest symbol-macrolet-non-shadow-lambda-args ()
+ ;; Even "non-shadowable" symbol macros shouldn't interfere with
+ ;; lambda arguments.
+ (should (equal
+ (let ((y (cons 1 2)))
+ (symbol-macrolet-non-shadowable ((x (car y)))
+ (funcall (lambda (x) (list (car y) x)) 3)))
+ '(1 3))))
+
+(ert-deftest cl-lib-symbol-nested-macrolet ()
+ (should (eql (symbol-macrolet ((x 1))
+ (symbol-macrolet ((x 2))
+ x))
+ 2)))
+
+(ert-deftest cl-lib-symbol-nested-macrolet-shadowing ()
+ (should (equal
+ (let ((y (cons 1 2)))
+ (symbol-macrolet-non-shadowable ((x (car y)))
+ (symbol-macrolet-shadowable ((x (cdr y)))
+ (let ((x 3))
+ (list (car y) (cdr y) x)))))
+ '(1 2 3)))
+ (should (equal
+ (let ((y (cons 1 2)))
+ (symbol-macrolet-shadowable ((x (car y)))
+ (symbol-macrolet-non-shadowable ((x (cdr y)))
+ (let ((x 3))
+ (list (car y) (cdr y) x)))))
+ '(1 3 3)))
+ (should (equal
+ (let ((y (cons 1 2)))
+ (symbol-macrolet-shadowable ((x (car y)))
+ (symbol-macrolet-shadowable ((x (cdr y)))
+ (let ((x 3))
+ (list (car y) (cdr y) x)))))
+ '(1 2 3)))
+ (should (equal
+ (let ((y (cons 1 2)))
+ (symbol-macrolet-non-shadowable ((x (car y)))
+ (symbol-macrolet-non-shadowable ((x (cdr y)))
+ (let ((x 3))
+ (list (car y) (cdr y) x)))))
+ '(1 3 3))))
+
+(ert-deftest symbol-macrolet-condition-case ()
+ "Don't forget that `condition-case' is also a binding form."
+ (should (equal
+ (let ((x 1))
+ (symbol-macrolet-non-shadowable ((y x))
+ (condition-case y
+ (progn
+ (cl-incf y)
+ (error "ignored"))
+ (error (setq y 5))))
+ x)
+ 2))
+ (should (equal
+ (let ((x 1))
+ (symbol-macrolet-shadowable ((y x))
+ (condition-case y
+ (progn
+ (cl-incf y)
+ (error "ignored"))
+ (error (setq y 5))))
+ x)
+ 2)))
+
+
+
(provide 'core-elisp-tests)
;;; core-elisp-tests.el ends here
signature.asc
Description: OpenPGP digital signature
- [PATCH, RFC] Macros expansion changes, robust symbol macros, and constant propagation,
Daniel Colascione <=
- Re: [PATCH, RFC] Macros expansion changes, robust symbol macros, and constant propagation, Stefan Monnier, 2013/09/17
- Re: [PATCH, RFC] Macros expansion changes, robust symbol macros, and constant propagation, Daniel Colascione, 2013/09/17
- Re: [PATCH, RFC] Macros expansion changes, robust symbol macros, and constant propagation, Daniel Colascione, 2013/09/17
- Re: [PATCH, RFC] Macros expansion changes, robust symbol macros, and constant propagation, Stefan Monnier, 2013/09/18
- Re: [PATCH, RFC] Macros expansion changes, robust symbol macros, and constant propagation, Stefan Monnier, 2013/09/17
- Re: [PATCH, RFC] Macros expansion changes, robust symbol macros, and constant propagation, Daniel Colascione, 2013/09/18
- Re: [PATCH, RFC] Macros expansion changes, robust symbol macros, and constant propagation, Daniel Colascione, 2013/09/18
- Re: [PATCH, RFC] Macros expansion changes, robust symbol macros, and constant propagation, Stefan Monnier, 2013/09/24