;;; bytecomp.el --- compilation of Lisp code into byte code
-;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1998, 2000, 2001, 2002
+;; Copyright (C) 1985,86,87,92,94,1998,2000,01,02,03,2004
;; Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Maintainer: FSF
;; Keywords: lisp
-;;; This version incorporates changes up to version 2.10 of the
-;;; Zawinski-Furuseth compiler.
-(defconst byte-compile-version "$Revision: 2.98 $")
-
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; User customization variables:
;;
;; byte-compile-verbose Whether to report the function currently being
-;; compiled in the minibuffer;
+;; compiled in the echo area;
;; byte-optimize Whether to do optimizations; this may be
;; t, nil, 'source, or 'byte;
;; byte-optimize-log Whether to report (in excruciating detail)
;; finding unused functions, as well as simple
;; performance metering.
;; byte-compile-warnings List of warnings to issue, or t. May contain
-;; 'free-vars (references to variables not in the
-;; current lexical scope)
-;; 'unresolved (calls to unknown functions)
-;; 'callargs (lambda calls with args that don't
-;; match the lambda's definition)
-;; 'redefine (function cell redefined from
-;; a macro to a lambda or vice versa,
-;; or redefined to take other args)
-;; 'obsolete (obsolete variables and functions)
-;; 'noruntime (calls to functions only defined
-;; within `eval-when-compile')
+;; `free-vars' (references to variables not in the
+;; current lexical scope)
+;; `unresolved' (calls to unknown functions)
+;; `callargs' (lambda calls with args that don't
+;; match the lambda's definition)
+;; `redefine' (function cell redefined from
+;; a macro to a lambda or vice versa,
+;; or redefined to take other args)
+;; `obsolete' (obsolete variables and functions)
+;; `noruntime' (calls to functions only defined
+;; within `eval-when-compile')
;; byte-compile-compatibility Whether the compiler should
;; generate .elc files which can be loaded into
;; generic emacs 18.
;; (baz 0))
;;
;; o It is possible to open-code a function in the same file it is defined
-;; in without having to load that file before compiling it. the
+;; in without having to load that file before compiling it. The
;; byte-compiler has been modified to remember function definitions in
;; the compilation environment in the same way that it remembers macro
;; definitions.
(or (fboundp 'defsubst)
;; This really ought to be loaded already!
- (load-library "byte-run"))
+ (load "byte-run"))
;; The feature of compiling in a specific target Emacs version
;; has been turned off because compile time options are a bad idea.
:type 'boolean)
(defcustom byte-compile-compatibility nil
- "*Non-nil means generate output that can run in Emacs 18."
+ "*Non-nil means generate output that can run in Emacs 18.
+This only means that it can run in principle, if it doesn't require
+facilities that have been added more recently."
:group 'bytecomp
:type 'boolean)
(const :tag "source-level" source)
(const :tag "byte-level" byte)))
-(defcustom byte-compile-delete-errors t
+(defcustom byte-compile-delete-errors nil
"*If non-nil, the optimizer may delete forms that may signal an error.
This includes variable references and calls to functions such as `car'."
:group 'bytecomp
:type 'boolean)
(defconst byte-compile-warning-types
- '(redefine callargs free-vars unresolved obsolete noruntime))
+ '(redefine callargs free-vars unresolved obsolete noruntime cl-functions)
+ "The list of warning types used when `byte-compile-warnings' is t.")
(defcustom byte-compile-warnings t
"*List of warnings that the byte-compiler should issue (t for all).
+
Elements of the list may be be:
free-vars references to variables not in the current lexical scope.
callargs lambda calls with args that don't match the definition.
redefine function cell redefined from a macro to a lambda or vice
versa, or redefined to take a different number of arguments.
- obsolete obsolete variables and functions."
+ obsolete obsolete variables and functions.
+ noruntime functions that may not be defined at runtime (typically
+ defined only under `eval-when-compile').
+ cl-functions calls to runtime functions from the CL package (as
+ distinguished from macros and aliases)."
:group 'bytecomp
- :type '(choice (const :tag "All" t)
+ :type `(choice (const :tag "All" t)
(set :menu-tag "Some"
(const free-vars) (const unresolved)
- (const callargs) (const redefined)
- (const obsolete) (const noruntime))))
+ (const callargs) (const redefine)
+ (const obsolete) (const noruntime) (const cl-functions))))
+
+(defvar byte-compile-not-obsolete-var nil
+ "If non-nil, this is a variable that shouldn't be reported as obsolete.")
(defcustom byte-compile-generate-call-tree nil
"*Non-nil means collect call-graph information when compiling.
(defvar byte-compile-bound-variables nil
"List of variables bound in the context of the current form.
This list lives partly on the stack.")
+(defvar byte-compile-const-variables nil
+ "List of variables declared as constants during compilation of this file.")
(defvar byte-compile-free-references)
(defvar byte-compile-free-assignments)
(byte-compile-eval (byte-compile-top-level
(cons 'progn body))))))
(eval-and-compile . (lambda (&rest body)
- (eval (cons 'progn body))
+ (byte-compile-eval-before-compile (cons 'progn body))
(cons 'progn body))))
"The default macro-environment passed to macroexpand by the compiler.
Placing a macro here will cause a macro to have different semantics when
Used for warnings when the function is not known to be defined or is later
defined with incorrect args.")
+(defvar byte-compile-noruntime-functions nil
+ "Alist of functions called that may not be defined when the compiled code is run.
+Used for warnings about calling a function that is defined during compilation
+but won't necessarily be defined when the compiled file is loaded.")
+
(defvar byte-compile-tag-number 0)
(defvar byte-compile-output nil
"Alist describing contents to put in byte code string.
(let ((pc 0) ; Program counter
op off ; Operation & offset
(bytes '()) ; Put the output bytes here
- (patchlist nil) ; List of tags and goto's to patch
- rest rel tmp)
+ (patchlist nil)) ; List of tags and goto's to patch
(while lap
(setq op (car (car lap))
off (cdr (car lap)))
(defun byte-compile-eval (form)
"Eval FORM and mark the functions defined therein.
-Each function's symbol gets marked with the `byte-compile-noruntime' property."
+Each function's symbol gets added to `byte-compile-noruntime-functions'."
(let ((hist-orig load-history)
(hist-nil-orig current-load-list))
(prog1 (eval form)
;; Go through load-history, look for newly loaded files
;; and mark all the functions defined therein.
(while (and hist-new (not (eq hist-new hist-orig)))
- (let ((xs (pop hist-new)))
+ (let ((xs (pop hist-new))
+ old-autoloads)
;; Make sure the file was not already loaded before.
(unless (assoc (car xs) hist-orig)
(dolist (s xs)
(cond
- ((symbolp s) (put s 'byte-compile-noruntime t))
+ ((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)))
- (put (cdr s) 'byte-compile-noruntime t)))))))
+ (push (cdr s) byte-compile-noruntime-functions)))))))
;; Go through current-load-list for the locally defined funs.
- (while (and hist-nil-new (not (eq hist-nil-new hist-nil-orig)))
- (let ((s (pop hist-nil-new)))
- (when (symbolp s)
- (put s 'byte-compile-noruntime t)))))))))
-
+ (let (old-autoloads)
+ (while (and hist-nil-new (not (eq hist-nil-new hist-nil-orig)))
+ (let ((s (pop hist-nil-new)))
+ (when (and (symbolp s) (not (memq s old-autoloads)))
+ (push s byte-compile-noruntime-functions))
+ (when (and (consp s) (eq t (car s)))
+ (push (cdr s) old-autoloads))))))))))
+
+(defun byte-compile-eval-before-compile (form)
+ "Evaluate FORM for `eval-and-compile'."
+ (let ((hist-nil-orig current-load-list))
+ (prog1 (eval form)
+ ;; (eval-and-compile (require 'cl) turns off warnings for cl functions.
+ (let ((tem current-load-list))
+ (while (not (eq tem hist-nil-orig))
+ (when (equal (car tem) '(require . cl))
+ (setq byte-compile-warnings
+ (remq 'cl-functions byte-compile-warnings)))
+ (setq tem (cdr tem)))))))
\f
;;; byte compiler messages
(defvar byte-compile-current-file nil)
(defvar byte-compile-current-buffer nil)
+;; Log something that isn't a warning.
(defmacro byte-compile-log (format-string &rest args)
(list 'and
'byte-optimize
(if (symbolp x) (list 'prin1-to-string x) x))
args)))))))
-(defvar byte-compile-last-warned-form nil)
-(defvar byte-compile-last-logged-file nil)
+;; Log something that isn't a warning.
+(defun byte-compile-log-1 (string)
+ (save-excursion
+ (byte-goto-log-buffer)
+ (goto-char (point-max))
+ (byte-compile-warning-prefix nil nil)
+ (cond (noninteractive
+ (message " %s" string))
+ (t
+ (insert (format "%s\n" string))))))
(defvar byte-compile-read-position nil
"Character position we began the last `read' from.")
"Last known character position in the input.")
;; copied from gnus-util.el
-(defun byte-compile-delete-first (elt list)
+(defsubst byte-compile-delete-first (elt list)
(if (eq (car list) elt)
(cdr list)
(let ((total list))
;; variable reference, like in (1+ foo), we remove `foo' from the
;; list. If our current position is after the symbol's position, we
;; assume we've already passed that point, and look for the next
-;; occurence of the symbol.
-;; So your're probably asking yourself: Isn't this function a
+;; occurrence of the symbol.
+;; So your're probably asking yourself: Isn't this function a
;; gross hack? And the answer, of course, would be yes.
(defun byte-compile-set-symbol-position (sym &optional allow-previous)
(when byte-compile-read-position
- (let ((last nil))
+ (let (last entry)
(while (progn
- (setq last byte-compile-last-position)
- (let* ((entry (assq sym read-symbol-positions-list))
- (cur (cdr entry)))
- (setq byte-compile-last-position
- (if cur
- (+ byte-compile-read-position cur)
- last))
- (setq
- read-symbol-positions-list
- (byte-compile-delete-first entry read-symbol-positions-list)))
+ (setq last byte-compile-last-position
+ entry (assq sym read-symbol-positions-list))
+ (when entry
+ (setq byte-compile-last-position
+ (+ byte-compile-read-position (cdr entry))
+ read-symbol-positions-list
+ (byte-compile-delete-first
+ entry read-symbol-positions-list)))
(or (and allow-previous (not (= last byte-compile-last-position)))
(> last byte-compile-last-position)))))))
-(defun byte-compile-display-log-head-p ()
- (and (not (eq byte-compile-current-form :end))
- (or (and byte-compile-current-file
- (not (equal byte-compile-current-file
- byte-compile-last-logged-file)))
- (and byte-compile-last-warned-form
- (not (eq byte-compile-current-form
- byte-compile-last-warned-form))))))
+(defvar byte-compile-last-warned-form nil)
+(defvar byte-compile-last-logged-file nil)
(defun byte-goto-log-buffer ()
(set-buffer (get-buffer-create "*Compile-Log*"))
(unless (eq major-mode 'compilation-mode)
(compilation-mode)))
-;; Log a message STRING in *Compile-Log*.
-;; Also log the current function and file if not already done.
-(defun byte-compile-log-1 (string &optional fill)
- (let* ((file (cond ((stringp byte-compile-current-file)
- (format "%s:" 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* ((dir default-directory)
+ (file (cond ((stringp byte-compile-current-file)
+ (format "%s:" (file-relative-name byte-compile-current-file dir)))
((bufferp byte-compile-current-file)
(format "Buffer %s:"
(buffer-name byte-compile-current-file)))
(goto-char byte-compile-last-position)
(1+ (current-column)))))
""))
- (form (or byte-compile-current-form "toplevel form")))
- (cond (noninteractive
- (when (byte-compile-display-log-head-p)
- (message "%s In %s" file form))
- (message "%s%s %s" file pos string))
- (t
- (save-excursion
- (byte-goto-log-buffer)
- (goto-char (point-max))
- (when (byte-compile-display-log-head-p)
- (insert (format "\nIn %s" form)))
- (insert (format "\n%s%s\n%s\n" file pos string))
- (when (and fill (not (string-match "\n" string)))
- (let ((fill-prefix " ") (fill-column 78))
- (fill-paragraph nil)))))))
+ (form (if (eq byte-compile-current-form :end) "end of data"
+ (or byte-compile-current-form "toplevel form"))))
+ (when (or (and byte-compile-current-file
+ (not (equal byte-compile-current-file
+ byte-compile-last-logged-file)))
+ (and byte-compile-current-form
+ (not (eq byte-compile-current-form
+ byte-compile-last-warned-form))))
+ (insert (format "\nIn %s:\n" form)))
+ (when level
+ (insert (format "%s%s" file pos))))
(setq byte-compile-last-logged-file byte-compile-current-file
- byte-compile-last-warned-form byte-compile-current-form))
+ byte-compile-last-warned-form byte-compile-current-form)
+ entry)
+
+;; This no-op function is used as the value of warning-series
+;; to tell inner calls to displaying-byte-compile-warnings
+;; not to bind warning-series.
+(defun byte-compile-warning-series (&rest ignore)
+ nil)
;; Log the start of a file in *Compile-Log*, and mark it as done.
+;; Return the position of the start of the page in the log buffer.
;; But do nothing in batch mode.
(defun byte-compile-log-file ()
- (and byte-compile-current-file
- (not (equal byte-compile-current-file byte-compile-last-logged-file))
+ (and (not (equal byte-compile-current-file byte-compile-last-logged-file))
(not noninteractive)
(save-excursion
- (byte-goto-log-buffer)
+ (set-buffer (get-buffer-create "*Compile-Log*"))
(goto-char (point-max))
- (insert "\n\^L\nCompiling "
- (if (stringp byte-compile-current-file)
- (concat "file " byte-compile-current-file)
- (concat "buffer " (buffer-name byte-compile-current-file)))
- " at " (current-time-string) "\n")
- (setq byte-compile-last-logged-file byte-compile-current-file))))
+ (let* ((dir (and byte-compile-current-file
+ (file-name-directory byte-compile-current-file)))
+ (was-same (equal default-directory dir))
+ pt)
+ (when dir
+ (unless was-same
+ (insert (format "Leaving directory `%s'\n" default-directory))))
+ (unless (bolp)
+ (insert "\n"))
+ (setq pt (point-marker))
+ (if byte-compile-current-file
+ (insert "\f\nCompiling "
+ (if (stringp byte-compile-current-file)
+ (concat "file " byte-compile-current-file)
+ (concat "buffer " (buffer-name byte-compile-current-file)))
+ " at " (current-time-string) "\n")
+ (insert "\f\nCompiling no file at " (current-time-string) "\n"))
+ (when dir
+ (setq default-directory dir)
+ (unless was-same
+ (insert (format "Entering directory `%s'\n" default-directory))))
+ (setq byte-compile-last-logged-file byte-compile-current-file
+ byte-compile-last-warned-form nil)
+ ;; Do this after setting default-directory.
+ (unless (eq major-mode 'compilation-mode)
+ (compilation-mode))
+ pt))))
+
+;; Log a message STRING in *Compile-Log*.
+;; Also log the current function and file if not already done.
+(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 " ")))
+ (display-warning 'bytecomp string level "*Compile-Log*")))
(defun byte-compile-warn (format &rest args)
+ "Issue a byte compiler warning; use (format FORMAT ARGS...) for message."
(setq format (apply 'format format args))
(if byte-compile-error-on-warn
(error "%s" format) ; byte-compile-file catches and logs it
- (byte-compile-log-1 (concat "warning: " format) t)
- ;; It is useless to flash warnings too fast to be read.
- ;; Besides, they will all be shown at the end.
- ;; (or noninteractive ; already written on stdout.
- ;; (message "Warning: %s" format))
- ))
+ (byte-compile-log-warning format t :warning)))
-;;; This function should be used to report errors that have halted
-;;; compilation of the current file.
(defun byte-compile-report-error (error-info)
+ "Report Lisp error in compilation. ERROR-INFO is the error data."
(setq byte-compiler-error-flag t)
- (byte-compile-log-1
- (concat "error: "
- (format (if (cdr error-info) "%s (%s)" "%s")
- (downcase (get (car error-info) 'error-message))
- (prin1-to-string (cdr error-info))))))
+ (byte-compile-log-warning
+ (error-message-string error-info)
+ nil :error))
;;; Used by make-obsolete.
(defun byte-compile-obsolete (form)
(if (< ncall (car sig))
"requires"
"accepts only")
- (byte-compile-arglist-signature-string sig)))
- (or (and (fboundp (car form)) ; might be a subr or autoload.
- (not (get (car form) 'byte-compile-noruntime)))
- (eq (car form) byte-compile-current-form) ; ## this doesn't work
- ; with recursion.
- ;; It's a currently-undefined function.
- ;; Remember number of args in call.
- (let ((cons (assq (car form) byte-compile-unresolved-functions))
- (n (length (cdr form))))
- (if cons
- (or (memq n (cdr cons))
- (setcdr cons (cons n (cdr cons))))
- (setq byte-compile-unresolved-functions
- (cons (list (car form) n)
- byte-compile-unresolved-functions))))))))
+ (byte-compile-arglist-signature-string sig))))
+ (byte-compile-format-warn form)
+ ;; Check to see if the function will be available at runtime
+ ;; and/or remember its arity if it's unknown.
+ (or (and (or sig (fboundp (car form))) ; might be a subr or autoload.
+ (not (memq (car form) byte-compile-noruntime-functions)))
+ (eq (car form) byte-compile-current-form) ; ## this doesn't work
+ ; with recursion.
+ ;; It's a currently-undefined function.
+ ;; Remember number of args in call.
+ (let ((cons (assq (car form) byte-compile-unresolved-functions))
+ (n (length (cdr form))))
+ (if cons
+ (or (memq n (cdr cons))
+ (setcdr cons (cons n (cdr cons))))
+ (setq byte-compile-unresolved-functions
+ (cons (list (car form) n)
+ byte-compile-unresolved-functions)))))))
+
+(defun byte-compile-format-warn (form)
+ "Warn if FORM is `format'-like with inconsistent args.
+Applies if head of FORM is a symbol with non-nil property
+`byte-compile-format-like' and first arg is a constant string.
+Then check the number of format fields matches the number of
+extra args."
+ (when (and (symbolp (car form))
+ (stringp (nth 1 form))
+ (get (car form) 'byte-compile-format-like))
+ (let ((nfields (with-temp-buffer
+ (insert (nth 1 form))
+ (goto-char 1)
+ (let ((n 0))
+ (while (re-search-forward "%." nil t)
+ (unless (eq ?% (char-after (1+ (match-beginning 0))))
+ (setq n (1+ n))))
+ n)))
+ (nargs (- (length form) 2)))
+ (unless (= nargs nfields)
+ (byte-compile-warn
+ "`%s' called with %d args to fill %d format field(s)" (car form)
+ nargs nfields)))))
+
+(dolist (elt '(format message error))
+ (put elt 'byte-compile-format-like t))
;; Warn if the function or macro is being redefined with a different
;; number of arguments.
(delq calls byte-compile-unresolved-functions)))))
)))
+(defvar byte-compile-cl-functions nil
+ "List of functions defined in CL.")
+
+(defun byte-compile-find-cl-functions ()
+ (unless byte-compile-cl-functions
+ (dolist (elt load-history)
+ (when (and (stringp (car elt))
+ (string-match "^cl\\>" (car elt)))
+ (setq byte-compile-cl-functions
+ (append byte-compile-cl-functions
+ (cdr elt)))))
+ (let ((tail byte-compile-cl-functions))
+ (while tail
+ (if (and (consp (car tail))
+ (eq (car (car tail)) 'autoload))
+ (setcar tail (cdr (car tail))))
+ (setq tail (cdr tail))))))
+
+(defun byte-compile-cl-warn (form)
+ "Warn if FORM is a call of a function from the CL package."
+ (let ((func (car-safe form)))
+ (if (and byte-compile-cl-functions
+ (memq func byte-compile-cl-functions)
+ ;; Aliases which won't have been expanded at this point.
+ ;; These aren't all aliases of subrs, so not trivial to
+ ;; avoid hardwiring the list.
+ (not (memq func
+ '(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.
+ 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
+ cl-compiling-file)))
+ ;; Avoid warnings for things which are safe because they
+ ;; have suitable compiler macros, but those aren't
+ ;; expanded at this stage. There should probably be more
+ ;; here than caaar and friends.
+ (not (and (eq (get func 'byte-compile)
+ 'cl-byte-compile-compiler-macro)
+ (string-match "\\`c[ad]+r\\'" (symbol-name func)))))
+ (byte-compile-warn "Function `%s' from cl package called at runtime"
+ func)))
+ form)
+
(defun byte-compile-print-syms (str1 strn syms)
(when syms
(byte-compile-set-symbol-position (car syms) t))
nil)
\f
-(defsubst byte-compile-const-symbol-p (symbol)
+(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)))
+ (keywordp symbol)
+ (if any-value (memq symbol byte-compile-const-variables))))
(defmacro byte-compile-constp (form)
"Return non-nil if FORM is a constant."
(copy-alist byte-compile-initial-macro-environment))
(byte-compile-function-environment nil)
(byte-compile-bound-variables nil)
+ (byte-compile-const-variables nil)
(byte-compile-free-references nil)
(byte-compile-free-assignments nil)
;;
)
body)))
-(defvar byte-compile-warnings-point-max nil)
(defmacro displaying-byte-compile-warnings (&rest body)
- `(let ((byte-compile-warnings-point-max byte-compile-warnings-point-max))
- ;; Log the file name.
- (byte-compile-log-file)
- ;; Record how much is logged now.
- ;; We will display the log buffer if anything more is logged
- ;; before the end of BODY.
- (unless byte-compile-warnings-point-max
- (save-excursion
- (byte-goto-log-buffer)
- (setq byte-compile-warnings-point-max (point-max))))
- (unwind-protect
- (let ((--displaying-byte-compile-warnings-fn (lambda ()
- ,@body)))
+ `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body))
+ (warning-series-started
+ (and (markerp warning-series)
+ (eq (marker-buffer warning-series)
+ (get-buffer "*Compile-Log*")))))
+ (byte-compile-find-cl-functions)
+ (if (or (eq warning-series 'byte-compile-warning-series)
+ warning-series-started)
+ ;; warning-series does come from compilation,
+ ;; so don't bind it, but maybe do set it.
+ (let (tem)
+ ;; Log the file name. Record position of that text.
+ (setq tem (byte-compile-log-file))
+ (unless warning-series-started
+ (setq warning-series (or tem 'byte-compile-warning-series)))
(if byte-compile-debug
(funcall --displaying-byte-compile-warnings-fn)
(condition-case error-info
(funcall --displaying-byte-compile-warnings-fn)
(error (byte-compile-report-error error-info)))))
- (with-current-buffer "*Compile-Log*"
- ;; If there were compilation warnings, display them.
- (unless (= byte-compile-warnings-point-max (point-max))
- (select-window
- (prog1 (selected-window)
- (select-window (display-buffer (current-buffer)))
- (goto-char byte-compile-warnings-point-max)
- (beginning-of-line)
- (forward-line -1)
- (recenter 0))))))))
-
+ ;; warning-series does not come from compilation, so bind it.
+ (let ((warning-series
+ ;; Log the file name. Record position of that text.
+ (or (byte-compile-log-file) 'byte-compile-warning-series)))
+ (if byte-compile-debug
+ (funcall --displaying-byte-compile-warnings-fn)
+ (condition-case error-info
+ (funcall --displaying-byte-compile-warnings-fn)
+ (error (byte-compile-report-error error-info))))))))
\f
;;;###autoload
(defun byte-force-recompile (directory)
nil
(save-some-buffers)
(force-mode-line-update))
- (let ((directories (list (expand-file-name directory)))
- (skip-count 0)
- (fail-count 0)
- (file-count 0)
- (dir-count 0)
- last-dir)
- (displaying-byte-compile-warnings
- (while directories
- (setq directory (car directories))
- (message "Checking %s..." directory)
- (let ((files (directory-files directory))
- source dest)
- (dolist (file files)
- (setq source (expand-file-name file directory))
- (if (and (not (member file '("." ".." "RCS" "CVS")))
- (file-directory-p source)
- (not (file-symlink-p source)))
- ;; This file is a subdirectory. Handle them differently.
- (when (or (null arg)
- (eq 0 arg)
- (y-or-n-p (concat "Check " source "? ")))
- (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)
- (file-readable-p source)
- (not (auto-save-file-name-p source))
- (setq dest (byte-compile-dest-file source))
- (if (file-exists-p dest)
- ;; File was already compiled.
- (or force (file-newer-than-file-p source dest))
- ;; No compiled file exists yet.
- (and arg
- (or (eq 0 arg)
- (y-or-n-p (concat "Compile " source "? "))))))
- (progn (if (and noninteractive (not byte-compile-verbose))
- (message "Compiling %s..." source))
- (let ((res (byte-compile-file source)))
- (cond ((eq res 'no-byte-compile)
- (setq skip-count (1+ skip-count)))
- ((eq res t)
- (setq file-count (1+ file-count)))
- ((eq res nil)
- (setq fail-count (1+ fail-count)))))
- (or noninteractive
- (message "Checking %s..." directory))
- (if (not (eq last-dir directory))
- (setq last-dir directory
- dir-count (1+ dir-count)))
- )))))
- (setq directories (cdr directories))))
- (message "Done (Total of %d file%s compiled%s%s%s)"
- file-count (if (= file-count 1) "" "s")
- (if (> fail-count 0) (format ", %d failed" fail-count) "")
- (if (> skip-count 0) (format ", %d skipped" skip-count) "")
- (if (> dir-count 1) (format " in %d directories" dir-count) ""))))
+ (save-current-buffer
+ (set-buffer (get-buffer-create "*Compile-Log*"))
+ (setq default-directory (expand-file-name directory))
+ ;; compilation-mode copies value of default-directory.
+ (unless (eq major-mode 'compilation-mode)
+ (compilation-mode))
+ (let ((directories (list (expand-file-name directory)))
+ (default-directory default-directory)
+ (skip-count 0)
+ (fail-count 0)
+ (file-count 0)
+ (dir-count 0)
+ last-dir)
+ (displaying-byte-compile-warnings
+ (while directories
+ (setq directory (car directories))
+ (message "Checking %s..." directory)
+ (let ((files (directory-files directory))
+ source dest)
+ (dolist (file files)
+ (setq source (expand-file-name file directory))
+ (if (and (not (member file '("RCS" "CVS")))
+ (not (eq ?\. (aref file 0)))
+ (file-directory-p source)
+ (not (file-symlink-p source)))
+ ;; This file is a subdirectory. Handle them differently.
+ (when (or (null arg)
+ (eq 0 arg)
+ (y-or-n-p (concat "Check " source "? ")))
+ (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)
+ (file-readable-p source)
+ (not (auto-save-file-name-p source))
+ (setq dest (byte-compile-dest-file source))
+ (if (file-exists-p dest)
+ ;; File was already compiled.
+ (or force (file-newer-than-file-p source dest))
+ ;; No compiled file exists yet.
+ (and arg
+ (or (eq 0 arg)
+ (y-or-n-p (concat "Compile " source "? "))))))
+ (progn (if (and noninteractive (not byte-compile-verbose))
+ (message "Compiling %s..." source))
+ (let ((res (byte-compile-file source)))
+ (cond ((eq res 'no-byte-compile)
+ (setq skip-count (1+ skip-count)))
+ ((eq res t)
+ (setq file-count (1+ file-count)))
+ ((eq res nil)
+ (setq fail-count (1+ fail-count)))))
+ (or noninteractive
+ (message "Checking %s..." directory))
+ (if (not (eq last-dir directory))
+ (setq last-dir directory
+ dir-count (1+ dir-count)))
+ )))))
+ (setq directories (cdr directories))))
+ (message "Done (Total of %d file%s compiled%s%s%s)"
+ file-count (if (= file-count 1) "" "s")
+ (if (> fail-count 0) (format ", %d failed" fail-count) "")
+ (if (> skip-count 0) (format ", %d skipped" skip-count) "")
+ (if (> dir-count 1) (format " in %d directories" dir-count) "")))))
(defvar no-byte-compile nil
"Non-nil to prevent byte-compiling of emacs-lisp code.
(y-or-n-p (format "Save buffer %s first? " (buffer-name b))))
(save-excursion (set-buffer b) (save-buffer)))))
+ ;; Force logging of the file name for each file compiled.
+ (setq byte-compile-last-logged-file nil)
(let ((byte-compile-current-file filename)
- (byte-compile-last-logged-file nil)
(set-auto-coding-for-load t)
target-file input-buffer output-buffer
byte-compile-dest-file)
;; unless the file itself forces unibyte with -*-coding: raw-text;-*-
(set-buffer-multibyte t)
(insert-file-contents filename)
- ;; Mimic the way after-insert-file-set-buffer-file-coding-system
- ;; can make the buffer unibyte when visiting this file.
+ ;; Mimic the way after-insert-file-set-coding can make the
+ ;; buffer unibyte when visiting this file.
(when (or (eq last-coding-system-used 'no-conversion)
(eq (coding-system-type last-coding-system-used) 5))
;; For coding systems no-conversion and raw-text...,
;; compile this file.
(if (with-current-buffer input-buffer no-byte-compile)
(progn
- (message "%s not compiled because of `no-byte-compile: %s'"
- (file-relative-name filename)
- (with-current-buffer input-buffer no-byte-compile))
- (if (file-exists-p target-file)
- (condition-case nil (delete-file target-file) (error nil)))
+ ;; (message "%s not compiled because of `no-byte-compile: %s'"
+ ;; (file-relative-name 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)
+ (buffer-local-value 'no-byte-compile input-buffer))
+ (condition-case nil (delete-file target-file) (error nil)))
;; We successfully didn't compile this file.
'no-byte-compile)
(when byte-compile-verbose
;; It is important that input-buffer not be current at this call,
;; so that the value of point set in input-buffer
;; within byte-compile-from-buffer lingers in that buffer.
- (setq output-buffer (byte-compile-from-buffer input-buffer filename))
+ (setq output-buffer
+ (save-current-buffer
+ (byte-compile-from-buffer input-buffer filename)))
(if byte-compiler-error-flag
nil
(when byte-compile-verbose
;; the build tree, without causing problems when emacs-lisp
;; files in the build tree are recompiled).
(delete-file target-file))
- (write-region 1 (point-max) target-file))
+ (write-region (point-min) (point-max) target-file))
;; This is just to give a better error message than write-region
(signal 'file-error
(list "Opening output file"
;;;###autoload
(defun compile-defun (&optional arg)
"Compile and evaluate the current top-level form.
-Print the result in the minibuffer.
+Print the result in the echo area.
With argument, insert value in current buffer after the form."
(interactive "P")
(save-excursion
(byte-compile-last-position byte-compile-read-position)
(byte-compile-last-warned-form 'nothing)
(value (eval
- (let ((read-with-symbol-positions inbuffer)
+ (let ((read-with-symbol-positions (current-buffer))
(read-symbol-positions-list nil))
(displaying-byte-compile-warnings
(byte-compile-sexp (read (current-buffer))))))))
(byte-compile-file-form form)))
;; Compile pending forms at end of file.
(byte-compile-flush-pending)
+ ;; Make warnings about unresolved functions
+ ;; give the end of the file as their position.
+ (setq byte-compile-last-position (point-max))
(byte-compile-warn-about-unresolved-functions)
;; Should we always do this? When calling multiple files, it
;; would be useful to delay this warning until all have
outbuffer))
(defun byte-compile-fix-header (filename inbuffer outbuffer)
- (save-excursion
- (set-buffer outbuffer)
+ (with-current-buffer outbuffer
;; See if the buffer has any multibyte characters.
(when (< (point-max) (position-bytes (point-max)))
(when (byte-compile-version-cond byte-compile-compatibility)
" on "
(current-time-string) "\n;;; from file " filename "\n")
(insert ";;; in Emacs version " emacs-version "\n")
- (insert ";;; with bytecomp version "
- (progn (string-match "[0-9.]+" byte-compile-version)
- (match-string 0 byte-compile-version))
- "\n;;; "
+ (insert ";;; "
(cond
((eq byte-optimize 'source) "with source-level optimization only")
((eq byte-optimize 'byte) "with byte-level optimization only")
(prin1 form outbuffer)
nil)))
+(defvar print-gensym-alist) ;Used before print-circle existed.
+
(defun byte-compile-output-docform (preface name info form specindex quoted)
"Print a form with a doc string. INFO is (prefix doc-index postfix).
If PREFACE and NAME are non-nil, print them too,
(setq position
(byte-compile-output-as-comment
(nth (nth 1 info) form) nil))
- (setq position (position-bytes position))
+ (setq position (- (position-bytes position) (point-min) -1))
;; If the doc string starts with * (a user variable),
;; negate POSITION.
(if (and (stringp (nth (nth 1 info) form))
;; print-gensym-alist not to be cleared
;; between calls to print functions.
(print-gensym '(t))
- ;; print-gensym-alist was used before print-circle existed.
- print-gensym-alist
+ print-gensym-alist ; was used before print-circle existed.
(print-continuous-numbering t)
print-number-table
(index 0))
(while (setq form (cdr form))
(setq index (1+ index))
(insert " ")
- (cond ((and (numberp specindex) (= index specindex))
+ (cond ((and (numberp specindex) (= index specindex)
+ ;; Don't handle the definition dynamically
+ ;; if it refers (or might refer)
+ ;; to objects already output
+ ;; (for instance, gensyms in the arg list).
+ (let (non-nil)
+ (dotimes (i (length print-number-table))
+ (if (aref print-number-table i)
+ (setq non-nil t)))
+ (not non-nil)))
+ ;; Output the byte code and constants specially
+ ;; for lazy dynamic loading.
(let ((position
(byte-compile-output-as-comment
(cons (car form) (nth 1 form))
t)))
- (setq position (position-bytes position))
+ (setq position (- (position-bytes position) (point-min) -1))
(princ (format "(#$ . %d) nil" position) outbuffer)
(setq form (cdr form))
(setq index (1+ index))))
(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst)
(defun byte-compile-file-form-defsubst (form)
- (cond ((assq (nth 1 form) byte-compile-unresolved-functions)
- (setq byte-compile-current-form (nth 1 form))
- (byte-compile-warn "defsubst %s was used before it was defined"
- (nth 1 form))))
+ (when (assq (nth 1 form) byte-compile-unresolved-functions)
+ (setq byte-compile-current-form (nth 1 form))
+ (byte-compile-warn "defsubst %s was used before it was defined"
+ (nth 1 form)))
(byte-compile-file-form
(macroexpand form byte-compile-macro-environment))
;; Return nil so the form is not output twice.
;; Since there is no doc string, we can compile this as a normal form,
;; and not do a file-boundary.
(byte-compile-keep-pending form)
- (if (memq 'free-vars byte-compile-warnings)
- (setq byte-compile-bound-variables
- (cons (nth 1 form) byte-compile-bound-variables)))
+ (when (memq 'free-vars byte-compile-warnings)
+ (push (nth 1 form) byte-compile-bound-variables)
+ (if (eq (car form) 'defconst)
+ (push (nth 1 form) byte-compile-const-variables)))
(cond ((consp (nth 2 form))
(setq form (copy-sequence form))
(setcar (cdr (cdr form))
(put 'custom-declare-variable 'byte-hunk-handler
'byte-compile-file-form-custom-declare-variable)
(defun byte-compile-file-form-custom-declare-variable (form)
- (if (memq 'free-vars byte-compile-warnings)
- (setq byte-compile-bound-variables
- (cons (nth 1 (nth 1 form)) byte-compile-bound-variables)))
+ (when (memq 'free-vars byte-compile-warnings)
+ (push (nth 1 (nth 1 form)) byte-compile-bound-variables))
+ (let ((tail (nthcdr 4 form)))
+ (while tail
+ ;; If there are any (function (lambda ...)) expressions, compile
+ ;; those functions.
+ (if (and (consp (car tail))
+ (eq (car (car tail)) 'function)
+ (consp (nth 1 (car tail))))
+ (setcar tail (byte-compile-lambda (nth 1 (car tail))))
+ ;; Likewise for a bare lambda.
+ (if (and (consp (car tail))
+ (eq (car (car tail)) 'lambda))
+ (setcar tail (byte-compile-lambda (car tail)))))
+ (setq tail (cdr tail))))
form)
(put 'require 'byte-hunk-handler 'byte-compile-file-form-eval-boundary)
(defun byte-compile-file-form-eval-boundary (form)
- (eval form)
+ (let ((old-load-list current-load-list))
+ (eval form)
+ ;; (require 'cl) turns off warnings for cl functions.
+ (let ((tem current-load-list))
+ (while (not (eq tem old-load-list))
+ (when (equal (car tem) '(require . cl))
+ (setq byte-compile-warnings
+ (remq 'cl-functions byte-compile-warnings)))
+ (setq tem (cdr tem)))))
(byte-compile-keep-pending form 'byte-compile-normal-call))
(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
(byte-compile-set-symbol-position (nth 1 form))
(byte-compile-warn "probable `\"' without `\\' in doc string of %s"
(nth 1 form))))
-
+
;; Generate code for declarations in macro definitions.
;; Remove declarations from the body of the macro definition.
(when macrop
(funcall macro-declaration-function
',name ',declaration))
outbuffer)))))
-
+
(let* ((new-one (byte-compile-lambda (cons 'lambda (nthcdr 2 form))))
(code (byte-compile-byte-code-maker new-one)))
(if this-one
(when (symbolp arg)
(byte-compile-set-symbol-position arg))
(cond ((or (not (symbolp arg))
- (keywordp arg)
- (memq arg '(t nil)))
+ (byte-compile-const-symbol-p arg t))
(error "Invalid lambda variable %s" arg))
((eq arg '&rest)
(unless (cdr list)
(if (cdr body)
(setq body (cdr body))))))
(int (assq 'interactive body)))
- (cond (int
- (byte-compile-set-symbol-position 'interactive)
- ;; Skip (interactive) if it is in front (the most usual location).
- (if (eq int (car body))
- (setq body (cdr body)))
- (cond ((consp (cdr int))
- (if (cdr (cdr int))
- (byte-compile-warn "malformed interactive spec: %s"
- (prin1-to-string int)))
- ;; If the interactive spec is a call to `list',
- ;; don't compile it, because `call-interactively'
- ;; looks at the args of `list'.
- (let ((form (nth 1 int)))
- (while (or (eq (car-safe form) 'let)
- (eq (car-safe form) 'let*)
- (eq (car-safe form) 'save-excursion))
- (while (consp (cdr form))
- (setq form (cdr form)))
- (setq form (car form)))
- (or (eq (car-safe form) 'list)
- (setq int (list 'interactive
- (byte-compile-top-level (nth 1 int)))))))
- ((cdr int)
- (byte-compile-warn "malformed interactive spec: %s"
- (prin1-to-string int))))))
+ ;; Process the interactive spec.
+ (when int
+ (byte-compile-set-symbol-position 'interactive)
+ ;; Skip (interactive) if it is in front (the most usual location).
+ (if (eq int (car body))
+ (setq body (cdr body)))
+ (cond ((consp (cdr int))
+ (if (cdr (cdr int))
+ (byte-compile-warn "malformed interactive spec: %s"
+ (prin1-to-string int)))
+ ;; If the interactive spec is a call to `list', don't
+ ;; compile it, because `call-interactively' looks at the
+ ;; args of `list'. Actually, compile it to get warnings,
+ ;; but don't use the result.
+ (let ((form (nth 1 int)))
+ (while (memq (car-safe form) '(let let* progn save-excursion))
+ (while (consp (cdr form))
+ (setq form (cdr form)))
+ (setq form (car form)))
+ (if (eq (car-safe form) 'list)
+ (byte-compile-top-level (nth 1 int))
+ (setq int (list 'interactive
+ (byte-compile-top-level (nth 1 int)))))))
+ ((cdr int)
+ (byte-compile-warn "malformed interactive spec: %s"
+ (prin1-to-string int)))))
+ ;; Process the body.
(let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda)))
+ ;; Build the actual byte-coded function.
(if (and (eq 'byte-code (car-safe compiled))
(not (byte-compile-version-cond
byte-compile-compatibility)))
;; constant was not optimized away because we chose to return it.
(and (not (assq nil byte-compile-constants)) ; Nil is often there.
(let ((tmp (reverse byte-compile-constants)))
- (while (and tmp (not (or (symbolp (car (car tmp)))
- (numberp (car (car tmp))))))
+ (while (and tmp (not (or (symbolp (caar tmp))
+ (numberp (caar tmp)))))
(setq tmp (cdr tmp)))
- (car (car tmp)))))))
+ (caar tmp))))))
(byte-compile-out 'byte-return 0)
(setq byte-compile-output (nreverse byte-compile-output))
(if (memq byte-optimize '(t byte))
(funcall handler form)
(if (memq 'callargs byte-compile-warnings)
(byte-compile-callargs-warn form))
- (byte-compile-normal-call form))))
+ (byte-compile-normal-call form))
+ (if (memq 'cl-functions byte-compile-warnings)
+ (byte-compile-cl-warn form))))
((and (or (byte-code-function-p (car form))
(eq (car-safe (car form)) 'lambda))
;; if the form comes out the same way it went in, that's
(defun byte-compile-variable-ref (base-op var)
(when (symbolp var)
(byte-compile-set-symbol-position var))
- (if (or (not (symbolp var)) (byte-compile-const-symbol-p var))
- (byte-compile-warn (if (eq base-op 'byte-varbind)
- "attempt to let-bind %s %s"
- "variable reference to %s %s")
- (if (symbolp var) "constant" "nonvariable")
- (prin1-to-string var))
+ (if (or (not (symbolp var))
+ (byte-compile-const-symbol-p var (not (eq base-op 'byte-varref))))
+ (byte-compile-warn
+ (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s %s")
+ ((eq base-op 'byte-varset) "variable assignment to %s %s")
+ (t "variable reference to %s %s"))
+ (if (symbolp var) "constant" "nonvariable")
+ (prin1-to-string var))
(if (and (get var 'byte-obsolete-variable)
- (memq 'obsolete byte-compile-warnings))
+ (memq 'obsolete byte-compile-warnings)
+ (not (eq var byte-compile-not-obsolete-var)))
(let* ((ob (get var 'byte-obsolete-variable))
(when (cdr ob)))
(byte-compile-warn "%s is an obsolete variable%s; %s" var
(format "use %s instead." (car ob))))))
(if (memq 'free-vars byte-compile-warnings)
(if (eq base-op 'byte-varbind)
- (setq byte-compile-bound-variables
- (cons var byte-compile-bound-variables))
+ (push var byte-compile-bound-variables)
(or (boundp var)
(memq var byte-compile-bound-variables)
(if (eq base-op 'byte-varset)
(or (memq var byte-compile-free-assignments)
(progn
(byte-compile-warn "assignment to free variable %s" var)
- (setq byte-compile-free-assignments
- (cons var byte-compile-free-assignments))))
+ (push var byte-compile-free-assignments)))
(or (memq var byte-compile-free-references)
(progn
(byte-compile-warn "reference to free variable %s" var)
- (setq byte-compile-free-references
- (cons var byte-compile-free-references)))))))))
+ (push var byte-compile-free-references))))))))
(let ((tmp (assq var byte-compile-variables)))
- (or tmp
- (setq tmp (list var)
- byte-compile-variables (cons tmp byte-compile-variables)))
+ (unless tmp
+ (setq tmp (list var))
+ (push tmp byte-compile-variables))
(byte-compile-out base-op tmp)))
(defmacro byte-compile-get-constant (const)
`(or (if (stringp ,const)
- (assoc ,const byte-compile-constants)
+ (assoc-default ,const byte-compile-constants
+ 'equal-including-properties nil)
(assq ,const byte-compile-constants))
(car (setq byte-compile-constants
(cons (list ,const) byte-compile-constants)))))
;; If function is a symbol, then the variable "byte-SYMBOL" must name
;; the opcode to be used. If function is a list, the first element
;; is the function and the second element is the bytecode-symbol.
+ ;; The second element may be nil, meaning there is no opcode.
;; COMPILE-HANDLER is the function to use to compile this byte-op, or
;; may be the abbreviations 0, 1, 2, 3, 0-1, or 1-2.
;; If it is nil, then the handler is "byte-compile-SYMBOL."
(setq args (cdr args))
(or args (setq args '(0)
opcode (get '+ 'byte-opcode)))
- (while args
- (byte-compile-form (car args))
- (byte-compile-out opcode 0)
- (setq args (cdr args))))
+ (dolist (arg args)
+ (byte-compile-form arg)
+ (byte-compile-out opcode 0)))
(byte-compile-constant (eval form))))
\f
(byte-defop-compiler-1 mapatoms byte-compile-funarg)
(byte-defop-compiler-1 mapconcat byte-compile-funarg)
(byte-defop-compiler-1 mapc byte-compile-funarg)
+(byte-defop-compiler-1 maphash byte-compile-funarg)
+(byte-defop-compiler-1 map-char-table byte-compile-funarg)
(byte-defop-compiler-1 sort byte-compile-funarg-2)
(byte-defop-compiler-1 let)
(byte-defop-compiler-1 let*)
(if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop))
,tag))
+(defmacro byte-compile-maybe-guarded (condition &rest body)
+ "Execute forms in BODY, potentially guarded by CONDITION.
+CONDITION is the test in an `if' form or in a `cond' clause.
+BODY is to compile the first arm of the if or the body of the
+cond clause. If CONDITION is of the form `(foundp 'foo)'
+or `(boundp 'foo)', the relevant warnings from BODY about foo
+being undefined will be suppressed."
+ (declare (indent 1) (debug t))
+ `(let* ((fbound
+ (if (eq 'fboundp (car-safe ,condition))
+ (and (eq 'quote (car-safe (nth 1 ,condition)))
+ ;; Ignore if the symbol is already on the
+ ;; unresolved list.
+ (not (assq (nth 1 (nth 1 ,condition)) ; the relevant symbol
+ byte-compile-unresolved-functions))
+ (nth 1 (nth 1 ,condition)))))
+ (bound (if (or (eq 'boundp (car-safe ,condition))
+ (eq 'default-boundp (car-safe ,condition)))
+ (and (eq 'quote (car-safe (nth 1 ,condition)))
+ (nth 1 (nth 1 ,condition)))))
+ ;; Maybe add to the bound list.
+ (byte-compile-bound-variables
+ (if bound
+ (cons bound byte-compile-bound-variables)
+ byte-compile-bound-variables)))
+ (progn ,@body)
+ ;; Maybe remove the function symbol from the unresolved list.
+ (if fbound
+ (setq byte-compile-unresolved-functions
+ (delq (assq fbound byte-compile-unresolved-functions)
+ byte-compile-unresolved-functions)))))
+
(defun byte-compile-if (form)
(byte-compile-form (car (cdr form)))
- (if (null (nthcdr 3 form))
- ;; No else-forms
- (let ((donetag (byte-compile-make-tag)))
- (byte-compile-goto-if nil for-effect donetag)
- (byte-compile-form (nth 2 form) for-effect)
- (byte-compile-out-tag donetag))
- (let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag)))
- (byte-compile-goto 'byte-goto-if-nil elsetag)
- (byte-compile-form (nth 2 form) for-effect)
- (byte-compile-goto 'byte-goto donetag)
- (byte-compile-out-tag elsetag)
- (byte-compile-body (cdr (cdr (cdr form))) for-effect)
- (byte-compile-out-tag donetag)))
+ ;; Check whether we have `(if (fboundp ...' or `(if (boundp ...'
+ ;; and avoid warnings about the relevent symbols in the consequent.
+ (let ((clause (nth 1 form))
+ (donetag (byte-compile-make-tag)))
+ (if (null (nthcdr 3 form))
+ ;; No else-forms
+ (progn
+ (byte-compile-goto-if nil for-effect donetag)
+ (byte-compile-maybe-guarded clause
+ (byte-compile-form (nth 2 form) for-effect))
+ (byte-compile-out-tag donetag))
+ (let ((elsetag (byte-compile-make-tag)))
+ (byte-compile-goto 'byte-goto-if-nil elsetag)
+ (byte-compile-maybe-guarded clause
+ (byte-compile-form (nth 2 form) for-effect))
+ (byte-compile-goto 'byte-goto donetag)
+ (byte-compile-out-tag elsetag)
+ (byte-compile-body (cdr (cdr (cdr form))) for-effect)
+ (byte-compile-out-tag donetag))))
(setq for-effect nil))
(defun byte-compile-cond (clauses)
(if (null (cdr clause))
;; First clause is a singleton.
(byte-compile-goto-if t for-effect donetag)
- (setq nexttag (byte-compile-make-tag))
- (byte-compile-goto 'byte-goto-if-nil nexttag)
- (byte-compile-body (cdr clause) for-effect)
- (byte-compile-goto 'byte-goto donetag)
- (byte-compile-out-tag nexttag)))))
+ (setq nexttag (byte-compile-make-tag))
+ (byte-compile-goto 'byte-goto-if-nil nexttag)
+ (byte-compile-maybe-guarded (car clause)
+ (byte-compile-body (cdr clause) for-effect))
+ (byte-compile-goto 'byte-goto donetag)
+ (byte-compile-out-tag nexttag)))))
;; Last clause
- (and (cdr clause) (not (eq (car clause) t))
- (progn (byte-compile-form (car clause))
- (byte-compile-goto-if nil for-effect donetag)
- (setq clause (cdr clause))))
- (byte-compile-body-do-effect clause)
+ (let ((guard (car clause)))
+ (and (cdr clause) (not (eq guard t))
+ (progn (byte-compile-form guard)
+ (byte-compile-goto-if nil for-effect donetag)
+ (setq clause (cdr clause))))
+ (byte-compile-maybe-guarded guard
+ (byte-compile-body-do-effect clause)))
(byte-compile-out-tag donetag)))
(defun byte-compile-and (form)
(defun byte-compile-let (form)
;; First compute the binding values in the old scope.
(let ((varlist (car (cdr form))))
- (while varlist
- (if (consp (car varlist))
- (byte-compile-form (car (cdr (car varlist))))
- (byte-compile-push-constant nil))
- (setq varlist (cdr varlist))))
+ (dolist (var varlist)
+ (if (consp var)
+ (byte-compile-form (car (cdr var)))
+ (byte-compile-push-constant nil))))
(let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
(varlist (reverse (car (cdr form)))))
- (while varlist
- (byte-compile-variable-ref 'byte-varbind (if (consp (car varlist))
- (car (car varlist))
- (car varlist)))
- (setq varlist (cdr varlist)))
+ (dolist (var varlist)
+ (byte-compile-variable-ref 'byte-varbind (if (consp var) (car var) var)))
(byte-compile-body-do-effect (cdr (cdr form)))
(byte-compile-out 'byte-unbind (length (car (cdr form))))))
(defun byte-compile-let* (form)
(let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
(varlist (copy-sequence (car (cdr form)))))
- (while varlist
- (if (atom (car varlist))
+ (dolist (var varlist)
+ (if (atom var)
(byte-compile-push-constant nil)
- (byte-compile-form (car (cdr (car varlist))))
- (setcar varlist (car (car varlist))))
- (byte-compile-variable-ref 'byte-varbind (car varlist))
- (setq varlist (cdr varlist)))
+ (byte-compile-form (car (cdr var)))
+ (setq var (car var)))
+ (byte-compile-variable-ref 'byte-varbind var))
(byte-compile-body-do-effect (cdr (cdr form)))
(byte-compile-out 'byte-unbind (length (car (cdr form))))))
(defun byte-compile-track-mouse (form)
(byte-compile-form
- (list
- 'funcall
- (list 'quote
- (list 'lambda nil
- (cons 'track-mouse
- (byte-compile-top-level-body (cdr form))))))))
+ `(funcall '(lambda nil
+ (track-mouse ,@(byte-compile-top-level-body (cdr form)))))))
(defun byte-compile-condition-case (form)
(let* ((var (nth 1 form))
(byte-compile-out 'byte-temp-output-buffer-setup 0)
(byte-compile-body (cdr (cdr form)))
(byte-compile-out 'byte-temp-output-buffer-show 0))
-
\f
;;; top-level forms elsewhere
(byte-compile-set-symbol-position (car form))
(byte-compile-set-symbol-position 'defun)
(error "defun name must be a symbol, not %s" (car form)))
- (byte-compile-two-args ; Use this to avoid byte-compile-fset's warning.
- (list 'fset (list 'quote (nth 1 form))
- (byte-compile-byte-code-maker
- (byte-compile-lambda (cons 'lambda (cdr (cdr form)))))))
- (byte-compile-discard)
+ (if (byte-compile-version-cond byte-compile-compatibility)
+ (progn
+ (byte-compile-two-args ; Use this to avoid byte-compile-fset's warning.
+ (list 'fset
+ (list 'quote (nth 1 form))
+ (byte-compile-byte-code-maker
+ (byte-compile-lambda (cons 'lambda (cdr (cdr form)))))))
+ (byte-compile-discard))
+ ;; We prefer to generate a defalias form so it will record the function
+ ;; definition just like interpreting a defun.
+ (byte-compile-form
+ (list 'defalias
+ (list 'quote (nth 1 form))
+ (byte-compile-byte-code-maker
+ (byte-compile-lambda (cons 'lambda (cdr (cdr form))))))
+ t))
(byte-compile-constant (nth 1 form)))
(defun byte-compile-defmacro (form)
(value (nth 2 form))
(string (nth 3 form)))
(byte-compile-set-symbol-position fun)
- (when (> (length form) 4)
- (byte-compile-warn
- "%s %s called with %d arguments, but accepts only %s"
- fun var (length (cdr form)) 3))
+ (when (or (> (length form) 4)
+ (and (eq fun 'defconst) (null (cddr form))))
+ (let ((ncall (length (cdr form))))
+ (byte-compile-warn
+ "%s called with %d argument%s, but %s %s"
+ fun ncall
+ (if (= 1 ncall) "" "s")
+ (if (< ncall 2) "requires" "accepts only")
+ "2-3")))
(when (memq 'free-vars byte-compile-warnings)
- (setq byte-compile-bound-variables
- (cons var byte-compile-bound-variables)))
+ (push var byte-compile-bound-variables)
+ (if (eq fun 'defconst)
+ (push var byte-compile-const-variables)))
(byte-compile-body-do-effect
(list
;; Put the defined variable in this library's load-history entry
fun var string))
`(put ',var 'variable-documentation ,string))
(if (cddr form) ; `value' provided
- (if (eq fun 'defconst)
- ;; `defconst' sets `var' unconditionally.
- (let ((tmp (make-symbol "defconst-tmp-var")))
- `(let ((,tmp ,value))
- (eval '(defconst ,var ,tmp))))
- ;; `defvar' sets `var' only when unbound.
- `(if (not (boundp ',var)) (setq ,var ,value))))
+ (let ((byte-compile-not-obsolete-var var))
+ (if (eq fun 'defconst)
+ ;; `defconst' sets `var' unconditionally.
+ (let ((tmp (make-symbol "defconst-tmp-var")))
+ `(funcall '(lambda (,tmp) (defconst ,var ,tmp))
+ ,value))
+ ;; `defvar' sets `var' only when unbound.
+ `(if (not (default-boundp ',var)) (setq-default ,var ,value))))
+ (when (eq fun 'defconst)
+ ;; This will signal an appropriate error at runtime.
+ `(eval ',form)))
`',var))))
(defun byte-compile-autoload (form)
(consp (cdr (nth 2 form)))
(symbolp (nth 1 (nth 2 form))))
(progn
- (byte-compile-defalias-warn (nth 1 (nth 1 form))
- (nth 1 (nth 2 form)))
+ (byte-compile-defalias-warn (nth 1 (nth 1 form)))
(setq byte-compile-function-environment
(cons (cons (nth 1 (nth 1 form))
(nth 1 (nth 2 form)))
;; Turn off warnings about prior calls to the function being defalias'd.
;; This could be smarter and compare those calls with
;; the function it is being aliased to.
-(defun byte-compile-defalias-warn (new alias)
+(defun byte-compile-defalias-warn (new)
(let ((calls (assq new byte-compile-unresolved-functions)))
(if calls
(setq byte-compile-unresolved-functions
(delq calls byte-compile-unresolved-functions)))))
+
+(byte-defop-compiler-1 with-no-warnings byte-compile-no-warnings)
+(defun byte-compile-no-warnings (form)
+ (let (byte-compile-warnings)
+ (byte-compile-form (cadr form))))
\f
;;; tags
(setcdr (cdr tag) byte-compile-depth)))
(defun byte-compile-goto (opcode tag)
- (setq byte-compile-output (cons (cons opcode tag) byte-compile-output))
+ (push (cons opcode tag) byte-compile-output)
(setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops)
(1- byte-compile-depth)
byte-compile-depth))
(1- byte-compile-depth))))
(defun byte-compile-out (opcode offset)
- (setq byte-compile-output (cons (cons opcode offset) byte-compile-output))
+ (push (cons opcode offset) byte-compile-output)
(cond ((eq opcode 'byte-call)
(setq byte-compile-depth (- byte-compile-depth offset)))
((eq opcode 'byte-return)
;;;###autoload
(defun batch-byte-recompile-directory ()
- "Runs `byte-recompile-directory' on the dirs remaining on the command line.
+ "Run `byte-recompile-directory' on the dirs remaining on the command line.
Must be used only with `-batch', and kills Emacs on completion.
For example, invoke `emacs -batch -f batch-byte-recompile-directory .'."
;; command-line-args-left is what is left of the command line (startup.el)
(kill-emacs 0))
-(make-obsolete 'dot 'point "before 19.15")
-(make-obsolete 'dot-max 'point-max "before 19.15")
-(make-obsolete 'dot-min 'point-min "before 19.15")
-(make-obsolete 'dot-marker 'point-marker "before 19.15")
-
-(make-obsolete 'buffer-flush-undo 'buffer-disable-undo "before 19.15")
-(make-obsolete 'baud-rate "use the baud-rate variable instead" "before 19.15")
-(make-obsolete 'compiled-function-p 'byte-code-function-p "before 19.15")
-(make-obsolete 'define-function 'defalias "20.1")
(make-obsolete-variable 'auto-fill-hook 'auto-fill-function "before 19.15")
(make-obsolete-variable 'blink-paren-hook 'blink-paren-function "before 19.15")
(make-obsolete-variable 'lisp-indent-hook 'lisp-indent-function "before 19.15")
(make-obsolete-variable 'inhibit-local-variables
"use enable-local-variables (with the reversed sense)."
"before 19.15")
-(make-obsolete-variable 'unread-command-char
- "use unread-command-events instead. That variable is a list of events to reread, so it now uses nil to mean `no event', instead of -1."
- "before 19.15")
(make-obsolete-variable 'unread-command-event
"use unread-command-events; which is a list of events rather than a single event."
"before 19.15")
(make-obsolete-variable 'suspend-hooks 'suspend-hook "before 19.15")
(make-obsolete-variable 'comment-indent-hook 'comment-indent-function "before 19.15")
-(make-obsolete-variable 'meta-flag "Use the set-input-mode function instead." "before 19.34")
-(make-obsolete-variable 'executing-macro 'executing-kbd-macro "before 19.34")
+(make-obsolete-variable 'meta-flag "use the set-input-mode function instead." "before 19.34")
(make-obsolete-variable 'before-change-function
"use before-change-functions; which is a list of functions rather than a single function."
"before 19.34")
"use after-change-functions; which is a list of functions rather than a single function."
"before 19.34")
(make-obsolete-variable 'font-lock-doc-string-face 'font-lock-string-face "before 19.34")
-(make-obsolete-variable 'post-command-idle-hook
- "use timers instead, with `run-with-idle-timer'." "before 19.34")
-(make-obsolete-variable 'post-command-idle-delay
- "use timers instead, with `run-with-idle-timer'." "before 19.34")
(provide 'byte-compile)
(provide 'bytecomp)
\f
;;; report metering (see the hacks in bytecode.c)
+(defvar byte-code-meter)
(defun byte-compile-report-ops ()
- (defvar byte-code-meter)
(with-output-to-temp-buffer "*Meter*"
(set-buffer "*Meter*")
(let ((i 0) n op off)
(run-hooks 'bytecomp-load-hook)
+;;; arch-tag: 9c97b0f0-8745-4571-bfc3-8dceb677292a
;;; bytecomp.el ends here