merge from trunk

1 files changed, 194 insertions, 81 deletions

diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index e8b513fcd3e..8983454d318 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-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2015 Free Software Foundation, Inc.
 ;;
 ;; Author: Miles Bader <miles@gnu.org>
 ;; Keywords: lisp, compiler, macros
@@ -25,7 +25,6 @@
 ;; This file contains macro-expansions functions that are not defined in
 ;; the Lisp core, namely `macroexpand-all', which expands all macros in
 ;; a form, not just a top-level one.
-;;
 
 ;;; Code:
 
@@ -97,7 +96,8 @@ each clause."
 (defun macroexp--compiler-macro (handler form)
   (condition-case err
       (apply handler form (cdr form))
-    (error (message "Compiler-macro error for %S: %S" (car form) err)
+    (error
+     (message "Compiler-macro error for %S: %S" (car form) err)
            form)))
 
 (defun macroexp--funcall-if-compiled (_form)
@@ -119,36 +119,89 @@ 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."
+  (cond
+   ((consp form)
+    (let* ((head (car form))
+           (env-expander (assq head environment)))
+      (if env-expander
+          (if (cdr env-expander)
+              (apply (cdr env-expander) (cdr form))
+            form)
+        (if (not (and (symbolp head) (fboundp head)))
+            form
+          (let ((def (autoload-do-load (symbol-function head) head 'macro)))
+            (cond
+             ;; Follow alias, but only for macros, otherwise we may end up
+             ;; skipping an important compiler-macro (e.g. cl--block-wrapper).
+             ((and (symbolp def) (macrop def)) (cons def (cdr form)))
+             ((not (consp def)) form)
+             (t
+              (if (eq 'macro (car def))
+                  (apply (cdr def) (cdr form))
+                form))))))))
+   (t form)))
+
+(defun macroexp-macroexpand (form env)
+  "Like `macroexpand' but checking obsolescence."
+  (let ((new-form
+         (macroexpand form env)))
+    (if (and (not (eq form new-form))   ;It was a macro call.
+             (car-safe form)
+             (symbolp (car form))
+             (get (car form) 'byte-obsolete-info)
+             (or (not (fboundp 'byte-compile-warning-enabled-p))
+                 (byte-compile-warning-enabled-p 'obsolete)))
+        (let* ((fun (car form))
+               (obsolete (get fun 'byte-obsolete-info)))
+          (macroexp--warn-and-return
+           (macroexp--obsolete-warning
+            fun obsolete
+            (if (symbolp (symbol-function fun))
+                "alias" "macro"))
+           new-form))
+      new-form)))
 
 (defun macroexp--expand-all (form)
   "Expand all macros in FORM.
 This is an internal version of `macroexpand-all'.
 Assumes the caller has bound `macroexpand-all-environment'."
-  (if (and (listp form) (eq (car form) 'backquote-list*))
+  (if (eq (car-safe form) 'backquote-list*)
       ;; Special-case `backquote-list*', as it is normally a macro that
       ;; generates exceedingly deep expansions from relatively shallow input
       ;; forms.  We just process it `in reverse' -- first we expand all the
@@ -156,24 +209,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
       (macroexpand (macroexp--all-forms form 1)
 		   macroexpand-all-environment)
     ;; Normal form; get its expansion, and then expand arguments.
-    (let ((new-form
-           (macroexpand form macroexpand-all-environment)))
-      (setq form
-            (if (and (not (eq form new-form)) ;It was a macro call.
-                     (car-safe form)
-                     (symbolp (car form))
-                     (get (car form) 'byte-obsolete-info)
-                     (or (not (fboundp 'byte-compile-warning-enabled-p))
-                         (byte-compile-warning-enabled-p 'obsolete)))
-                (let* ((fun (car form))
-                       (obsolete (get fun 'byte-obsolete-info)))
-                  (macroexp--warn-and-return
-                   (macroexp--obsolete-warning
-                    fun obsolete
-                    (if (symbolp (symbol-function fun))
-                        "alias" "macro"))
-                   new-form))
-              new-form)))
+    (setq form (macroexp-macroexpand form macroexpand-all-environment))
     (pcase form
       (`(cond . ,clauses)
        (macroexp--cons 'cond (macroexp--all-clauses clauses) form))
@@ -181,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
@@ -225,6 +261,10 @@ 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)
+       ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
+       ;; has a compiler-macro.
+       (macroexp--expand-all `(,f . ,args)))
       (`(,func . ,_)
        ;; Macro expand compiler macros.  This cannot be delayed to
        ;; byte-optimize-form because the output of the compiler-macro can
@@ -238,7 +278,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
            ;; If the handler is not loaded yet, try (auto)loading the
            ;; function itself, which may in turn load the handler.
            (unless (functionp handler)
-             (ignore-errors
+             (with-demoted-errors "macroexp--expand-all: %S"
                (autoload-do-load (indirect-function func) func)))
            (let ((newform (macroexp--compiler-macro handler form)))
              (if (eq form newform)
@@ -253,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)
@@ -266,13 +306,25 @@ definitions to shadow the loaded ones for use in file byte-compilation."
 
 ;;; Handy functions to use in macros.
 
+(defun macroexp-parse-body (body)
+  "Parse a function BODY into (DECLARATIONS . EXPS)."
+  (let ((decls ()))
+    (while (and (cdr body)
+                (let ((e (car body)))
+                  (or (stringp e)
+                      (memq (car-safe e)
+                            '(:documentation declare interactive cl-declare)))))
+      (push (pop body) decls))
+    (cons (nreverse decls) body)))
+
 (defun macroexp-progn (exps)
   "Return an expression equivalent to `(progn ,@EXPS)."
   (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)."
@@ -282,40 +334,83 @@ 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)
+  "Bind each binding in BINDINGS as `macroexp-let2' does."
+  (declare (indent 2) (debug (sexp (&rest (sexp form)) body)))
+  (pcase-exhaustive bindings
+    (`nil (macroexp-progn body))
+    (`((,var ,exp) . ,tl)
+     `(macroexp-let2 ,test ,var ,exp
+        (macroexp-let2* ,test ,tl ,@body)))))
+
 (defun macroexp--maxsize (exp size)
   (cond ((< size 0) size)
         ((symbolp exp) (1- size))
@@ -367,6 +462,18 @@ symbol itself."
   "Return non-nil if EXP can be copied without extra cost."
   (or (symbolp exp) (macroexp-const-p exp)))
 
+(defun macroexp-quote (v)
+  "Return an expression E such that `(eval E)' is V.
+
+E is either V or (quote V) depending on whether V evaluates to
+itself or not."
+  (if (and (not (consp v))
+	   (or (keywordp v)
+	       (not (symbolp v))
+	       (memq v '(nil t))))
+      v
+    (list 'quote v)))
+
 ;;; Load-time macro-expansion.
 
 ;; Because macro-expansion used to be more lazy, eager macro-expansion
@@ -402,7 +509,9 @@ symbol itself."
 (defvar macroexp--pending-eager-loads nil
   "Stack of files currently undergoing eager macro-expansion.")
 
-(defun internal-macroexpand-for-load (form)
+(defvar macroexp--debug-eager nil)
+
+(defun internal-macroexpand-for-load (form full-p)
   ;; Called from the eager-macroexpansion in readevalloop.
   (cond
    ;; Don't repeat the same warning for every top-level element.
@@ -417,15 +526,19 @@ symbol itself."
            (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
     (condition-case err
         (let ((macroexp--pending-eager-loads
                (cons load-file-name macroexp--pending-eager-loads)))
-          (macroexpand-all form))
+          (if full-p
+              (macroexpand-all form)
+            (macroexpand form)))
       (error
        ;; Hopefully this shouldn't happen thanks to the cycle detection,
        ;; but in case it does happen, let's catch the error and give the