From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Daniel Colascione Newsgroups: gmane.emacs.devel Subject: [PATCH, RFC] Macros expansion changes, robust symbol macros, and constant propagation Date: Tue, 17 Sep 2013 09:33:27 -0700 Message-ID: <52388457.1090908@dancol.org> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/signed; micalg=pgp-sha1; protocol="application/pgp-signature"; boundary="tHmBaSijBWkFWaJtL2sPXsVHcwCISRx2U" X-Trace: ger.gmane.org 1379435702 10249 80.91.229.3 (17 Sep 2013 16:35:02 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 17 Sep 2013 16:35:02 +0000 (UTC) To: Emacs development discussions Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Tue Sep 17 18:35:02 2013 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1VLyEv-0001dP-TN for ged-emacs-devel@m.gmane.org; Tue, 17 Sep 2013 18:35:02 +0200 Original-Received: from localhost ([::1]:42420 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1VLyEv-0002vT-93 for ged-emacs-devel@m.gmane.org; Tue, 17 Sep 2013 12:35:01 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:40825) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1VLyEj-0002vG-Cs for emacs-devel@gnu.org; Tue, 17 Sep 2013 12:34:58 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1VLyEa-0005Z0-Nw for emacs-devel@gnu.org; Tue, 17 Sep 2013 12:34:49 -0400 Original-Received: from dancol.org ([2600:3c01::f03c:91ff:fedf:adf3]:59610) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1VLyEa-0005Xi-3m for emacs-devel@gnu.org; Tue, 17 Sep 2013 12:34:40 -0400 Original-Received: from c-76-22-66-162.hsd1.wa.comcast.net ([76.22.66.162] helo=[192.168.1.2]) by dancol.org with esmtpsa (TLS1.0:DHE_RSA_CAMELLIA_256_CBC_SHA1:256) (Exim 4.80) (envelope-from ) id 1VLyET-0003A7-KN for emacs-devel@gnu.org; Tue, 17 Sep 2013 09:34:33 -0700 User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.6; rv:17.0) Gecko/20130801 Thunderbird/17.0.8 X-Enigmail-Version: 1.5.2 X-detected-operating-system: by eggs.gnu.org: Error: Malformed IPv6 address (bad octet value). X-Received-From: 2600:3c01::f03c:91ff:fedf:adf3 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:163395 Archived-At: This is an OpenPGP/MIME signed message (RFC 4880 and 3156) --tHmBaSijBWkFWaJtL2sPXsVHcwCISRx2U Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable Below, you'll find a patch that: - removes Fmacroexpand and implements macroexpand-1 and macroexpand in l= isp - 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-ma= cros - 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. =3D=3D=3D 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 =3D=3D=3D 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 calle= d on - ;; non-macroexpanded code, so it may also miss some occurrences that w= ould - ;; 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 ,@bod= y)))) + (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 correspon= d @@ -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) newen= v))))) -;; 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 expansi= on. - (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 fo= r - ;; expansion (turning the let into a letf if needed), contr= ary to - ;; Common-Lisp where such re-bindings hide the symbol-macro= =2E - (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-l= etf*) - (car exp)) - ,(nreverse nbs) - ,@body))))) - ;; FIXME: The behavior of CL made sense in a dynamically sco= ped - ;; 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 base= d 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 bindi= ng))) - ;; (name (symbol-name var)) - ;; (val (and found (consp binding) (eq 'let* (ca= r exp)) - ;; (list (macroexpand-all (cadr bindin= g) - ;; env))))) - ;; (push (if (assq name env) - ;; ;; This binding should hide its symbol-m= acro, - ;; ;; but given the way macroexpand-all wor= ks, we - ;; ;; can't prevent application of `env' to= the - ;; ;; sub-expressions, so we need to =CE=B1= -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 cl= ear - ;; that the actual assignments ("bindings") should only happen after - ;; evaluating VAL1 and VAL2, it's not clear when the sub-expressions o= f - ;; 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)) bod= y))) - (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 (<=3D pos 5) + (let ((xx temp)) + (while (>=3D (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-expa= nder, - ;; 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 woul= d - ;; ;; cause a warning because it may not be - ;; ;; defined at run time. Suppress that warni= ng. - ;; (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 expansi= ons. (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 arg= v)) (progn (push (cons argn argv) su= bsts) - nil) + (and unsafe (list argn ar= gv))) (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)) =3D=3D=3D 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-v= ars)) (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 (<=3D pos 5) - (let ((xx temp)) - (while (>=3D (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) =3D=3D=3D 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 o= f + ;; 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)) bod= y))) + (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'. =3D=3D=3D 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 =3D=3D=3D 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" =3D=3D=3D 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)) + =0C ;;;; List functions. @@ -479,6 +638,19 @@ =0C ;;;; 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 =3D=3D=3D 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 sym= bol. */ - def =3D sym =3D XCAR (form); - tem =3D Qnil; - /* Trace symbols aliases to other symbols - until we get a symbol that is not an alias. */ - while (SYMBOLP (def)) - { - QUIT; - sym =3D def; - tem =3D Fassq (sym, environment); - if (NILP (tem)) - { - def =3D 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 =3D 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 =3D XCDR (def); - } - else - { - expander =3D XCDR (tem); - if (NILP (expander)) - break; - } - { - Lisp_Object newform =3D apply1 (expander, XCDR (form)); - if (EQ (form, newform)) - break; - else - form =3D newform; - } - } - return form; -} =0C 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); =3D=3D=3D 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 =3D=3D=3D 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 (=3D core-macroexpand-expansion-count 4)) + (setf core-macroexpand-expansion-count 0) + (macroexpand-all '(test-macro-with-expand-marker) env) + (should (=3D 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 --tHmBaSijBWkFWaJtL2sPXsVHcwCISRx2U Content-Type: application/pgp-signature; name="signature.asc" Content-Description: OpenPGP digital signature Content-Disposition: attachment; filename="signature.asc" -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.14 (Darwin) iQIcBAEBAgAGBQJSOIRaAAoJEMAaIROpHW7I5fIP/Ron7I7C6Nu2TOz4B79v01J0 WjHw+Y2ZNfOlIChyoAkAY7JlF5aACFwFH9mXMuYJi8RuDnSbO+3gyHSkMV6UxQIY vfBAOE85Y8X1UX2Nq+BvoVIMI3yNavewmEieNQhtD2WPJ8zjJob4OQFRbTwXT7D7 QlZf+41KJkOyDsN4cC1z79mM65asgcUBEV8c/F3CJJo+r3G5xM3ia/h0t10TU1bT rvk7218xHdJ4dueAUN8oTDiSE/b5rzXczVKibfqyrAF46VxHJTcjBWrKKF65WVPx 3Dgn6o74AmFfOscAWUSj/atqMeQGlC7d5oJoiPz6h7bioRINC7i4jBEG9JfZmY7x nchu8CbqCZxfeM/kFpBz1Cf/XO5rY8TPrfX7cPWtf43g4NnxuOImXVqL1mlYKGcI /6Jgz2y++9SoHMThn08LLlFI1CfwHoaKTsPu+urGpQ4816lRIVHZtiPFJ8NHAwpe a+BEy5br35rSP9RkZ8Fse6HkyOyedVQ2fkEo/LoCiH+sVlyctTyHS1Rgpxk/inZ+ P+HX+I0nKlZneCQ7LSFx/W8JFh76A3/NerKW+Ut+iArpHbMKAlcgXH6Gvz4x1D2m AbQn+sCQ1HKxR2kidkKX9pS7S9bZKdzeBeCVdYTn/c3QH9nehrpLbdsTv/BtX8F2 nxIGRll6mq/nHWDPQLmx =1ADa -----END PGP SIGNATURE----- --tHmBaSijBWkFWaJtL2sPXsVHcwCISRx2U--