X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/f15c8583198c3d6c26ca0c0a5b6fb019f98d6c3c..96bd07a3226700156fa7d5ec20e9bd6550c95057:/lisp/emacs-lisp/macroexp.el diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 68bf4f62c3..310ca29e9a 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -1,6 +1,6 @@ -;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t; coding: utf-8 -*- +;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*- ;; -;; Copyright (C) 2004-2015 Free Software Foundation, Inc. +;; Copyright (C) 2004-2016 Free Software Foundation, Inc. ;; ;; Author: Miles Bader ;; Keywords: lisp, compiler, macros @@ -119,30 +119,39 @@ and also to avoid outputting the warning during normal execution." (member '(declare-function . byte-compile-macroexpand-declare-function) macroexpand-all-environment)) +(defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) -(defun macroexp--warn-and-return (msg form) +(defun macroexp--warn-and-return (msg form &optional compile-only) (let ((when-compiled (lambda () (byte-compile-log-warning msg t)))) (cond ((null msg) form) ((macroexp--compiling-p) - `(progn - (macroexp--funcall-if-compiled ',when-compiled) - ,form)) + (if (gethash form macroexp--warned) + ;; Already wrapped this exp with a warning: avoid inf-looping + ;; where we keep adding the same warning onto `form' because + ;; macroexpand-all gets right back to macroexpanding `form'. + form + (puthash form form macroexp--warned) + `(progn + (macroexp--funcall-if-compiled ',when-compiled) + ,form))) (t - (message "%s%s" (if (stringp load-file-name) - (concat (file-relative-name load-file-name) ": ") - "") - msg) + (unless compile-only + (message "%s%s" (if (stringp load-file-name) + (concat (file-relative-name load-file-name) ": ") + "") + msg)) form)))) (defun macroexp--obsolete-warning (fun obsolescence-data type) (let ((instead (car obsolescence-data)) (asof (nth 2 obsolescence-data))) - (format "`%s' is an obsolete %s%s%s" fun type - (if asof (concat " (as of " asof ")") "") - (cond ((stringp instead) (concat "; " instead)) - (instead (format "; use `%s' instead." instead)) - (t "."))))) + (format-message + "`%s' is an obsolete %s%s%s" fun type + (if asof (concat " (as of " asof ")") "") + (cond ((stringp instead) (concat "; " (substitute-command-keys instead))) + (instead (format-message "; use `%s' instead." instead)) + (t "."))))) (defun macroexpand-1 (form &optional environment) "Perform (at most) one step of macroexpansion." @@ -208,30 +217,30 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexp--cons 'condition-case (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) form)) (`(,(or `defvar `defconst) . ,_) (macroexp--all-forms form 2)) (`(function ,(and f `(lambda . ,_))) (macroexp--cons 'function - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form)) + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form)) (`(,(or `function `quote) . ,_) form) (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare)) (macroexp--cons fun - (macroexp--cons (macroexp--all-clauses bindings 1) - (macroexp--all-forms body) - (cdr form)) - form)) + (macroexp--cons (macroexp--all-clauses bindings 1) + (macroexp--all-forms body) + (cdr form)) + form)) (`(,(and fun `(lambda . ,_)) . ,args) ;; Embedded lambda in function position. (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form)) + (macroexp--all-forms args) + form)) ;; The following few cases are for normal function calls that ;; are known to funcall one of their arguments. The byte ;; compiler has traditionally handled these functions specially @@ -252,7 +261,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (format "%s quoted with ' rather than with #'" (list 'lambda (nth 1 f) '...)) (macroexp--expand-all `(,fun ,arg1 ,f . ,args)))) - (`(funcall (,(or 'quote 'function) ,(and f (pred symbolp)) . ,_) . ,args) + (`(funcall #',(and f (pred symbolp)) . ,args) ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' ;; has a compiler-macro. (macroexp--expand-all `(,f . ,args))) @@ -284,7 +293,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexp--expand-all newform))) (macroexp--expand-all newform)))))) - (t form)))) + (_ form)))) ;;;###autoload (defun macroexpand-all (form &optional environment) @@ -313,8 +322,9 @@ definitions to shadow the loaded ones for use in file byte-compilation." (if (cdr exps) `(progn ,@exps) (car exps))) (defun macroexp-unprogn (exp) - "Turn EXP into a list of expressions to execute in sequence." - (if (eq (car-safe exp) 'progn) (cdr exp) (list exp))) + "Turn EXP into a list of expressions to execute in sequence. +Never returns an empty list." + (if (eq (car-safe exp) 'progn) (or (cdr exp) '(nil)) (list exp))) (defun macroexp-let* (bindings exp) "Return an expression equivalent to `(let* ,bindings ,exp)." @@ -324,38 +334,72 @@ definitions to shadow the loaded ones for use in file byte-compilation." (t `(let* ,bindings ,exp)))) (defun macroexp-if (test then else) - "Return an expression equivalent to `(if ,test ,then ,else)." + "Return an expression equivalent to `(if ,TEST ,THEN ,ELSE)." (cond ((eq (car-safe else) 'if) - (if (equal test (nth 1 else)) - ;; Doing a test a second time: get rid of the redundancy. - `(if ,test ,then ,@(nthcdr 3 else)) - `(cond (,test ,then) - (,(nth 1 else) ,(nth 2 else)) - (t ,@(nthcdr 3 else))))) + (cond + ;; Drop this optimization: It's unsafe (it assumes that `test' is + ;; pure, or at least idempotent), and it's not used even a single + ;; time while compiling Emacs's sources. + ;;((equal test (nth 1 else)) + ;; ;; Doing a test a second time: get rid of the redundancy. + ;; (message "macroexp-if: sharing 'test' %S" test) + ;; `(if ,test ,then ,@(nthcdr 3 else))) + ((equal then (nth 2 else)) + ;; (message "macroexp-if: sharing 'then' %S" then) + `(if (or ,test ,(nth 1 else)) ,then ,@(nthcdr 3 else))) + ((equal (macroexp-unprogn then) (nthcdr 3 else)) + ;; (message "macroexp-if: sharing 'then' with not %S" then) + `(if (or ,test (not ,(nth 1 else))) + ,then ,@(macroexp-unprogn (nth 2 else)))) + (t + `(cond (,test ,@(macroexp-unprogn then)) + (,(nth 1 else) ,@(macroexp-unprogn (nth 2 else))) + (t ,@(nthcdr 3 else)))))) ((eq (car-safe else) 'cond) - `(cond (,test ,then) - ;; Doing a test a second time: get rid of the redundancy, as above. - ,@(remove (assoc test else) (cdr else)))) + `(cond (,test ,@(macroexp-unprogn then)) ,@(cdr else))) ;; Invert the test if that lets us reduce the depth of the tree. ((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then)) - (t `(if ,test ,then ,else)))) - -(defmacro macroexp-let2 (test var exp &rest exps) - "Bind VAR to a copyable expression that returns the value of EXP. -This is like `(let ((v ,EXP)) ,EXPS) except that `v' is a new generated -symbol which EXPS can find in VAR. -TEST should be the name of a predicate on EXP checking whether the `let' can -be skipped; if nil, as is usual, `macroexp-const-p' is used." + (t `(if ,test ,then ,@(macroexp-unprogn else))))) + +(defmacro macroexp-let2 (test sym exp &rest body) + "Evaluate BODY with SYM bound to an expression for EXP's value. +The intended usage is that BODY generates an expression that +will refer to EXP's value multiple times, but will evaluate +EXP only once. As BODY generates that expression, it should +use SYM to stand for the value of EXP. + +If EXP is a simple, safe expression, then SYM's value is EXP itself. +Otherwise, SYM's value is a symbol which holds the value produced by +evaluating EXP. The return value incorporates the value of BODY, plus +additional code to evaluate EXP once and save the result so SYM can +refer to it. + +If BODY consists of multiple forms, they are all evaluated +but only the last one's value matters. + +TEST is a predicate to determine whether EXP qualifies as simple and +safe; if TEST is nil, only constant expressions qualify. + +Example: + (macroexp-let2 nil foo EXP + \\=`(* ,foo ,foo)) +generates an expression that evaluates EXP once, +then returns the square of that value. +You could do this with + (let ((foovar EXP)) + (* foovar foovar)) +but using `macroexp-let2' produces more efficient code in +cases where EXP is a constant." (declare (indent 3) (debug (sexp sexp form body))) (let ((bodysym (make-symbol "body")) (expsym (make-symbol "exp"))) `(let* ((,expsym ,exp) - (,var (if (funcall #',(or test #'macroexp-const-p) ,expsym) - ,expsym (make-symbol ,(symbol-name var)))) - (,bodysym ,(macroexp-progn exps))) - (if (eq ,var ,expsym) ,bodysym - (macroexp-let* (list (list ,var ,expsym)) + (,sym (if (funcall #',(or test #'macroexp-const-p) ,expsym) + ,expsym (make-symbol ,(symbol-name sym)))) + (,bodysym ,(macroexp-progn body))) + (if (eq ,sym ,expsym) ,bodysym + (macroexp-let* (list (list ,sym ,expsym)) ,bodysym))))) (defmacro macroexp-let2* (test bindings &rest body) @@ -465,6 +509,8 @@ itself or not." (defvar macroexp--pending-eager-loads nil "Stack of files currently undergoing eager macro-expansion.") +(defvar macroexp--debug-eager nil) + (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. (cond @@ -480,8 +526,10 @@ itself or not." (tail (member elem (cdr (member elem bt))))) (if tail (setcdr tail (list '…))) (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) - (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" - (mapconcat #'prin1-to-string (nreverse bt) " => ")) + (if macroexp--debug-eager + (debug 'eager-macroexp-cycle) + (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" + (mapconcat #'prin1-to-string (nreverse bt) " => "))) (push 'skip macroexp--pending-eager-loads) form)) (t