Merge from emacs-24; up to 2012-12-06T01:39:03Z!monnier@iro.umontreal.ca

[gnu-emacs] / lisp / emacs-lisp / bytecomp.el

diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index bf6237cb12050c55f8dbdbb6dc00a5585dcac6b2..4e002cfc8cb8d6debbe33f545eb2bd845523cc50 100644 (file)
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -1,7 +1,7 @@
 ;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*-
 
 ;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*-
 

-;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2012
-;;   Free Software Foundation, Inc.
+;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2013 Free Software
+;; Foundation, Inc.

 
 ;; Author: Jamie Zawinski <jwz@lucid.com>
 ;;     Hallvard Furuseth <hbf@ulrik.uio.no>
 
 ;; Author: Jamie Zawinski <jwz@lucid.com>
 ;;     Hallvard Furuseth <hbf@ulrik.uio.no>


@@ -120,7 +120,7 @@
 (require 'backquote)
 (require 'macroexp)
 (require 'cconv)
 (require 'backquote)
 (require 'macroexp)
 (require 'cconv)

-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))

 
 (or (fboundp 'defsubst)
     ;; This really ought to be loaded already!
 
 (or (fboundp 'defsubst)
     ;; This really ought to be loaded already!


@@ -355,7 +355,7 @@ else the global value will be modified."
 (defvar byte-compile-interactive-only-functions
   '(beginning-of-buffer end-of-buffer replace-string replace-regexp
     insert-file insert-buffer insert-file-literally previous-line next-line
 (defvar byte-compile-interactive-only-functions
   '(beginning-of-buffer end-of-buffer replace-string replace-regexp
     insert-file insert-buffer insert-file-literally previous-line next-line

-    goto-line comint-run delete-backward-char toggle-read-only)
+    goto-line comint-run delete-backward-char)

   "List of commands that are not meant to be called from Lisp.")
 
 (defvar byte-compile-not-obsolete-vars nil
   "List of commands that are not meant to be called from Lisp.")
 
 (defvar byte-compile-not-obsolete-vars nil


@@ -419,8 +419,8 @@ This list lives partly on the stack.")
 
 (defconst byte-compile-initial-macro-environment
   '(
 
 (defconst byte-compile-initial-macro-environment
   '(

-;;     (byte-compiler-options . (lambda (&rest forms)
-;;                            (apply 'byte-compiler-options-handler forms)))
+    ;; (byte-compiler-options . (lambda (&rest forms)
+    ;;                        (apply 'byte-compiler-options-handler forms)))

     (declare-function . byte-compile-macroexpand-declare-function)
     (eval-when-compile . (lambda (&rest body)
                           (list
     (declare-function . byte-compile-macroexpand-declare-function)
     (eval-when-compile . (lambda (&rest body)
                           (list


@@ -429,8 +429,19 @@ This list lives partly on the stack.")
                              (byte-compile-top-level
                               (byte-compile-preprocess (cons 'progn body)))))))
     (eval-and-compile . (lambda (&rest body)
                              (byte-compile-top-level
                               (byte-compile-preprocess (cons 'progn body)))))))
     (eval-and-compile . (lambda (&rest body)

-                         (byte-compile-eval-before-compile (cons 'progn body))
-                         (cons 'progn body))))
+                          ;; Byte compile before running it.  Do it piece by
+                          ;; piece, in case further expressions need earlier
+                          ;; ones to be evaluated already, as is the case in
+                          ;; eieio.el.
+                          `(progn
+                             ,@(mapcar (lambda (exp)
+                                         (let ((cexp
+                                                (byte-compile-top-level
+                                                 (byte-compile-preprocess
+                                                  exp))))
+                                           (eval cexp)
+                                           cexp))
+                                       body)))))

   "The default macro-environment passed to macroexpand by the compiler.
 Placing a macro here will cause a macro to have different semantics when
 expanded by the compiler as when expanded by the interpreter.")
   "The default macro-environment passed to macroexpand by the compiler.
 Placing a macro here will cause a macro to have different semantics when
 expanded by the compiler as when expanded by the interpreter.")


@@ -731,14 +742,16 @@ otherwise pop it")
 ;; Also, this lets us notice references to free variables.
 
 (defmacro byte-compile-push-bytecodes (&rest args)
 ;; Also, this lets us notice references to free variables.
 
 (defmacro byte-compile-push-bytecodes (&rest args)

-  "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed.
-ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names.
-BYTES and PC are updated after evaluating all the arguments."
+  "Push bytes onto BVAR, and increment CVAR by the number of bytes pushed.
+BVAR and CVAR are variables which are updated after evaluating
+all the arguments.
+
+\(fn BYTE1 BYTE2 ... BYTEn BVAR CVAR)"

   (let ((byte-exprs (butlast args 2))
        (bytes-var (car (last args 2)))
        (pc-var (car (last args))))
     `(setq ,bytes-var ,(if (null (cdr byte-exprs))
   (let ((byte-exprs (butlast args 2))
        (bytes-var (car (last args 2)))
        (pc-var (car (last args))))
     `(setq ,bytes-var ,(if (null (cdr byte-exprs))

-                           `(progn (assert (<= 0 ,(car byte-exprs)))
+                           `(progn (cl-assert (<= 0 ,(car byte-exprs)))

                                    (cons ,@byte-exprs ,bytes-var))
                          `(nconc (list ,@(reverse byte-exprs)) ,bytes-var))
            ,pc-var (+ ,(length byte-exprs) ,pc-var))))
                                    (cons ,@byte-exprs ,bytes-var))
                          `(nconc (list ,@(reverse byte-exprs)) ,bytes-var))
            ,pc-var (+ ,(length byte-exprs) ,pc-var))))


@@ -846,7 +859,7 @@ CONST2 may be evaluated multiple times."
 (defun byte-compile-cl-file-p (file)
   "Return non-nil if FILE is one of the CL files."
   (and (stringp file)
 (defun byte-compile-cl-file-p (file)
   "Return non-nil if FILE is one of the CL files."
   (and (stringp file)

-       (string-match "^cl\\>" (file-name-nondirectory file))))
+       (string-match "^cl\\.el" (file-name-nondirectory file))))

 
 (defun byte-compile-eval (form)
   "Eval FORM and mark the functions defined therein.
 
 (defun byte-compile-eval (form)
   "Eval FORM and mark the functions defined therein.


@@ -863,25 +876,14 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
            (let ((xs (pop hist-new))
                  old-autoloads)
              ;; Make sure the file was not already loaded before.
            (let ((xs (pop hist-new))
                  old-autoloads)
              ;; Make sure the file was not already loaded before.

-             (unless (or (assoc (car xs) hist-orig)
-                         ;; Don't give both the "noruntime" and
-                         ;; "cl-functions" warning for the same function.
-                         ;; FIXME This seems incorrect - these are two
-                         ;; independent warnings.  For example, you may be
-                         ;; choosing to see the cl warnings but ignore them.
-                         ;; You probably don't want to ignore noruntime in the
-                         ;; same way.
-                         (and (byte-compile-warning-enabled-p 'cl-functions)
-                              (byte-compile-cl-file-p (car xs))))
+             (unless (assoc (car xs) hist-orig)

                (dolist (s xs)
                  (cond
                (dolist (s xs)
                  (cond

-                  ((symbolp s)
-                   (unless (memq s old-autoloads)
-                     (push s byte-compile-noruntime-functions)))

                   ((and (consp s) (eq t (car s)))
                    (push (cdr s) old-autoloads))
                   ((and (consp s) (eq t (car s)))
                    (push (cdr s) old-autoloads))

-                  ((and (consp s) (eq 'autoload (car s)))
-                   (push (cdr s) byte-compile-noruntime-functions)))))))
+                  ((and (consp s) (memq (car s) '(autoload defun)))
+                   (unless (memq (cdr s) old-autoloads)
+                      (push (cdr s) byte-compile-noruntime-functions))))))))

          ;; Go through current-load-list for the locally defined funs.
          (let (old-autoloads)
            (while (and hist-nil-new (not (eq hist-nil-new hist-nil-orig)))
          ;; Go through current-load-list for the locally defined funs.
          (let (old-autoloads)
            (while (and hist-nil-new (not (eq hist-nil-new hist-nil-orig)))


@@ -1005,17 +1007,29 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
 (defvar byte-compile-root-dir nil
   "Directory relative to which file names in error messages are written.")
 
 (defvar byte-compile-root-dir nil
   "Directory relative to which file names in error messages are written.")
 

+;; FIXME: We should maybe extend abbreviate-file-name with an optional DIR
+;; argument to try and use a relative file-name.
+(defun byte-compile-abbreviate-file (file &optional dir)
+  (let ((f1 (abbreviate-file-name file))
+        (f2 (file-relative-name file dir)))
+    (if (< (length f2) (length f1)) f2 f1)))
+

 ;; This is used as warning-prefix for the compiler.
 ;; It is always called with the warnings buffer current.
 (defun byte-compile-warning-prefix (level entry)
   (let* ((inhibit-read-only t)
         (dir (or byte-compile-root-dir default-directory))
         (file (cond ((stringp byte-compile-current-file)
 ;; This is used as warning-prefix for the compiler.
 ;; It is always called with the warnings buffer current.
 (defun byte-compile-warning-prefix (level entry)
   (let* ((inhibit-read-only t)
         (dir (or byte-compile-root-dir default-directory))
         (file (cond ((stringp byte-compile-current-file)

-                     (format "%s:" (file-relative-name
+                     (format "%s:" (byte-compile-abbreviate-file

                                      byte-compile-current-file dir)))
                     ((bufferp byte-compile-current-file)
                      (format "Buffer %s:"
                              (buffer-name byte-compile-current-file)))
                                      byte-compile-current-file dir)))
                     ((bufferp byte-compile-current-file)
                      (format "Buffer %s:"
                              (buffer-name byte-compile-current-file)))

+                    ;; We might be simply loading a file that
+                    ;; contains explicit calls to byte-compile functions.
+                    ((stringp load-file-name)
+                     (format "%s:" (byte-compile-abbreviate-file
+                                     load-file-name dir)))

                     (t "")))
         (pos (if (and byte-compile-current-file
                       (integerp byte-compile-read-position))
                     (t "")))
         (pos (if (and byte-compile-current-file
                       (integerp byte-compile-read-position))


@@ -1096,8 +1110,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
 (defun byte-compile-log-warning (string &optional fill level)
   (let ((warning-prefix-function 'byte-compile-warning-prefix)
        (warning-type-format "")
 (defun byte-compile-log-warning (string &optional fill level)
   (let ((warning-prefix-function 'byte-compile-warning-prefix)
        (warning-type-format "")

-       (warning-fill-prefix (if fill "    "))
-       (inhibit-read-only t))
+       (warning-fill-prefix (if fill "    ")))

     (display-warning 'bytecomp string level byte-compile-log-buffer)))
 
 (defun byte-compile-warn (format &rest args)
     (display-warning 'bytecomp string level byte-compile-log-buffer)))
 
 (defun byte-compile-warn (format &rest args)


@@ -1111,18 +1124,12 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
   "Warn that SYMBOL (a variable or function) is obsolete."
   (when (byte-compile-warning-enabled-p 'obsolete)
     (let* ((funcp (get symbol 'byte-obsolete-info))
   "Warn that SYMBOL (a variable or function) is obsolete."
   (when (byte-compile-warning-enabled-p 'obsolete)
     (let* ((funcp (get symbol 'byte-obsolete-info))

-          (obsolete (or funcp (get symbol 'byte-obsolete-variable)))
-          (instead (car obsolete))
-          (asof (nth 2 obsolete)))
+           (msg (macroexp--obsolete-warning
+                 symbol
+                 (or funcp (get symbol 'byte-obsolete-variable))
+                 (if funcp "function" "variable"))))

       (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs))
       (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs))

-       (byte-compile-warn "`%s' is an obsolete %s%s%s" symbol
-                          (if funcp "function" "variable")
-                          (if asof (concat " (as of " asof ")") "")
-                          (cond ((stringp instead)
-                                 (concat "; " instead))
-                                (instead
-                                 (format "; use `%s' instead." instead))
-                                (t ".")))))))
+       (byte-compile-warn "%s" msg)))))

 
 (defun byte-compile-report-error (error-info)
   "Report Lisp error in compilation.  ERROR-INFO is the error data."
 
 (defun byte-compile-report-error (error-info)
   "Report Lisp error in compilation.  ERROR-INFO is the error data."


@@ -1355,7 +1362,7 @@ extra args."
            nums sig min max)
        (when calls
           (when (and (symbolp name)
            nums sig min max)
        (when calls
           (when (and (symbolp name)

-                     (eq (get name 'byte-optimizer)
+                     (eq (function-get name 'byte-optimizer)

                          'byte-compile-inline-expand))
             (byte-compile-warn "defsubst `%s' was used before it was defined"
                       name))
                          'byte-compile-inline-expand))
             (byte-compile-warn "defsubst `%s' was used before it was defined"
                       name))


@@ -1399,18 +1406,18 @@ extra args."
             ;; These aren't all aliases of subrs, so not trivial to
             ;; avoid hardwiring the list.
             (not (memq func
             ;; These aren't all aliases of subrs, so not trivial to
             ;; avoid hardwiring the list.
             (not (memq func

-                       '(cl-block-wrapper cl-block-throw
+                       '(cl--block-wrapper cl--block-throw

                          multiple-value-call nth-value
                          copy-seq first second rest endp cl-member
                          ;; These are included in generated code
                          ;; that can't be called except at compile time
                          ;; or unless cl is loaded anyway.
                          multiple-value-call nth-value
                          copy-seq first second rest endp cl-member
                          ;; These are included in generated code
                          ;; that can't be called except at compile time
                          ;; or unless cl is loaded anyway.

-                         cl-defsubst-expand cl-struct-setf-expander
+                         cl--defsubst-expand cl-struct-setf-expander

                          ;; These would sometimes be warned about
                          ;; but such warnings are never useful,
                          ;; so don't warn about them.
                          macroexpand cl-macroexpand-all
                          ;; These would sometimes be warned about
                          ;; but such warnings are never useful,
                          ;; so don't warn about them.
                          macroexpand cl-macroexpand-all

-                         cl-compiling-file))))
+                         cl--compiling-file))))

        (byte-compile-warn "function `%s' from cl package called at runtime"
                           func)))
   form)
        (byte-compile-warn "function `%s' from cl package called at runtime"
                           func)))
   form)


@@ -1464,29 +1471,6 @@ extra args."
   nil)
 
 \f
   nil)
 
 \f

-(defsubst byte-compile-const-symbol-p (symbol &optional any-value)
-  "Non-nil if SYMBOL is constant.
-If ANY-VALUE is nil, only return non-nil if the value of the symbol is the
-symbol itself."
-  (or (memq symbol '(nil t))
-      (keywordp symbol)
-      (if any-value
-         (or (memq symbol byte-compile-const-variables)
-             ;; FIXME: We should provide a less intrusive way to find out
-             ;; if a variable is "constant".
-             (and (boundp symbol)
-                  (condition-case nil
-                      (progn (set symbol (symbol-value symbol)) nil)
-                    (setting-constant t)))))))
-
-(defmacro byte-compile-constp (form)
-  "Return non-nil if FORM is a constant."
-  `(cond ((consp ,form) (or (eq (car ,form) 'quote)
-                            (and (eq (car ,form) 'function)
-                                 (symbolp (cadr ,form)))))
-        ((not (symbolp ,form)))
-        ((byte-compile-const-symbol-p ,form))))
-

 ;; Dynamically bound in byte-compile-from-buffer.
 ;; NB also used in cl.el and cl-macs.el.
 (defvar byte-compile--outbuffer)
 ;; Dynamically bound in byte-compile-from-buffer.
 ;; NB also used in cl.el and cl-macs.el.
 (defvar byte-compile--outbuffer)


@@ -1614,10 +1598,11 @@ that already has a `.elc' file."
                         (not (auto-save-file-name-p source))
                         (not (string-equal dir-locals-file
                                            (file-name-nondirectory source))))
                         (not (auto-save-file-name-p source))
                         (not (string-equal dir-locals-file
                                            (file-name-nondirectory source))))

-                   (progn (case (byte-recompile-file source force arg)
-                            (no-byte-compile (setq skip-count (1+ skip-count)))
-                            ((t) (setq file-count (1+ file-count)))
-                            ((nil) (setq fail-count (1+ fail-count))))
+                   (progn (cl-incf
+                           (pcase (byte-recompile-file source force arg)
+                             (`no-byte-compile skip-count)
+                             (`t file-count)
+                             (_ fail-count)))

                           (or noninteractive
                               (message "Checking %s..." directory))
                           (if (not (eq last-dir directory))
                           (or noninteractive
                               (message "Checking %s..." directory))
                           (if (not (eq last-dir directory))


@@ -1643,21 +1628,20 @@ This is normally set in local file variables at the end of the elisp file:
   "Recompile FILENAME file if it needs recompilation.
 This happens when its `.elc' file is older than itself.
 
   "Recompile FILENAME file if it needs recompilation.
 This happens when its `.elc' file is older than itself.
 

-If the `.elc' file exists and is up-to-date, normally this
-function *does not* compile FILENAME. However, if the
-prefix argument FORCE is set, that means do compile
-FILENAME even if the destination already exists and is
-up-to-date.
+If the `.elc' file exists and is up-to-date, normally this function
+*does not* compile FILENAME.  If the prefix argument FORCE is non-nil,
+however, it compiles FILENAME even if the destination already
+exists and is up-to-date.

 
 

-If the `.elc' file does not exist, normally this function *does
-not* compile FILENAME. If ARG is 0, that means
-compile the file even if it has never been compiled before.
-A nonzero ARG means ask the user.
+If the `.elc' file does not exist, normally this function *does not*
+compile FILENAME.  If optional argument ARG is 0, it compiles
+the input file even if the `.elc' file does not exist.
+Any other non-nil value of ARG means to ask the user.

 
 

-If LOAD is set, `load' the file after compiling.
+If optional argument LOAD is non-nil, loads the file after compiling.

 
 

-The value returned is the value returned by `byte-compile-file',
-or 'no-byte-compile if the file did not need recompilation."
+If compilation is needed, this functions returns the result of
+`byte-compile-file'; otherwise it returns 'no-byte-compile."

   (interactive
    (let ((file buffer-file-name)
         (file-name nil)
   (interactive
    (let ((file buffer-file-name)
         (file-name nil)


@@ -1687,7 +1671,8 @@ or 'no-byte-compile if the file did not need recompilation."
           (if (and noninteractive (not byte-compile-verbose))
               (message "Compiling %s..." filename))
           (byte-compile-file filename load))
           (if (and noninteractive (not byte-compile-verbose))
               (message "Compiling %s..." filename))
           (byte-compile-file filename load))

-      (when load (load filename))
+      (when load
+       (load (if (file-exists-p dest) dest filename)))

       'no-byte-compile)))
 
 ;;;###autoload
       'no-byte-compile)))
 
 ;;;###autoload


@@ -1748,17 +1733,24 @@ The value is non-nil if there were no errors, nil if errors."
        (set-buffer-multibyte nil))
       ;; Run hooks including the uncompression hook.
       ;; If they change the file name, then change it for the output also.
        (set-buffer-multibyte nil))
       ;; Run hooks including the uncompression hook.
       ;; If they change the file name, then change it for the output also.

-      (letf ((buffer-file-name filename)
-             ((default-value 'major-mode) 'emacs-lisp-mode)
-             ;; Ignore unsafe local variables.
-             ;; We only care about a few of them for our purposes.
-             (enable-local-variables :safe)
-             (enable-local-eval nil))
-       ;; Arg of t means don't alter enable-local-variables.
-        (normal-mode t)
+      (let ((buffer-file-name filename)
+            (dmm (default-value 'major-mode))
+            ;; Ignore unsafe local variables.
+            ;; We only care about a few of them for our purposes.
+            (enable-local-variables :safe)
+            (enable-local-eval nil))
+        (unwind-protect
+            (progn
+              (setq-default major-mode 'emacs-lisp-mode)
+              ;; Arg of t means don't alter enable-local-variables.
+              (normal-mode t))
+          (setq-default major-mode dmm))

         ;; There may be a file local variable setting (bug#10419).
         (setq buffer-read-only nil
               filename buffer-file-name))
         ;; There may be a file local variable setting (bug#10419).
         (setq buffer-read-only nil
               filename buffer-file-name))

+      ;; Don't inherit lexical-binding from caller (bug#12938).
+      (unless (local-variable-p 'lexical-binding)
+        (setq-local lexical-binding nil))

       ;; Set the default directory, in case an eval-when-compile uses it.
       (setq default-directory (file-name-directory filename)))
     ;; Check if the file's local variables explicitly specify not to
       ;; Set the default directory, in case an eval-when-compile uses it.
       (setq default-directory (file-name-directory filename)))
     ;; Check if the file's local variables explicitly specify not to


@@ -1766,11 +1758,11 @@ The value is non-nil if there were no errors, nil if errors."
     (if (with-current-buffer input-buffer no-byte-compile)
        (progn
          ;; (message "%s not compiled because of `no-byte-compile: %s'"
     (if (with-current-buffer input-buffer no-byte-compile)
        (progn
          ;; (message "%s not compiled because of `no-byte-compile: %s'"

-         ;;       (file-relative-name filename)
+         ;;       (byte-compile-abbreviate-file filename)

          ;;       (with-current-buffer input-buffer no-byte-compile))
          (when (file-exists-p target-file)
            (message "%s deleted because of `no-byte-compile: %s'"
          ;;       (with-current-buffer input-buffer no-byte-compile))
          (when (file-exists-p target-file)
            (message "%s deleted because of `no-byte-compile: %s'"

-                    (file-relative-name target-file)
+                    (byte-compile-abbreviate-file target-file)

                     (buffer-local-value 'no-byte-compile input-buffer))
            (condition-case nil (delete-file target-file) (error nil)))
          ;; We successfully didn't compile this file.
                     (buffer-local-value 'no-byte-compile input-buffer))
            (condition-case nil (delete-file target-file) (error nil)))
          ;; We successfully didn't compile this file.


@@ -2204,7 +2196,7 @@ list that represents a doc string reference.
 (put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload)
 (defun byte-compile-file-form-autoload (form)
   (and (let ((form form))
 (put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload)
 (defun byte-compile-file-form-autoload (form)
   (and (let ((form form))

-        (while (if (setq form (cdr form)) (byte-compile-constp (car form))))
+        (while (if (setq form (cdr form)) (macroexp-const-p (car form))))

         (null form))                   ;Constants only
        (eval (nth 5 form))             ;Macro
        (eval form))                    ;Define the autoload.
         (null form))                   ;Constants only
        (eval (nth 5 form))             ;Macro
        (eval form))                    ;Define the autoload.


@@ -2212,7 +2204,10 @@ list that represents a doc string reference.
   (when (and (consp (nth 1 form))
           (eq (car (nth 1 form)) 'quote)
           (consp (cdr (nth 1 form)))
   (when (and (consp (nth 1 form))
           (eq (car (nth 1 form)) 'quote)
           (consp (cdr (nth 1 form)))

-          (symbolp (nth 1 (nth 1 form))))
+             (symbolp (nth 1 (nth 1 form)))
+             ;; Don't add it if it's already defined.  Otherwise, it might
+             ;; hide the actual definition.
+             (not (fboundp (nth 1 (nth 1 form)))))

     (push (cons (nth 1 (nth 1 form))
                (cons 'autoload (cdr (cdr form))))
          byte-compile-function-environment)
     (push (cons (nth 1 (nth 1 form))
                (cons 'autoload (cdr (cdr form))))
          byte-compile-function-environment)


@@ -2386,7 +2381,7 @@ not to take responsibility for the actual compilation of the code."
       ;;(byte-compile-set-symbol-position name)
       (byte-compile-warn "probable `\"' without `\\' in doc string of %s"
                          name))
       ;;(byte-compile-set-symbol-position name)
       (byte-compile-warn "probable `\"' without `\\' in doc string of %s"
                          name))

-    
+

     (if (not (listp body))
         ;; The precise definition requires evaluation to find out, so it
         ;; will only be known at runtime.
     (if (not (listp body))
         ;; The precise definition requires evaluation to find out, so it
         ;; will only be known at runtime.


@@ -2470,7 +2465,26 @@ If QUOTED is non-nil, print with quoting; otherwise, print without quoting."
           (- (position-bytes (point)) (point-min) -1)
         (goto-char (point-max))))))
 
           (- (position-bytes (point)) (point-min) -1)
         (goto-char (point-max))))))
 

-
+(defun byte-compile--reify-function (fun)
+  "Return an expression which will evaluate to a function value FUN.
+FUN should be either a `lambda' value or a `closure' value."
+  (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil))
+                    `(closure ,env ,args . ,body)) fun)
+               (renv ()))
+    ;; Turn the function's closed vars (if any) into local let bindings.
+    (dolist (binding env)
+      (cond
+       ((consp binding)
+        ;; We check shadowing by the args, so that the `let' can be moved
+        ;; within the lambda, which can then be unfolded.  FIXME: Some of those
+        ;; bindings might be unused in `body'.
+        (unless (memq (car binding) args) ;Shadowed.
+          (push `(,(car binding) ',(cdr binding)) renv)))
+       ((eq binding t))
+       (t (push `(defvar ,binding) body))))
+    (if (null renv)
+        `(lambda ,args ,@body)
+      `(lambda ,args (let ,(nreverse renv) ,@body)))))

 \f
 ;;;###autoload
 (defun byte-compile (form)
 \f
 ;;;###autoload
 (defun byte-compile (form)


@@ -2478,23 +2492,39 @@ If QUOTED is non-nil, print with quoting; otherwise, print without quoting."
 If FORM is a lambda or a macro, byte-compile it as a function."
   (displaying-byte-compile-warnings
    (byte-compile-close-variables
 If FORM is a lambda or a macro, byte-compile it as a function."
   (displaying-byte-compile-warnings
    (byte-compile-close-variables

-    (let* ((fun (if (symbolp form)
+    (let* ((lexical-binding lexical-binding)
+           (fun (if (symbolp form)

                    (and (fboundp form) (symbol-function form))
                  form))
           (macro (eq (car-safe fun) 'macro)))
       (if macro
          (setq fun (cdr fun)))
                    (and (fboundp form) (symbol-function form))
                  form))
           (macro (eq (car-safe fun) 'macro)))
       (if macro
          (setq fun (cdr fun)))

-      (cond ((eq (car-safe fun) 'lambda)
-            ;; Expand macros.
-             (setq fun (byte-compile-preprocess fun))
-            ;; Get rid of the `function' quote added by the `lambda' macro.
-            (if (eq (car-safe fun) 'function) (setq fun (cadr fun)))
-            (setq fun (if macro
-                          (cons 'macro (byte-compile-lambda fun))
-                        (byte-compile-lambda fun)))
-            (if (symbolp form)
-                (defalias form fun)
-              fun)))))))
+      (cond
+       ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to
+       ;; compile something invalid.  So let's tune down the complaint from an
+       ;; error to a simple message for the known case where signaling an error
+       ;; causes problems.
+       ((byte-code-function-p fun)
+        (message "Function %s is already compiled"
+                 (if (symbolp form) form "provided"))
+        fun)
+       (t
+        (when (symbolp form)
+          (unless (memq (car-safe fun) '(closure lambda))
+            (error "Don't know how to compile %S" fun))
+          (setq lexical-binding (eq (car fun) 'closure))
+          (setq fun (byte-compile--reify-function fun)))
+        (unless (eq (car-safe fun) 'lambda)
+          (error "Don't know how to compile %S" fun))
+        ;; Expand macros.
+        (setq fun (byte-compile-preprocess fun))
+        ;; Get rid of the `function' quote added by the `lambda' macro.
+        (if (eq (car-safe fun) 'function) (setq fun (cadr fun)))
+        (setq fun (byte-compile-lambda fun))
+        (if macro (push 'macro fun))
+        (if (symbolp form)
+            (fset form fun)
+          fun)))))))

 
 (defun byte-compile-sexp (sexp)
   "Compile and return SEXP."
 
 (defun byte-compile-sexp (sexp)
   "Compile and return SEXP."


@@ -2510,7 +2540,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
        (when (symbolp arg)
          (byte-compile-set-symbol-position arg))
        (cond ((or (not (symbolp arg))
        (when (symbolp arg)
          (byte-compile-set-symbol-position arg))
        (cond ((or (not (symbolp arg))

-                  (byte-compile-const-symbol-p arg t))
+                  (macroexp--const-symbol-p arg t))

               (error "Invalid lambda variable %s" arg))
              ((eq arg '&rest)
               (unless (cdr list)
               (error "Invalid lambda variable %s" arg))
              ((eq arg '&rest)
               (unless (cdr list)


@@ -2634,7 +2664,7 @@ for symbols generated by the byte compiler itself."
                                         (byte-compile-make-lambda-lexenv fun))
                                    reserved-csts)))
       ;; Build the actual byte-coded function.
                                         (byte-compile-make-lambda-lexenv fun))
                                    reserved-csts)))
       ;; Build the actual byte-coded function.

-      (assert (eq 'byte-code (car-safe compiled)))
+      (cl-assert (eq 'byte-code (car-safe compiled)))

       (apply #'make-byte-code
              (if lexical-binding
                  (byte-compile-make-args-desc arglist)
       (apply #'make-byte-code
              (if lexical-binding
                  (byte-compile-make-args-desc arglist)


@@ -2677,7 +2707,7 @@ for symbols generated by the byte compiler itself."
       (while (and rest (< i limit))
        (cond
         ((numberp (car rest))
       (while (and rest (< i limit))
        (cond
         ((numberp (car rest))

-         (assert (< (car rest) byte-compile-reserved-constants)))
+         (cl-assert (< (car rest) byte-compile-reserved-constants)))

         ((setq tmp (assq (car (car rest)) ret))
          (setcdr (car rest) (cdr tmp)))
         (t
         ((setq tmp (assq (car (car rest)) ret))
          (setcdr (car rest) (cdr tmp)))
         (t


@@ -2779,7 +2809,7 @@ for symbols generated by the byte compiler itself."
                   (if (if (eq (car (car rest)) 'byte-constant)
                           (or (consp tmp)
                               (and (symbolp tmp)
                   (if (if (eq (car (car rest)) 'byte-constant)
                           (or (consp tmp)
                               (and (symbolp tmp)

-                                   (not (byte-compile-const-symbol-p tmp)))))
+                                   (not (macroexp--const-symbol-p tmp)))))

                       (if maycall
                           (setq body (cons (list 'quote tmp) body)))
                     (setq body (cons tmp body))))
                       (if maycall
                           (setq body (cons (list 'quote tmp) body)))
                     (setq body (cons tmp body))))


@@ -2796,7 +2826,8 @@ for symbols generated by the byte compiler itself."
                   (setq body (nreverse body))
                   (setq body (list
                               (if (and (eq tmp 'funcall)
                   (setq body (nreverse body))
                   (setq body (list
                               (if (and (eq tmp 'funcall)

-                                       (eq (car-safe (car body)) 'quote))
+                                       (eq (car-safe (car body)) 'quote)
+                                      (symbolp (nth 1 (car body))))

                                   (cons (nth 1 (car body)) (cdr body))
                                 (cons tmp body))))
                   (or (eq output-type 'file)
                                   (cons (nth 1 (car body)) (cdr body))
                                 (cons tmp body))))
                   (or (eq output-type 'file)


@@ -2850,7 +2881,7 @@ for symbols generated by the byte compiler itself."
   (let ((byte-compile--for-effect for-effect))
     (cond
      ((not (consp form))
   (let ((byte-compile--for-effect for-effect))
     (cond
      ((not (consp form))

-      (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form))
+      (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form))

              (when (symbolp form)
                (byte-compile-set-symbol-position form))
              (byte-compile-constant form))
              (when (symbolp form)
                (byte-compile-set-symbol-position form))
              (byte-compile-constant form))


@@ -2863,7 +2894,7 @@ for symbols generated by the byte compiler itself."
      ((symbolp (car form))
       (let* ((fn (car form))
              (handler (get fn 'byte-compile)))
      ((symbolp (car form))
       (let* ((fn (car form))
              (handler (get fn 'byte-compile)))

-        (when (byte-compile-const-symbol-p fn)
+        (when (macroexp--const-symbol-p fn)

           (byte-compile-warn "`%s' called as a function" fn))
         (and (byte-compile-warning-enabled-p 'interactive-only)
              (memq fn byte-compile-interactive-only-functions)
           (byte-compile-warn "`%s' called as a function" fn))
         (and (byte-compile-warning-enabled-p 'interactive-only)
              (memq fn byte-compile-interactive-only-functions)


@@ -2874,14 +2905,12 @@ That command is designed for interactive use only" fn))
             (byte-compile-log-warning
              (format "Forgot to expand macro %s" (car form)) nil :error))
         (if (and handler
             (byte-compile-log-warning
              (format "Forgot to expand macro %s" (car form)) nil :error))
         (if (and handler

-                 ;; Make sure that function exists.  This is important
-                 ;; for CL compiler macros since the symbol may be
-                 ;; `cl-byte-compile-compiler-macro' but if CL isn't
-                 ;; loaded, this function doesn't exist.
-                 (and (not (eq handler
-                               ;; Already handled by macroexpand-all.
-                               'cl-byte-compile-compiler-macro))
-                      (functionp handler)))
+                 ;; Make sure that function exists.
+                 (and (functionp handler)
+                      ;; Ignore obsolete byte-compile function used by former
+                      ;; CL code to handle compiler macros (we do it
+                      ;; differently now).
+                      (not (eq handler 'cl-byte-compile-compiler-macro))))

             (funcall handler form)
           (byte-compile-normal-call form))
         (if (byte-compile-warning-enabled-p 'cl-functions)
             (funcall handler form)
           (byte-compile-normal-call form))
         (if (byte-compile-warning-enabled-p 'cl-functions)


@@ -2958,14 +2987,14 @@ That command is designed for interactive use only" fn))
     (mapc 'byte-compile-form (cdr form))
     (unless fmax2
       ;; Old-style byte-code.
     (mapc 'byte-compile-form (cdr form))
     (unless fmax2
       ;; Old-style byte-code.

-      (assert (listp fargs))
+      (cl-assert (listp fargs))

       (while fargs
       (while fargs

-        (case (car fargs)
-          (&optional (setq fargs (cdr fargs)))
-          (&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1))
+        (pcase (car fargs)
+          (`&optional (setq fargs (cdr fargs)))
+          (`&rest (setq fmax2 (+ (* 2 (length dynbinds)) 1))

                  (push (cadr fargs) dynbinds)
                  (setq fargs nil))
                  (push (cadr fargs) dynbinds)
                  (setq fargs nil))

-          (t (push (pop fargs) dynbinds))))
+          (_ (push (pop fargs) dynbinds))))

       (unless fmax2 (setq fmax2 (* 2 (length dynbinds)))))
     (cond
      ((<= (+ alen alen) fmax2)
       (unless fmax2 (setq fmax2 (* 2 (length dynbinds)))))
     (cond
      ((<= (+ alen alen) fmax2)


@@ -2979,7 +3008,7 @@ That command is designed for interactive use only" fn))
      (t
       ;; Turn &rest args into a list.
       (let ((n (- alen (/ (1- fmax2) 2))))
      (t
       ;; Turn &rest args into a list.
       (let ((n (- alen (/ (1- fmax2) 2))))

-        (assert (> n 0) nil "problem: fmax2=%S alen=%S n=%S" fmax2 alen n)
+        (cl-assert (> n 0) nil "problem: fmax2=%S alen=%S n=%S" fmax2 alen n)

         (if (< n 5)
             (byte-compile-out
              (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- n))
         (if (< n 5)
             (byte-compile-out
              (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- n))


@@ -2992,14 +3021,14 @@ That command is designed for interactive use only" fn))
     ;; Unbind dynamic variables.
     (when dynbinds
       (byte-compile-out 'byte-unbind (length dynbinds)))
     ;; Unbind dynamic variables.
     (when dynbinds
       (byte-compile-out 'byte-unbind (length dynbinds)))

-    (assert (eq byte-compile-depth (1+ start-depth))
+    (cl-assert (eq byte-compile-depth (1+ start-depth))

             nil "Wrong depth start=%s end=%s" start-depth byte-compile-depth)))
 
 (defun byte-compile-check-variable (var access-type)
   "Do various error checks before a use of the variable VAR."
   (when (symbolp var)
     (byte-compile-set-symbol-position var))
             nil "Wrong depth start=%s end=%s" start-depth byte-compile-depth)))
 
 (defun byte-compile-check-variable (var access-type)
   "Do various error checks before a use of the variable VAR."
   (when (symbolp var)
     (byte-compile-set-symbol-position var))

-  (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var))
+  (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var))

         (when (byte-compile-warning-enabled-p 'constants)
           (byte-compile-warn (if (eq access-type 'let-bind)
                                  "attempt to let-bind %s `%s`"
         (when (byte-compile-warning-enabled-p 'constants)
           (byte-compile-warn (if (eq access-type 'let-bind)
                                  "attempt to let-bind %s `%s`"


@@ -3010,10 +3039,10 @@ That command is designed for interactive use only" fn))
            (and od
                 (not (memq var byte-compile-not-obsolete-vars))
                 (not (memq var byte-compile-global-not-obsolete-vars))
            (and od
                 (not (memq var byte-compile-not-obsolete-vars))
                 (not (memq var byte-compile-global-not-obsolete-vars))

-                (or (case (nth 1 od)
-                      (set (not (eq access-type 'reference)))
-                      (get (eq access-type 'reference))
-                      (t t)))))
+                (or (pcase (nth 1 od)
+                      (`set (not (eq access-type 'reference)))
+                      (`get (eq access-type 'reference))
+                      (_ t)))))

         (byte-compile-warn-obsolete var))))
 
 (defsubst byte-compile-dynamic-variable-op (base-op var)
         (byte-compile-warn-obsolete var))))
 
 (defsubst byte-compile-dynamic-variable-op (base-op var)


@@ -3337,8 +3366,8 @@ discarding."
            (body (nthcdr 3 form))
            (fun
             (byte-compile-lambda `(lambda ,vars . ,body) nil (length env))))
            (body (nthcdr 3 form))
            (fun
             (byte-compile-lambda `(lambda ,vars . ,body) nil (length env))))

-      (assert (> (length env) 0))       ;Otherwise, we don't need a closure.
-      (assert (byte-code-function-p fun))
+      (cl-assert (> (length env) 0))       ;Otherwise, we don't need a closure.
+      (cl-assert (byte-code-function-p fun))

       (byte-compile-form `(make-byte-code
                            ',(aref fun 0) ',(aref fun 1)
                            (vconcat (vector . ,env) ',(aref fun 2))
       (byte-compile-form `(make-byte-code
                            ',(aref fun 0) ',(aref fun 1)
                            (vconcat (vector . ,env) ',(aref fun 2))


@@ -3563,20 +3592,22 @@ discarding."
 
 (defun byte-compile-setq-default (form)
   (setq form (cdr form))
 
 (defun byte-compile-setq-default (form)
   (setq form (cdr form))

-  (if (> (length form) 2)
-      (let ((setters ()))
-        (while (consp form)
-          (push `(setq-default ,(pop form) ,(pop form)) setters))
-        (byte-compile-form (cons 'progn (nreverse setters))))
-    (let ((var (car form)))
-      (and (or (not (symbolp var))
-               (byte-compile-const-symbol-p var t))
-           (byte-compile-warning-enabled-p 'constants)
-           (byte-compile-warn
-            "variable assignment to %s `%s'"
-            (if (symbolp var) "constant" "nonvariable")
-            (prin1-to-string var)))
-      (byte-compile-normal-call `(set-default ',var ,@(cdr form))))))
+  (if (null form)                      ; (setq-default), with no arguments
+      (byte-compile-form nil byte-compile--for-effect)
+    (if (> (length form) 2)
+       (let ((setters ()))
+         (while (consp form)
+           (push `(setq-default ,(pop form) ,(pop form)) setters))
+         (byte-compile-form (cons 'progn (nreverse setters))))
+      (let ((var (car form)))
+       (and (or (not (symbolp var))
+                (macroexp--const-symbol-p var t))
+            (byte-compile-warning-enabled-p 'constants)
+            (byte-compile-warn
+             "variable assignment to %s `%s'"
+             (if (symbolp var) "constant" "nonvariable")
+             (prin1-to-string var)))
+       (byte-compile-normal-call `(set-default ',var ,@(cdr form)))))))

 
 (byte-defop-compiler-1 set-default)
 (defun byte-compile-set-default (form)
 
 (byte-defop-compiler-1 set-default)
 (defun byte-compile-set-default (form)


@@ -3677,10 +3708,10 @@ If CONDITION's value is (not (featurep 'emacs)) or (featurep 'xemacs),
 that suppresses all warnings during execution of BODY."
   (declare (indent 1) (debug t))
   `(let* ((fbound-list (byte-compile-find-bound-condition
 that suppresses all warnings during execution of BODY."
   (declare (indent 1) (debug t))
   `(let* ((fbound-list (byte-compile-find-bound-condition

-                       ,condition (list 'fboundp)
+                       ,condition '(fboundp functionp)

                        byte-compile-unresolved-functions))
          (bound-list (byte-compile-find-bound-condition
                        byte-compile-unresolved-functions))
          (bound-list (byte-compile-find-bound-condition

-                      ,condition (list 'boundp 'default-boundp)))
+                      ,condition '(boundp default-boundp)))

          ;; Maybe add to the bound list.
          (byte-compile-bound-variables
            (append bound-list byte-compile-bound-variables)))
          ;; Maybe add to the bound list.
          (byte-compile-bound-variables
            (append bound-list byte-compile-bound-variables)))


@@ -3916,8 +3947,8 @@ binding slots have been popped."
         (if lexical-binding
             ;; Unbind both lexical and dynamic variables.
             (progn
         (if lexical-binding
             ;; Unbind both lexical and dynamic variables.
             (progn

-              (assert (or (eq byte-compile-depth init-stack-depth)
-                          (eq byte-compile-depth (1+ init-stack-depth))))
+              (cl-assert (or (eq byte-compile-depth init-stack-depth)
+                             (eq byte-compile-depth (1+ init-stack-depth))))

               (byte-compile-unbind clauses init-lexenv (> byte-compile-depth
                                                           init-stack-depth)))
           ;; Unbind dynamic variables.
               (byte-compile-unbind clauses init-lexenv (> byte-compile-depth
                                                           init-stack-depth)))
           ;; Unbind dynamic variables.


@@ -4119,8 +4150,8 @@ binding slots have been popped."
 
 (defun byte-compile-autoload (form)
   (byte-compile-set-symbol-position 'autoload)
 
 (defun byte-compile-autoload (form)
   (byte-compile-set-symbol-position 'autoload)

-  (and (byte-compile-constp (nth 1 form))
-       (byte-compile-constp (nth 5 form))
+  (and (macroexp-const-p (nth 1 form))
+       (macroexp-const-p (nth 5 form))

        (eval (nth 5 form))  ; macro-p
        (not (fboundp (eval (nth 1 form))))
        (byte-compile-warn
        (eval (nth 5 form))  ; macro-p
        (not (fboundp (eval (nth 1 form))))
        (byte-compile-warn


@@ -4337,21 +4368,21 @@ invoked interactively."
     (if byte-compile-call-tree-sort
        (setq byte-compile-call-tree
              (sort byte-compile-call-tree
     (if byte-compile-call-tree-sort
        (setq byte-compile-call-tree
              (sort byte-compile-call-tree

-                   (case byte-compile-call-tree-sort
-                      (callers
+                   (pcase byte-compile-call-tree-sort
+                      (`callers

                        (lambda (x y) (< (length (nth 1 x))
                                    (length (nth 1 y)))))
                        (lambda (x y) (< (length (nth 1 x))
                                    (length (nth 1 y)))))

-                      (calls
+                      (`calls

                        (lambda (x y) (< (length (nth 2 x))
                                    (length (nth 2 y)))))
                        (lambda (x y) (< (length (nth 2 x))
                                    (length (nth 2 y)))))

-                      (calls+callers
+                      (`calls+callers

                        (lambda (x y) (< (+ (length (nth 1 x))
                                       (length (nth 2 x)))
                                    (+ (length (nth 1 y))
                                       (length (nth 2 y))))))
                        (lambda (x y) (< (+ (length (nth 1 x))
                                       (length (nth 2 x)))
                                    (+ (length (nth 1 y))
                                       (length (nth 2 y))))))

-                      (name
+                      (`name

                        (lambda (x y) (string< (car x) (car y))))
                        (lambda (x y) (string< (car x) (car y))))

-                      (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode"
+                      (_ (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode"

                                 byte-compile-call-tree-sort))))))
     (message "Generating call tree...")
     (let ((rest byte-compile-call-tree)
                                 byte-compile-call-tree-sort))))))
     (message "Generating call tree...")
     (let ((rest byte-compile-call-tree)


@@ -4564,6 +4595,16 @@ and corresponding effects."
     (setq command-line-args-left (cdr command-line-args-left)))
   (kill-emacs 0))
 
     (setq command-line-args-left (cdr command-line-args-left)))
   (kill-emacs 0))
 

+;;; Core compiler macros.
+
+(put 'featurep 'compiler-macro
+     (lambda (form feature &rest _ignore)
+       ;; Emacs-21's byte-code doesn't run under XEmacs or SXEmacs anyway, so
+       ;; we can safely optimize away this test.
+       (if (member feature '('xemacs 'sxemacs 'emacs))
+           (eval form)
+         form)))
+

 (provide 'byte-compile)
 (provide 'bytecomp)
 
 (provide 'byte-compile)
 (provide 'bytecomp)