summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp/bytecomp.el
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp/bytecomp.el')
-rw-r--r--lisp/emacs-lisp/bytecomp.el683
1 files changed, 388 insertions, 295 deletions
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 4bd94a6bc56..5fafac0540f 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -98,9 +98,12 @@
;; `obsolete' (obsolete variables and functions)
;; `noruntime' (calls to functions only defined
;; within `eval-when-compile')
-;; `cl-warnings' (calls to CL functions)
+;; `cl-functions' (calls to CL functions)
;; `interactive-only' (calls to commands that are
;; not good to call from Lisp)
+;; `make-local' (dubious calls to
+;; `make-variable-buffer-local')
+;; `mapcar' (mapcar called for effect)
;; byte-compile-compatibility Whether the compiler should
;; generate .elc files which can be loaded into
;; generic emacs 18.
@@ -338,7 +341,8 @@ If it is 'byte, then only byte-level optimizations will be logged."
(defconst byte-compile-warning-types
'(redefine callargs free-vars unresolved
- obsolete noruntime cl-functions interactive-only)
+ obsolete noruntime cl-functions interactive-only
+ make-local mapcar)
"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).
@@ -356,33 +360,82 @@ Elements of the list may be:
cl-functions calls to runtime functions from the CL package (as
distinguished from macros and aliases).
interactive-only
- commands that normally shouldn't be called from Lisp code."
+ commands that normally shouldn't be called from Lisp code.
+ make-local calls to make-variable-buffer-local that may be incorrect.
+ mapcar mapcar called for effect.
+
+If the list begins with `not', then the remaining elements specify warnings to
+suppress. For example, (not mapcar) will suppress warnings about mapcar."
:group 'bytecomp
:type `(choice (const :tag "All" t)
(set :menu-tag "Some"
(const free-vars) (const unresolved)
(const callargs) (const redefine)
(const obsolete) (const noruntime)
- (const cl-functions) (const interactive-only))))
+ (const cl-functions) (const interactive-only)
+ (const make-local) (const mapcar))))
;;;###autoload(put 'byte-compile-warnings 'safe-local-variable 'byte-compile-warnings-safe-p)
;;;###autoload
(defun byte-compile-warnings-safe-p (x)
(or (booleanp x)
(and (listp x)
+ (if (eq (car x) 'not) (setq x (cdr x))
+ t)
(equal (mapcar
(lambda (e)
(when (memq e '(free-vars unresolved
callargs redefine
obsolete noruntime
- cl-functions interactive-only))
+ cl-functions interactive-only
+ make-local mapcar))
e))
x)
x))))
+(defun byte-compile-warning-enabled-p (warning)
+ "Return non-nil if WARNING is enabled, according to `byte-compile-warnings'."
+ (or (eq byte-compile-warnings t)
+ (if (eq (car byte-compile-warnings) 'not)
+ (not (memq warning byte-compile-warnings))
+ (memq warning byte-compile-warnings))))
+
+;;;###autoload
+(defun byte-compile-disable-warning (warning)
+ "Change `byte-compile-warnings' to disable WARNING.
+If `byte-compile-warnings' is t, set it to `(not WARNING)'.
+Otherwise, if the first element is `not', add WARNING, else remove it.
+Normally you should let-bind `byte-compile-warnings' before calling this,
+else the global value will be modified."
+ (setq byte-compile-warnings
+ (cond ((eq byte-compile-warnings t)
+ (list 'not warning))
+ ((eq (car byte-compile-warnings) 'not)
+ (if (memq warning byte-compile-warnings)
+ byte-compile-warnings
+ (append byte-compile-warnings (list warning))))
+ (t
+ (delq warning byte-compile-warnings)))))
+
+;;;###autoload
+(defun byte-compile-enable-warning (warning)
+ "Change `byte-compile-warnings' to enable WARNING.
+If `byte-compile-warnings' is `t', do nothing. Otherwise, if the
+first element is `not', remove WARNING, else add it.
+Normally you should let-bind `byte-compile-warnings' before calling this,
+else the global value will be modified."
+ (or (eq byte-compile-warnings t)
+ (setq byte-compile-warnings
+ (cond ((eq (car byte-compile-warnings) 'not)
+ (delq warning byte-compile-warnings))
+ ((memq warning byte-compile-warnings)
+ byte-compile-warnings)
+ (t
+ (append byte-compile-warnings (list warning)))))))
+
(defvar byte-compile-interactive-only-functions
'(beginning-of-buffer end-of-buffer replace-string replace-regexp
- insert-file insert-buffer insert-file-literally)
+ insert-file insert-buffer insert-file-literally previous-line next-line)
"List of commands that are not meant to be called from Lisp.")
(defvar byte-compile-not-obsolete-var nil
@@ -822,7 +875,7 @@ 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)
- (when (memq 'noruntime byte-compile-warnings)
+ (when (byte-compile-warning-enabled-p 'noruntime)
(let ((hist-new load-history)
(hist-nil-new current-load-list))
;; Go through load-history, look for newly loaded files
@@ -850,14 +903,12 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(push s byte-compile-noruntime-functions))
(when (and (consp s) (eq t (car s)))
(push (cdr s) old-autoloads)))))))
- (when (memq 'cl-functions byte-compile-warnings)
- (let ((hist-new load-history)
- (hist-nil-new current-load-list))
+ (when (byte-compile-warning-enabled-p 'cl-functions)
+ (let ((hist-new load-history))
;; 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))
- old-autoloads)
+ (let ((xs (pop hist-new)))
;; Make sure the file was not already loaded before.
(when (and (equal (car xs) "cl") (not (assoc (car xs) hist-orig)))
(byte-compile-find-cl-functions)))))))))
@@ -870,8 +921,7 @@ Each function's symbol gets added to `byte-compile-noruntime-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)))
+ (byte-compile-disable-warning 'cl-functions))
(setq tem (cdr tem)))))))
;;; byte compiler messages
@@ -1003,6 +1053,9 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(defun byte-compile-warning-series (&rest ignore)
nil)
+;; (compile-mode) will cause this to be loaded.
+(declare-function compilation-forget-errors "compile" ())
+
;; 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.
@@ -1036,8 +1089,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(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))
+ (unless (derived-mode-p 'compilation-mode) (compilation-mode))
(compilation-forget-errors)
pt))))
@@ -1070,7 +1122,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(handler (nth 1 new))
(when (nth 2 new)))
(byte-compile-set-symbol-position (car form))
- (if (memq 'obsolete byte-compile-warnings)
+ (if (byte-compile-warning-enabled-p 'obsolete)
(byte-compile-warn "`%s' is an obsolete function%s; %s" (car form)
(if when (concat " (as of Emacs " when ")") "")
(if (stringp (car new))
@@ -1209,7 +1261,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(byte-compile-fdefinition (car form) t)))
(sig (if (and def (not (eq def t)))
(byte-compile-arglist-signature
- (if (eq 'lambda (car-safe def))
+ (if (memq (car-safe def) '(declared lambda))
(nth 1 def)
(if (byte-code-function-p def)
(aref def 0)
@@ -1262,7 +1314,7 @@ extra args."
(get (car form) 'byte-compile-format-like))
(let ((nfields (with-temp-buffer
(insert (nth 1 form))
- (goto-char 1)
+ (goto-char (point-min))
(let ((n 0))
(while (re-search-forward "%." nil t)
(unless (eq ?% (char-after (1+ (match-beginning 0))))
@@ -1280,19 +1332,19 @@ extra args."
;; Warn if a custom definition fails to specify :group.
(defun byte-compile-nogroup-warn (form)
(let ((keyword-args (cdr (cdr (cdr (cdr form)))))
- (name (cadr form)))
+ (name (cadr form)))
(or (not (eq (car-safe name) 'quote))
- (and (eq (car form) 'custom-declare-group)
- (equal name ''emacs))
- (plist-get keyword-args :group)
- (not (and (consp name) (eq (car name) 'quote)))
- (byte-compile-warn
- "%s for `%s' fails to specify containing group"
- (cdr (assq (car form)
- '((custom-declare-group . defgroup)
- (custom-declare-face . defface)
- (custom-declare-variable . defcustom))))
- (cadr name)))))
+ (and (eq (car form) 'custom-declare-group)
+ (equal name ''emacs))
+ (plist-get keyword-args :group)
+ (not (and (consp name) (eq (car name) 'quote)))
+ (byte-compile-warn
+ "%s for `%s' fails to specify containing group"
+ (cdr (assq (car form)
+ '((custom-declare-group . defgroup)
+ (custom-declare-face . defface)
+ (custom-declare-variable . defcustom))))
+ (cadr name)))))
;; Warn if the function or macro is being redefined with a different
;; number of arguments.
@@ -1345,7 +1397,8 @@ extra args."
(unless byte-compile-cl-functions
(dolist (elt load-history)
(when (and (stringp (car elt))
- (string-match "^cl\\>" (car elt)))
+ (string-match
+ "^cl\\>" (file-name-nondirectory (car elt))))
(setq byte-compile-cl-functions
(append byte-compile-cl-functions
(cdr elt)))))
@@ -1415,7 +1468,7 @@ extra args."
;; defined, issue a warning enumerating them.
;; `unresolved' in the list `byte-compile-warnings' disables this.
(defun byte-compile-warn-about-unresolved-functions ()
- (when (memq 'unresolved byte-compile-warnings)
+ (when (byte-compile-warning-enabled-p 'unresolved)
(let ((byte-compile-current-form :end)
(noruntime nil)
(unresolved nil))
@@ -1478,9 +1531,7 @@ symbol itself."
byte-compile-dynamic-docstrings)
;; (byte-compile-generate-emacs19-bytecodes
;; byte-compile-generate-emacs19-bytecodes)
- (byte-compile-warnings (if (eq byte-compile-warnings t)
- byte-compile-warning-types
- byte-compile-warnings))
+ (byte-compile-warnings byte-compile-warnings)
)
body)))
@@ -1823,9 +1874,7 @@ With argument, insert value in current buffer after the form."
(read-with-symbol-positions inbuffer)
(read-symbol-positions-list nil)
;; #### This is bound in b-c-close-variables.
- ;; (byte-compile-warnings (if (eq byte-compile-warnings t)
- ;; byte-compile-warning-types
- ;; byte-compile-warnings))
+ ;; (byte-compile-warnings byte-compile-warnings)
)
(byte-compile-close-variables
(with-current-buffer
@@ -1844,7 +1893,7 @@ With argument, insert value in current buffer after the form."
(displaying-byte-compile-warnings
(and filename (byte-compile-insert-header filename inbuffer outbuffer))
(with-current-buffer inbuffer
- (goto-char 1)
+ (goto-char (point-min))
;; Should we always do this? When calling multiple files, it
;; would be useful to delay this warning until all have been
;; compiled. A: Yes! b-c-u-f might contain dross from a
@@ -1915,88 +1964,88 @@ and will be removed soon. See (elisp)Backquote in the manual."))
(delete-char delta)))))
(defun byte-compile-insert-header (filename inbuffer outbuffer)
- (set-buffer inbuffer)
- (let ((dynamic-docstrings byte-compile-dynamic-docstrings)
- (dynamic byte-compile-dynamic))
- (set-buffer outbuffer)
- (goto-char 1)
- ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After
- ;; that is the file-format version number (18, 19 or 20) as a
- ;; byte, followed by some nulls. The primary motivation for doing
- ;; this is to get some binary characters up in the first line of
- ;; the file so that `diff' will simply say "Binary files differ"
- ;; instead of actually doing a diff of two .elc files. An extra
- ;; benefit is that you can add this to /etc/magic:
-
- ;; 0 string ;ELC GNU Emacs Lisp compiled file,
- ;; >4 byte x version %d
-
- (insert
- ";ELC"
- (if (byte-compile-version-cond byte-compile-compatibility) 18 20)
- "\000\000\000\n"
- )
- (insert ";;; Compiled by "
- (or (and (boundp 'user-mail-address) user-mail-address)
- (concat (user-login-name) "@" (system-name)))
- " on "
- (current-time-string) "\n;;; from file " filename "\n")
- (insert ";;; in Emacs version " emacs-version "\n")
- (insert ";;; "
- (cond
- ((eq byte-optimize 'source) "with source-level optimization only")
- ((eq byte-optimize 'byte) "with byte-level optimization only")
- (byte-optimize "with all optimizations")
- (t "without optimization"))
- (if (byte-compile-version-cond byte-compile-compatibility)
- "; compiled with Emacs 18 compatibility.\n"
- ".\n"))
- (if dynamic
- (insert ";;; Function definitions are lazy-loaded.\n"))
- (if (not (byte-compile-version-cond byte-compile-compatibility))
- (let (intro-string minimum-version)
- ;; Figure out which Emacs version to require,
- ;; and what comment to use to explain why.
- ;; Note that this fails to take account of whether
- ;; the buffer contains multibyte characters. We may have to
- ;; compensate at the end in byte-compile-fix-header.
- (if dynamic-docstrings
+ (with-current-buffer inbuffer
+ (let ((dynamic-docstrings byte-compile-dynamic-docstrings)
+ (dynamic byte-compile-dynamic))
+ (set-buffer outbuffer)
+ (goto-char (point-min))
+ ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After
+ ;; that is the file-format version number (18, 19 or 20) as a
+ ;; byte, followed by some nulls. The primary motivation for doing
+ ;; this is to get some binary characters up in the first line of
+ ;; the file so that `diff' will simply say "Binary files differ"
+ ;; instead of actually doing a diff of two .elc files. An extra
+ ;; benefit is that you can add this to /etc/magic:
+
+ ;; 0 string ;ELC GNU Emacs Lisp compiled file,
+ ;; >4 byte x version %d
+
+ (insert
+ ";ELC"
+ (if (byte-compile-version-cond byte-compile-compatibility) 18 20)
+ "\000\000\000\n"
+ )
+ (insert ";;; Compiled by "
+ (or (and (boundp 'user-mail-address) user-mail-address)
+ (concat (user-login-name) "@" (system-name)))
+ " on "
+ (current-time-string) "\n;;; from file " filename "\n")
+ (insert ";;; in Emacs version " emacs-version "\n")
+ (insert ";;; "
+ (cond
+ ((eq byte-optimize 'source) "with source-level optimization only")
+ ((eq byte-optimize 'byte) "with byte-level optimization only")
+ (byte-optimize "with all optimizations")
+ (t "without optimization"))
+ (if (byte-compile-version-cond byte-compile-compatibility)
+ "; compiled with Emacs 18 compatibility.\n"
+ ".\n"))
+ (if dynamic
+ (insert ";;; Function definitions are lazy-loaded.\n"))
+ (if (not (byte-compile-version-cond byte-compile-compatibility))
+ (let (intro-string minimum-version)
+ ;; Figure out which Emacs version to require,
+ ;; and what comment to use to explain why.
+ ;; Note that this fails to take account of whether
+ ;; the buffer contains multibyte characters. We may have to
+ ;; compensate at the end in byte-compile-fix-header.
+ (if dynamic-docstrings
+ (setq intro-string
+ ";;; This file uses dynamic docstrings, first added in Emacs 19.29.\n"
+ minimum-version "19.29")
(setq intro-string
- ";;; This file uses dynamic docstrings, first added in Emacs 19.29.\n"
- minimum-version "19.29")
- (setq intro-string
- ";;; This file uses opcodes which do not exist in Emacs 18.\n"
- minimum-version "19"))
- ;; Now insert the comment and the error check.
- (insert
- "\n"
- intro-string
- ;; Have to check if emacs-version is bound so that this works
- ;; in files loaded early in loadup.el.
- "(if (and (boundp 'emacs-version)\n"
- ;; If there is a name at the end of emacs-version,
- ;; don't try to check the version number.
- "\t (< (aref emacs-version (1- (length emacs-version))) ?A)\n"
- "\t (or (and (boundp 'epoch::version) epoch::version)\n"
- (format "\t (string-lessp emacs-version \"%s\")))\n"
- minimum-version)
- " (error \"`"
- ;; prin1-to-string is used to quote backslashes.
- (substring (prin1-to-string (file-name-nondirectory filename))
- 1 -1)
- (format "' was compiled for Emacs %s or later\"))\n\n"
- minimum-version)
- ;; Insert semicolons as ballast, so that byte-compile-fix-header
- ;; can delete them so as to keep the buffer positions
- ;; constant for the actual compiled code.
- ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n"))
- ;; Here if we want Emacs 18 compatibility.
- (when dynamic-docstrings
- (error "Version-18 compatibility doesn't support dynamic doc strings"))
- (when byte-compile-dynamic
- (error "Version-18 compatibility doesn't support dynamic byte code"))
- (insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n"
- "\n"))))
+ ";;; This file uses opcodes which do not exist in Emacs 18.\n"
+ minimum-version "19"))
+ ;; Now insert the comment and the error check.
+ (insert
+ "\n"
+ intro-string
+ ;; Have to check if emacs-version is bound so that this works
+ ;; in files loaded early in loadup.el.
+ "(if (and (boundp 'emacs-version)\n"
+ ;; If there is a name at the end of emacs-version,
+ ;; don't try to check the version number.
+ "\t (< (aref emacs-version (1- (length emacs-version))) ?A)\n"
+ "\t (or (and (boundp 'epoch::version) epoch::version)\n"
+ (format "\t (string-lessp emacs-version \"%s\")))\n"
+ minimum-version)
+ " (error \"`"
+ ;; prin1-to-string is used to quote backslashes.
+ (substring (prin1-to-string (file-name-nondirectory filename))
+ 1 -1)
+ (format "' was compiled for Emacs %s or later\"))\n\n"
+ minimum-version)
+ ;; Insert semicolons as ballast, so that byte-compile-fix-header
+ ;; can delete them so as to keep the buffer positions
+ ;; constant for the actual compiled code.
+ ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n"))
+ ;; Here if we want Emacs 18 compatibility.
+ (when dynamic-docstrings
+ (error "Version-18 compatibility doesn't support dynamic doc strings"))
+ (when byte-compile-dynamic
+ (error "Version-18 compatibility doesn't support dynamic byte code"))
+ (insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n"
+ "\n")))))
(defun byte-compile-output-file-form (form)
;; writes the given form to the output buffer, being careful of docstrings
@@ -2038,86 +2087,83 @@ list that represents a doc string reference.
;; We need to examine byte-compile-dynamic-docstrings
;; in the input buffer (now current), not in the output buffer.
(let ((dynamic-docstrings byte-compile-dynamic-docstrings))
- ;; FIXME: What's up with those set-buffers&prog1 thingy? --Stef
- (set-buffer
- (prog1 (current-buffer)
- (set-buffer outbuffer)
- (let (position)
-
- ;; Insert the doc string, and make it a comment with #@LENGTH.
- (and (>= (nth 1 info) 0)
- dynamic-docstrings
- (not byte-compile-compatibility)
- (progn
- ;; Make the doc string start at beginning of line
- ;; for make-docfile's sake.
- (insert "\n")
- (setq position
- (byte-compile-output-as-comment
- (nth (nth 1 info) form) nil))
- (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))
- (> (length (nth (nth 1 info) form)) 0)
- (eq (aref (nth (nth 1 info) form) 0) ?*))
- (setq position (- position)))))
-
- (if preface
- (progn
- (insert preface)
- (prin1 name outbuffer)))
- (insert (car info))
- (let ((print-escape-newlines t)
- (print-quoted t)
- ;; For compatibility with code before print-circle,
- ;; use a cons cell to say that we want
- ;; print-gensym-alist not to be cleared
- ;; between calls to print functions.
- (print-gensym '(t))
- (print-circle ; handle circular data structures
- (not byte-compile-disable-print-circle))
- print-gensym-alist ; was used before print-circle existed.
- (print-continuous-numbering t)
- print-number-table
- (index 0))
- (prin1 (car form) outbuffer)
- (while (setq form (cdr form))
- (setq index (1+ index))
- (insert " ")
- (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) (point-min) -1))
- (princ (format "(#$ . %d) nil" position) outbuffer)
- (setq form (cdr form))
- (setq index (1+ index))))
- ((= index (nth 1 info))
- (if position
- (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)")
- position)
- outbuffer)
- (let ((print-escape-newlines nil))
- (goto-char (prog1 (1+ (point))
- (prin1 (car form) outbuffer)))
- (insert "\\\n")
- (goto-char (point-max)))))
- (t
- (prin1 (car form) outbuffer)))))
- (insert (nth 2 info))))))
+ (with-current-buffer outbuffer
+ (let (position)
+
+ ;; Insert the doc string, and make it a comment with #@LENGTH.
+ (and (>= (nth 1 info) 0)
+ dynamic-docstrings
+ (not byte-compile-compatibility)
+ (progn
+ ;; Make the doc string start at beginning of line
+ ;; for make-docfile's sake.
+ (insert "\n")
+ (setq position
+ (byte-compile-output-as-comment
+ (nth (nth 1 info) form) nil))
+ (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))
+ (> (length (nth (nth 1 info) form)) 0)
+ (eq (aref (nth (nth 1 info) form) 0) ?*))
+ (setq position (- position)))))
+
+ (if preface
+ (progn
+ (insert preface)
+ (prin1 name outbuffer)))
+ (insert (car info))
+ (let ((print-escape-newlines t)
+ (print-quoted t)
+ ;; For compatibility with code before print-circle,
+ ;; use a cons cell to say that we want
+ ;; print-gensym-alist not to be cleared
+ ;; between calls to print functions.
+ (print-gensym '(t))
+ (print-circle ; handle circular data structures
+ (not byte-compile-disable-print-circle))
+ print-gensym-alist ; was used before print-circle existed.
+ (print-continuous-numbering t)
+ print-number-table
+ (index 0))
+ (prin1 (car form) outbuffer)
+ (while (setq form (cdr form))
+ (setq index (1+ index))
+ (insert " ")
+ (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) (point-min) -1))
+ (princ (format "(#$ . %d) nil" position) outbuffer)
+ (setq form (cdr form))
+ (setq index (1+ index))))
+ ((= index (nth 1 info))
+ (if position
+ (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)")
+ position)
+ outbuffer)
+ (let ((print-escape-newlines nil))
+ (goto-char (prog1 (1+ (point))
+ (prin1 (car form) outbuffer)))
+ (insert "\\\n")
+ (goto-char (point-max)))))
+ (t
+ (prin1 (car form) outbuffer)))))
+ (insert (nth 2 info)))))
nil)
(defun byte-compile-keep-pending (form &optional handler)
@@ -2207,7 +2253,7 @@ list that represents a doc string reference.
;; 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)
- (when (memq 'free-vars byte-compile-warnings)
+ (when (byte-compile-warning-enabled-p 'free-vars)
(push (nth 1 form) byte-compile-bound-variables)
(if (eq (car form) 'defconst)
(push (nth 1 form) byte-compile-const-variables)))
@@ -2217,37 +2263,41 @@ list that represents a doc string reference.
(byte-compile-top-level (nth 2 form) nil 'file))))
form))
+(put 'define-abbrev-table 'byte-hunk-handler 'byte-compile-file-form-define-abbrev-table)
+(defun byte-compile-file-form-define-abbrev-table (form)
+ (when (and (byte-compile-warning-enabled-p 'free-vars)
+ (eq 'quote (car-safe (car-safe (cdr form)))))
+ (push (car-safe (cdr (cadr form))) byte-compile-bound-variables))
+ (byte-compile-keep-pending form))
+
(put 'custom-declare-variable 'byte-hunk-handler
'byte-compile-file-form-custom-declare-variable)
(defun byte-compile-file-form-custom-declare-variable (form)
- (when (memq 'callargs byte-compile-warnings)
+ (when (byte-compile-warning-enabled-p 'callargs)
(byte-compile-nogroup-warn form))
- (when (memq 'free-vars byte-compile-warnings)
+ (when (byte-compile-warning-enabled-p 'free-vars)
(push (nth 1 (nth 1 form)) byte-compile-bound-variables))
+ ;; Don't compile the expression because it may be displayed to the user.
+ ;; (when (eq (car-safe (nth 2 form)) 'quote)
+ ;; ;; (nth 2 form) is meant to evaluate to an expression, so if we have the
+ ;; ;; final value already, we can byte-compile it.
+ ;; (setcar (cdr (nth 2 form))
+ ;; (byte-compile-top-level (cadr (nth 2 form)) nil 'file)))
(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)))))
+ (unless (keywordp (car tail)) ;No point optimizing keywords.
+ ;; Compile the keyword arguments.
+ (setcar tail (byte-compile-top-level (car tail) nil 'file)))
(setq tail (cdr tail))))
form)
(put 'require 'byte-hunk-handler 'byte-compile-file-form-require)
(defun byte-compile-file-form-require (form)
- (let ((old-load-list current-load-list)
- (args (mapcar 'eval (cdr form))))
+ (let ((args (mapcar 'eval (cdr form))))
(apply 'require args)
;; Detect (require 'cl) in a way that works even if cl is already loaded.
(if (member (car args) '("cl" cl))
- (setq byte-compile-warnings
- (remq 'cl-functions byte-compile-warnings))))
+ (byte-compile-disable-warning 'cl-functions)))
(byte-compile-keep-pending form 'byte-compile-normal-call))
(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
@@ -2293,12 +2343,12 @@ list that represents a doc string reference.
(cons (list name nil nil) byte-compile-call-tree))))
(setq byte-compile-current-form name) ; for warnings
- (if (memq 'redefine byte-compile-warnings)
+ (if (byte-compile-warning-enabled-p 'redefine)
(byte-compile-arglist-warn form macrop))
(if byte-compile-verbose
(message "Compiling %s... (%s)" (or filename "") (nth 1 form)))
(cond (that-one
- (if (and (memq 'redefine byte-compile-warnings)
+ (if (and (byte-compile-warning-enabled-p 'redefine)
;; don't warn when compiling the stubs in byte-run...
(not (assq (nth 1 form)
byte-compile-initial-macro-environment)))
@@ -2307,7 +2357,7 @@ list that represents a doc string reference.
(nth 1 form)))
(setcdr that-one nil))
(this-one
- (when (and (memq 'redefine byte-compile-warnings)
+ (when (and (byte-compile-warning-enabled-p 'redefine)
;; hack: don't warn when compiling the magic internal
;; byte-compiler macros in byte-run.el...
(not (assq (nth 1 form)
@@ -2318,7 +2368,7 @@ list that represents a doc string reference.
((and (fboundp name)
(eq (car-safe (symbol-function name))
(if macrop 'lambda 'macro)))
- (when (memq 'redefine byte-compile-warnings)
+ (when (byte-compile-warning-enabled-p 'redefine)
(byte-compile-warn "%s `%s' being redefined as a %s"
(if macrop "function" "macro")
(nth 1 form)
@@ -2404,39 +2454,37 @@ list that represents a doc string reference.
;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting.
(defun byte-compile-output-as-comment (exp quoted)
(let ((position (point)))
- (set-buffer
- (prog1 (current-buffer)
- (set-buffer outbuffer)
-
- ;; Insert EXP, and make it a comment with #@LENGTH.
- (insert " ")
- (if quoted
- (prin1 exp outbuffer)
- (princ exp outbuffer))
- (goto-char position)
- ;; Quote certain special characters as needed.
- ;; get_doc_string in doc.c does the unquoting.
- (while (search-forward "\^A" nil t)
- (replace-match "\^A\^A" t t))
- (goto-char position)
- (while (search-forward "\000" nil t)
- (replace-match "\^A0" t t))
- (goto-char position)
- (while (search-forward "\037" nil t)
- (replace-match "\^A_" t t))
- (goto-char (point-max))
- (insert "\037")
- (goto-char position)
- (insert "#@" (format "%d" (- (position-bytes (point-max))
- (position-bytes position))))
-
- ;; Save the file position of the object.
- ;; Note we should add 1 to skip the space
- ;; that we inserted before the actual doc string,
- ;; and subtract 1 to convert from an 1-origin Emacs position
- ;; to a file position; they cancel.
- (setq position (point))
- (goto-char (point-max))))
+ (with-current-buffer outbuffer
+
+ ;; Insert EXP, and make it a comment with #@LENGTH.
+ (insert " ")
+ (if quoted
+ (prin1 exp outbuffer)
+ (princ exp outbuffer))
+ (goto-char position)
+ ;; Quote certain special characters as needed.
+ ;; get_doc_string in doc.c does the unquoting.
+ (while (search-forward "\^A" nil t)
+ (replace-match "\^A\^A" t t))
+ (goto-char position)
+ (while (search-forward "\000" nil t)
+ (replace-match "\^A0" t t))
+ (goto-char position)
+ (while (search-forward "\037" nil t)
+ (replace-match "\^A_" t t))
+ (goto-char (point-max))
+ (insert "\037")
+ (goto-char position)
+ (insert "#@" (format "%d" (- (position-bytes (point-max))
+ (position-bytes position))))
+
+ ;; Save the file position of the object.
+ ;; Note we should add 1 to skip the space
+ ;; that we inserted before the actual doc string,
+ ;; and subtract 1 to convert from an 1-origin Emacs position
+ ;; to a file position; they cancel.
+ (setq position (point))
+ (goto-char (point-max)))
position))
@@ -2560,7 +2608,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(byte-compile-check-lambda-list (nth 1 fun))
(let* ((arglist (nth 1 fun))
(byte-compile-bound-variables
- (nconc (and (memq 'free-vars byte-compile-warnings)
+ (nconc (and (byte-compile-warning-enabled-p 'free-vars)
(delq '&rest (delq '&optional (copy-sequence arglist))))
byte-compile-bound-variables))
(body (cdr (cdr fun)))
@@ -2771,6 +2819,20 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(cdr body))
(body
(list body))))
+
+(put 'declare-function 'byte-hunk-handler 'byte-compile-declare-function)
+(defun byte-compile-declare-function (form)
+ (push (cons (nth 1 form)
+ (if (and (> (length form) 3)
+ (listp (nth 3 form)))
+ (list 'declared (nth 3 form))
+ t)) ; arglist not specified
+ byte-compile-function-environment)
+ ;; We are stating that it _will_ be defined at runtime.
+ (setq byte-compile-noruntime-functions
+ (delq (nth 1 form) byte-compile-noruntime-functions))
+ nil)
+
;; This is the recursive entry point for compiling each subform of an
;; expression.
@@ -2800,7 +2862,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(handler (get fn 'byte-compile)))
(when (byte-compile-const-symbol-p fn)
(byte-compile-warn "`%s' called as a function" fn))
- (and (memq 'interactive-only byte-compile-warnings)
+ (and (byte-compile-warning-enabled-p 'interactive-only)
(memq fn byte-compile-interactive-only-functions)
(byte-compile-warn "`%s' used from Lisp code\n\
That command is designed for interactive use only" fn))
@@ -2815,12 +2877,12 @@ That command is designed for interactive use only" fn))
byte-compile-compatibility)
(get (get fn 'byte-opcode) 'emacs19-opcode))))
(funcall handler form)
- (when (memq 'callargs byte-compile-warnings)
+ (when (byte-compile-warning-enabled-p 'callargs)
(if (memq fn '(custom-declare-group custom-declare-variable custom-declare-face))
(byte-compile-nogroup-warn form))
(byte-compile-callargs-warn form))
(byte-compile-normal-call form))
- (if (memq 'cl-functions byte-compile-warnings)
+ (if (byte-compile-warning-enabled-p 'cl-functions)
(byte-compile-cl-warn form))))
((and (or (byte-code-function-p (car form))
(eq (car-safe (car form)) 'lambda))
@@ -2836,6 +2898,11 @@ That command is designed for interactive use only" fn))
(defun byte-compile-normal-call (form)
(if byte-compile-generate-call-tree
(byte-compile-annotate-call-tree form))
+ (when (and for-effect (eq (car form) 'mapcar)
+ (byte-compile-warning-enabled-p 'mapcar))
+ (byte-compile-set-symbol-position 'mapcar)
+ (byte-compile-warn
+ "`mapcar' called for effect; use `mapc' or `dolist' instead"))
(byte-compile-push-constant (car form))
(mapc 'byte-compile-form (cdr form)) ; wasteful, but faster.
(byte-compile-out 'byte-call (length (cdr form))))
@@ -2852,7 +2919,7 @@ That command is designed for interactive use only" fn))
(if (symbolp var) "constant" "nonvariable")
(prin1-to-string var))
(if (and (get var 'byte-obsolete-variable)
- (memq 'obsolete byte-compile-warnings)
+ (byte-compile-warning-enabled-p 'obsolete)
(not (eq var byte-compile-not-obsolete-var)))
(let* ((ob (get var 'byte-obsolete-variable))
(when (cdr ob)))
@@ -2861,7 +2928,7 @@ That command is designed for interactive use only" fn))
(if (stringp (car ob))
(car ob)
(format "use `%s' instead." (car ob))))))
- (if (memq 'free-vars byte-compile-warnings)
+ (if (byte-compile-warning-enabled-p 'free-vars)
(if (eq base-op 'byte-varbind)
(push var byte-compile-bound-variables)
(or (boundp var)
@@ -3441,6 +3508,32 @@ That command is designed for interactive use only" fn))
(if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop))
,tag))
+;; Return the list of items in CONDITION-PARAM that match PRED-LIST.
+;; Only return items that are not in ONLY-IF-NOT-PRESENT.
+(defun byte-compile-find-bound-condition (condition-param
+ pred-list
+ &optional only-if-not-present)
+ (let ((result nil)
+ (nth-one nil)
+ (cond-list
+ (if (memq (car-safe condition-param) pred-list)
+ ;; The condition appears by itself.
+ (list condition-param)
+ ;; If the condition is an `and', look for matches among the
+ ;; `and' arguments.
+ (when (eq 'and (car-safe condition-param))
+ (cdr condition-param)))))
+
+ (dolist (crt cond-list)
+ (when (and (memq (car-safe crt) pred-list)
+ (eq 'quote (car-safe (setq nth-one (nth 1 crt))))
+ ;; Ignore if the symbol is already on the unresolved
+ ;; list.
+ (not (assq (nth 1 nth-one) ; the relevant symbol
+ only-if-not-present)))
+ (push (nth 1 (nth 1 crt)) result)))
+ result))
+
(defmacro byte-compile-maybe-guarded (condition &rest body)
"Execute forms in BODY, potentially guarded by CONDITION.
CONDITION is a variable whose value is a test in an `if' or `cond'.
@@ -3452,35 +3545,34 @@ being undefined will be suppressed.
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
- (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)))))
+ `(let* ((fbound-list (byte-compile-find-bound-condition
+ ,condition (list 'fboundp)
+ byte-compile-unresolved-functions))
+ (bound-list (byte-compile-find-bound-condition
+ ,condition (list 'boundp 'default-boundp)))
;; Maybe add to the bound list.
(byte-compile-bound-variables
- (if bound
- (cons bound byte-compile-bound-variables)
+ (if bound-list
+ (append bound-list byte-compile-bound-variables)
byte-compile-bound-variables))
;; Suppress all warnings, for code not used in Emacs.
- (byte-compile-warnings
- (if (member ,condition '((featurep 'xemacs)
- (not (featurep 'emacs))))
- nil byte-compile-warnings)))
+ ;; FIXME: by the time this is executed the `featurep'
+ ;; emacs/xemacs tests have been optimized away, so this is
+ ;; not doing anything useful here, is should probably be
+ ;; moved to a different place.
+ ;; (byte-compile-warnings
+ ;; (if (member ,condition '((featurep 'xemacs)
+ ;; (not (featurep 'emacs))))
+ ;; nil byte-compile-warnings))
+ )
(unwind-protect
(progn ,@body)
;; Maybe remove the function symbol from the unresolved list.
- (if fbound
+ (dolist (fbound fbound-list)
+ (when fbound
(setq byte-compile-unresolved-functions
(delq (assq fbound byte-compile-unresolved-functions)
- byte-compile-unresolved-functions))))))
+ byte-compile-unresolved-functions)))))))
(defun byte-compile-if (form)
(byte-compile-form (car (cdr form)))
@@ -3802,7 +3894,7 @@ that suppresses all warnings during execution of BODY."
(if (= 1 ncall) "" "s")
(if (< ncall 2) "requires" "accepts only")
"2-3")))
- (when (memq 'free-vars byte-compile-warnings)
+ (when (byte-compile-warning-enabled-p 'free-vars)
(push var byte-compile-bound-variables)
(if (eq fun 'defconst)
(push var byte-compile-const-variables)))
@@ -3893,7 +3985,8 @@ that suppresses all warnings during execution of BODY."
;; Warn about misuses of make-variable-buffer-local.
(byte-defop-compiler-1 make-variable-buffer-local byte-compile-make-variable-buffer-local)
(defun byte-compile-make-variable-buffer-local (form)
- (if (eq (car-safe (car-safe (cdr-safe form))) 'quote)
+ (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote)
+ (byte-compile-warning-enabled-p 'make-local))
(byte-compile-warn
"`make-variable-buffer-local' should be called at toplevel"))
(byte-compile-normal-call form))
@@ -4238,18 +4331,18 @@ and corresponding effects."
(assq 'byte-code (symbol-function 'byte-compile-form))
(let ((byte-optimize nil) ; do it fast
(byte-compile-warnings nil))
- (mapcar (lambda (x)
- (or noninteractive (message "compiling %s..." x))
- (byte-compile x)
- (or noninteractive (message "compiling %s...done" x)))
- '(byte-compile-normal-call
- byte-compile-form
- byte-compile-body
- ;; Inserted some more than necessary, to speed it up.
- byte-compile-top-level
- byte-compile-out-toplevel
- byte-compile-constant
- byte-compile-variable-ref))))
+ (mapc (lambda (x)
+ (or noninteractive (message "compiling %s..." x))
+ (byte-compile x)
+ (or noninteractive (message "compiling %s...done" x)))
+ '(byte-compile-normal-call
+ byte-compile-form
+ byte-compile-body
+ ;; Inserted some more than necessary, to speed it up.
+ byte-compile-top-level
+ byte-compile-out-toplevel
+ byte-compile-constant
+ byte-compile-variable-ref))))
nil)
(run-hooks 'bytecomp-load-hook)
generated by cgit v1.2.3 (git 2.39.1) at 2025-05-10 20:16:36 +0000