;;; 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>
(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
(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
(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.")
;; 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))))
(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.
(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
- ((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 '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)))
(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)
- (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)))
+ ;; 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))
(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)
"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))
- (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."
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))
(setq directories (nconc directories (list source))))
;; It is an ordinary file. Decide whether to compile it.
(if (and (string-match emacs-lisp-file-regexp source)
+ ;; The next 2 tests avoid compiling lock files
(file-readable-p source)
+ (not (string-match "\\`\\.#" file))
(not (auto-save-file-name-p source))
(not (string-equal dir-locals-file
(file-name-nondirectory source))))
- (progn (cl-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))
"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)
(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)))
+(defvar byte-compile-level 0 ; bug#13787
+ "Depth of a recursive byte compilation.")
+
;;;###autoload
(defun byte-compile-file (filename &optional load)
"Compile a file of Lisp code named FILENAME into a file of byte code.
(setq target-file (byte-compile-dest-file filename))
(setq byte-compile-dest-file target-file)
(with-current-buffer
- (setq input-buffer (get-buffer-create " *Compiler Input*"))
+ ;; It would be cleaner to use a temp buffer, but if there was
+ ;; an error, we leave this buffer around for diagnostics.
+ ;; Its name is documented in the lispref.
+ (setq input-buffer (get-buffer-create
+ (concat " *Compiler Input*"
+ (if (zerop byte-compile-level) ""
+ (format "-%s" byte-compile-level)))))
(erase-buffer)
(setq buffer-file-coding-system nil)
;; Always compile an Emacs Lisp file as multibyte
;; 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
(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'"
- (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.
;; within byte-compile-from-buffer lingers in that buffer.
(setq output-buffer
(save-current-buffer
- (byte-compile-from-buffer input-buffer)))
+ (let ((byte-compile-level (1+ byte-compile-level)))
+ (byte-compile-from-buffer input-buffer))))
(if byte-compiler-error-flag
nil
(when byte-compile-verbose
(kill-emacs-hook
(cons (lambda () (ignore-errors (delete-file tempfile)))
kill-emacs-hook)))
- (if (memq system-type '(ms-dos 'windows-nt))
- (setq buffer-file-type t))
(write-region (point-min) (point-max) tempfile nil 1)
;; This has the intentional side effect that any
;; hard-links to target-file continue to
(byte-compile-close-variables
(with-current-buffer
(setq byte-compile--outbuffer
- (get-buffer-create " *Compiler Output*"))
+ (get-buffer-create
+ (concat " *Compiler Output*"
+ (if (<= byte-compile-level 1) ""
+ (format "-%s" (1- byte-compile-level))))))
(set-buffer-multibyte t)
(erase-buffer)
;; (emacs-lisp-mode)
(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)
(when (symbolp form)
(unless (memq (car-safe fun) '(closure lambda))
(error "Don't know how to compile %S" fun))
- (setq fun (byte-compile--reify-function fun))
- (setq lexical-binding (eq (car fun) 'closure)))
+ (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 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)
;; Old-style byte-code.
(cl-assert (listp fargs))
(while fargs
- (cl-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))
- (t (push (pop fargs) dynbinds))))
+ (_ (push (pop fargs) dynbinds))))
(unless fmax2 (setq fmax2 (* 2 (length dynbinds)))))
(cond
((<= (+ alen alen) fmax2)
(and od
(not (memq var byte-compile-not-obsolete-vars))
(not (memq var byte-compile-global-not-obsolete-vars))
- (or (cl-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)
(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))
- (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))))))
+ (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)
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
- ,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)))
(if byte-compile-call-tree-sort
(setq byte-compile-call-tree
(sort byte-compile-call-tree
- (cl-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)))))
- (calls
+ (`calls
(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))))))
- (name
+ (`name
(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)