diff options
Diffstat (limited to 'lisp/emacs-lisp/bytecomp.el')
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 1520 |
1 files changed, 1047 insertions, 473 deletions
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index d093d95a775..6c5051d70c4 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -292,48 +292,60 @@ The information is logged to `byte-compile-log-buffer'." ;;;###autoload(put 'byte-compile-error-on-warn 'safe-local-variable 'booleanp) (defconst byte-compile-warning-types - '(redefine callargs free-vars unresolved - obsolete noruntime interactive-only - make-local mapcar constants suspicious lexical lexical-dynamic - docstrings docstrings-non-ascii-quotes not-unused) + '( callargs constants + docstrings docstrings-non-ascii-quotes docstrings-wide + empty-body free-vars ignored-return-value interactive-only + lexical lexical-dynamic make-local + mapcar ; obsolete + mutate-constant noruntime not-unused obsolete redefine suspicious + unresolved) "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 almost all). Elements of the list may be: - free-vars references to variables not in the current lexical scope. - unresolved calls to unknown functions. callargs function calls with args that don't match the definition. - redefine function name redefined from a macro to ordinary function or vice - versa, or redefined to take a different number of arguments. - obsolete obsolete variables and functions. - noruntime functions that may not be defined at runtime (typically - defined only under `eval-when-compile'). + constants let-binding of, or assignment to, constants/nonvariables. + docstrings various docstring stylistic issues, such as incorrect use + of single quotes + docstrings-non-ascii-quotes + docstrings that have non-ASCII quotes. + Only enabled when `docstrings' also is. + docstrings-wide + docstrings that are too wide, containing lines longer than both + `byte-compile-docstring-max-column' and `fill-column' characters. + Only enabled when `docstrings' also is. + empty-body body argument to a special form or macro is empty. + free-vars references to variables not in the current lexical scope. + ignored-return-value + function called without using the return value where this + is likely to be a mistake. interactive-only commands that normally shouldn't be called from Lisp code. lexical global/dynamic variables lacking a prefix. lexical-dynamic lexically bound variable declared dynamic elsewhere make-local calls to `make-variable-buffer-local' that may be incorrect. - mapcar mapcar called for effect. + mutate-constant + code that mutates program constants such as quoted lists. + noruntime functions that may not be defined at runtime (typically + defined only under `eval-when-compile'). not-unused warning about using variables with symbol names starting with _. - constants let-binding of, or assignment to, constants/nonvariables. - docstrings docstrings that are too wide (longer than - `byte-compile-docstring-max-column' or - `fill-column' characters, whichever is bigger) or - have other stylistic issues. - docstrings-non-ascii-quotes docstrings that have non-ASCII quotes. - This depends on the `docstrings' warning type. + obsolete obsolete variables and functions. + redefine function name redefined from a macro to ordinary function or vice + versa, or redefined to take a different number of arguments. suspicious constructs that usually don't do what the coder wanted. + unresolved calls to unknown functions. If the list begins with `not', then the remaining elements specify warnings to -suppress. For example, (not mapcar) will suppress warnings about mapcar. +suppress. For example, (not free-vars) will suppress the `free-vars' warning. The t value means \"all non experimental warning types\", and excludes the types in `byte-compile--emacs-build-warning-types'. A value of `all' really means all." - :type `(choice (const :tag "All" t) + :type `(choice (const :tag "Default selection" t) + (const :tag "All" all) (set :menu-tag "Some" ,@(mapcar (lambda (x) `(const ,x)) byte-compile-warning-types)))) @@ -483,8 +495,7 @@ Return the compile-time value of FORM." ;; 3.2.3.1, "Processing of Top Level Forms". The semantics are very ;; subtle: see test/lisp/emacs-lisp/bytecomp-tests.el for interesting ;; cases. - (let ((print-symbols-bare t)) ; Possibly redundant binding. - (setf form (macroexp-macroexpand form byte-compile-macro-environment))) + (setf form (macroexp-macroexpand form byte-compile-macro-environment)) (if (eq (car-safe form) 'progn) (cons (car form) (mapcar (lambda (subform) @@ -493,6 +504,42 @@ Return the compile-time value of FORM." (cdr form))) (funcall non-toplevel-case form))) + +(defvar bytecomp--copy-tree-seen) + +(defun bytecomp--copy-tree-1 (tree) + ;; TREE must be a cons. + (or (gethash tree bytecomp--copy-tree-seen) + (let* ((next (cdr tree)) + (result (cons nil next)) + (copy result)) + (while (progn + (puthash tree copy bytecomp--copy-tree-seen) + (let ((a (car tree))) + (setcar copy (if (consp a) + (bytecomp--copy-tree-1 a) + a))) + (and (consp next) + (let ((tail (gethash next bytecomp--copy-tree-seen))) + (if tail + (progn (setcdr copy tail) + nil) + (setq tree next) + (setq next (cdr next)) + (let ((prev copy)) + (setq copy (cons nil next)) + (setcdr prev copy) + t)))))) + result))) + +(defun bytecomp--copy-tree (tree) + "Make a copy of TREE, preserving any circular structure therein. +Only conses are traversed and duplicated, not arrays or any other structure." + (if (consp tree) + (let ((bytecomp--copy-tree-seen (make-hash-table :test #'eq))) + (bytecomp--copy-tree-1 tree)) + tree)) + (defconst byte-compile-initial-macro-environment `( ;; (byte-compiler-options . (lambda (&rest forms) @@ -526,13 +573,13 @@ Return the compile-time value of FORM." ;; Don't compile here, since we don't know ;; whether to compile as byte-compile-form ;; or byte-compile-file-form. - (let* ((print-symbols-bare t) ; Possibly redundant binding. - (expanded - (byte-run-strip-symbol-positions - (macroexpand--all-toplevel - form - macroexpand-all-environment)))) - (eval expanded lexical-binding) + (let ((expanded + (macroexpand--all-toplevel + form + macroexpand-all-environment))) + (eval (byte-run-strip-symbol-positions + (bytecomp--copy-tree expanded)) + lexical-binding) expanded))))) (with-suppressed-warnings . ,(lambda (warnings &rest body) @@ -541,15 +588,19 @@ Return the compile-time value of FORM." ;; Later `internal--with-suppressed-warnings' binds it again, this ;; time in order to affect warnings emitted during the ;; compilation itself. - (let ((byte-compile--suppressed-warnings - (append warnings byte-compile--suppressed-warnings))) - ;; This function doesn't exist, but is just a placeholder - ;; symbol to hook up with the - ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery. - `(internal--with-suppressed-warnings - ',warnings - ,(macroexpand-all `(progn ,@body) - macroexpand-all-environment)))))) + (if body + (let ((byte-compile--suppressed-warnings + (append warnings byte-compile--suppressed-warnings))) + ;; This function doesn't exist, but is just a placeholder + ;; symbol to hook up with the + ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery. + `(internal--with-suppressed-warnings + ',warnings + ,(macroexpand-all `(progn ,@body) + macroexpand-all-environment))) + (macroexp-warn-and-return + (format-message "`with-suppressed-warnings' with empty body") + nil '(empty-body with-suppressed-warnings) t warnings))))) "The default macro-environment passed to macroexpand by the compiler. Placing a macro here will cause a macro to have different semantics when expanded by the compiler as when expanded by the interpreter.") @@ -1081,7 +1132,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." ;; we arguably should add it to b-c-noruntime-functions, ;; but it's not clear it's worth the trouble ;; trying to recognize that case. - (unless (get f 'function-history) + (unless (or (get f 'function-history) + (assq f byte-compile-function-environment)) (push f byte-compile-noruntime-functions))))))))))))) (defun byte-compile-eval-before-compile (form) @@ -1569,61 +1621,9 @@ extra args." "`%s' called with %d args to fill %d format field(s)" (car form) nargs nfields))))) -(dolist (elt '(format message error)) +(dolist (elt '(format message format-message error)) (put elt 'byte-compile-format-like t)) -(defun byte-compile--suspicious-defcustom-choice (type) - "Say whether defcustom TYPE looks odd." - ;; Check whether there's anything like (choice (const :tag "foo" ;; 'bar)). - ;; We don't actually follow the syntax for defcustom types, but this - ;; should be good enough. - (catch 'found - (if (and (consp type) - (proper-list-p type)) - (if (memq (car type) '(const other)) - (when (assq 'quote type) - (throw 'found t)) - (when (memq t (mapcar #'byte-compile--suspicious-defcustom-choice - type)) - (throw 'found t))) - nil))) - -;; Warn if a custom definition fails to specify :group, or :type. -(defun byte-compile-nogroup-warn (form) - (let ((keyword-args (cdr (cdr (cdr (cdr form))))) - (name (cadr form))) - (when (eq (car-safe name) 'quote) - (when (eq (car form) 'custom-declare-variable) - (let ((type (plist-get keyword-args :type))) - (cond - ((not type) - (byte-compile-warn-x (cadr name) - "defcustom for `%s' fails to specify type" - (cadr name))) - ((byte-compile--suspicious-defcustom-choice type) - (byte-compile-warn-x - (cadr name) - "defcustom for `%s' has syntactically odd type `%s'" - (cadr name) type))))) - (if (and (memq (car form) '(custom-declare-face custom-declare-variable)) - byte-compile-current-group) - ;; The group will be provided implicitly. - nil - (or (and (eq (car form) 'custom-declare-group) - (equal name ''emacs)) - (plist-get keyword-args :group) - (byte-compile-warn-x (cadr name) - "%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))) - ;; Update the current group, if needed. - (if (and byte-compile-current-file ;Only when compiling a whole file. - (eq (car form) 'custom-declare-group)) - (setq byte-compile-current-group (cadr name))))))) - ;; Warn if the function or macro is being redefined with a different ;; number of arguments. (defun byte-compile-arglist-warn (name arglist macrop) @@ -1674,53 +1674,75 @@ extra args." (if (equal sig1 '(1 . 1)) "argument" "arguments") (byte-compile-arglist-signature-string sig2))))))) -(defvar byte-compile--wide-docstring-substitution-len 3 - "Substitution width used in `byte-compile--wide-docstring-p'. -This is a heuristic for guessing the width of a documentation -string: `byte-compile--wide-docstring-p' assumes that any -`substitute-command-keys' command substitutions are this long.") - -(defun byte-compile--wide-docstring-p (docstring col) - "Return t if string DOCSTRING is wider than COL. +(defun bytecomp--docstring-line-width (str) + "An approximation of the displayed width of docstring line STR." + ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just + ;; remove the markup as `substitute-command-keys' would. + (when (string-search "\\`" str) + (setq str (replace-regexp-in-string + (rx "\\`" (group (* (not "'"))) "'") + "\\1" + str t))) + ;; Heuristic: We can't reliably do `substitute-command-keys' + ;; substitutions, since the value of a keymap in general can't be + ;; known at compile time. So instead, we assume that these + ;; substitutions are of some constant length. + (when (string-search "\\[" str) + (setq str (replace-regexp-in-string + (rx "\\[" (* (not "]")) "]") + ;; We assume that substitutions have this length. + ;; To preserve the non-expansive property of the transform, + ;; it shouldn't be more than 3 characters long. + "xxx" + str t t))) + (setq str + (replace-regexp-in-string + (rx (or + ;; Ignore some URLs. + (seq "http" (? "s") "://" (* nonl)) + ;; Ignore these `substitute-command-keys' substitutions. + (seq "\\" (or "=" + (seq "<" (* (not ">")) ">") + (seq "{" (* (not "}")) "}"))) + ;; Ignore the function signature that's stashed at the end of + ;; the doc string (in some circumstances). + (seq bol "(" (+ (any word "-/:[]&")) + ;; One or more arguments. + (+ " " (or + ;; Arguments. + (+ (or (syntax symbol) + (any word "-/:[]&=()<>.,?^\\#*'\""))) + ;; Argument that is a list. + (seq "(" (* (not ")")) ")"))) + ")"))) + "" str t t)) + (length str)) + +(defun byte-compile--wide-docstring-p (docstring max-width) + "Whether DOCSTRING contains a line wider than MAX-WIDTH. Ignore all `substitute-command-keys' substitutions, except for -the `\\\\=[command]' ones that are assumed to be of length -`byte-compile--wide-docstring-substitution-len'. Also ignore -URLs." - (string-match - (format "^.\\{%d,\\}$" (min (1+ col) #xffff)) ; Heed RE_DUP_MAX. - (replace-regexp-in-string - (rx (or - ;; Ignore some URLs. - (seq "http" (? "s") "://" (* nonl)) - ;; Ignore these `substitute-command-keys' substitutions. - (seq "\\" (or "=" - (seq "<" (* (not ">")) ">") - (seq "{" (* (not "}")) "}"))) - ;; Ignore the function signature that's stashed at the end of - ;; the doc string (in some circumstances). - (seq bol "(" (+ (any word "-/:[]&")) - ;; One or more arguments. - (+ " " (or - ;; Arguments. - (+ (or (syntax symbol) - (any word "-/:[]&=()<>.,?^\\#*'\""))) - ;; Argument that is a list. - (seq "(" (* (not ")")) ")"))) - ")"))) - "" - ;; Heuristic: We can't reliably do `substitute-command-keys' - ;; substitutions, since the value of a keymap in general can't be - ;; known at compile time. So instead, we assume that these - ;; substitutions are of some length N. - (replace-regexp-in-string - (rx "\\[" (* (not "]")) "]") - (make-string byte-compile--wide-docstring-substitution-len ?x) - ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just - ;; remove the markup as `substitute-command-keys' would. - (replace-regexp-in-string - (rx "\\`" (group (* (not "'"))) "'") - "\\1" - docstring))))) +the `\\\\=[command]' ones that are assumed to be of a fixed length. +Also ignore URLs." + (let ((string-len (length docstring)) + (start 0) + (too-wide nil)) + (while (< start string-len) + (let ((eol (or (string-search "\n" docstring start) + string-len))) + ;; Since `bytecomp--docstring-line-width' is non-expansive, + ;; we can safely assume that if the raw length is + ;; within the allowed width, then so is the transformed width. + ;; This allows us to avoid the very expensive transformation in + ;; most cases. + (if (and (> (- eol start) max-width) + (> (bytecomp--docstring-line-width + (substring docstring start eol)) + max-width)) + (progn + (setq too-wide t) + (setq start string-len)) + (setq start (1+ eol))))) + too-wide)) (defcustom byte-compile-docstring-max-column 80 "Recommended maximum width of doc string lines. @@ -1741,8 +1763,11 @@ Warn if documentation string of FORM is too wide. It is too wide if it has any lines longer than the largest of `fill-column' and `byte-compile-docstring-max-column'." (when (byte-compile-warning-enabled-p 'docstrings) - (let ((col (max byte-compile-docstring-max-column fill-column)) - kind name docs) + (let* ((kind nil) (name nil) (docs nil) + (prefix (lambda () + (format "%s%s" + kind + (if name (format-message " `%s' " name) ""))))) (pcase (car form) ((or 'autoload 'custom-declare-variable 'defalias 'defconst 'define-abbrev-table @@ -1750,33 +1775,41 @@ It is too wide if it has any lines longer than the largest of 'custom-declare-face) (setq kind (nth 0 form)) (setq name (nth 1 form)) + (when (and (consp name) (eq (car name) 'quote)) + (setq name (cadr name))) (setq docs (nth 3 form))) ('lambda (setq kind "") ; can't be "function", unfortunately - (setq docs (and (stringp (nth 2 form)) - (nth 2 form))))) - (when (and (consp name) (eq (car name) 'quote)) - (setq name (cadr name))) - (setq name (if name (format " `%s' " name) "")) + (setq docs (nth 2 form)))) (when (and kind docs (stringp docs)) - (when (byte-compile--wide-docstring-p docs col) - (byte-compile-warn-x - name - "%s%sdocstring wider than %s characters" - kind name col)) + (let ((col (max byte-compile-docstring-max-column fill-column))) + (when (and (byte-compile-warning-enabled-p 'docstrings-wide) + (byte-compile--wide-docstring-p docs col)) + (byte-compile-warn-x + name + "%sdocstring wider than %s characters" (funcall prefix) col))) ;; There's a "naked" ' character before a symbol/list, so it ;; should probably be quoted with \=. - (when (string-match-p "\\( [\"#]\\|[ \t]\\|^\\)'[a-z(]" docs) + (when (string-match-p (rx (| (in " \t") bol) + (? (in "\"#")) + "'" + (in "A-Za-z" "(")) + docs) (byte-compile-warn-x - name "%s%sdocstring has wrong usage of unescaped single quotes (use \\= or different quoting)" - kind name)) + name + (concat "%sdocstring has wrong usage of unescaped single quotes" + " (use \\=%c or different quoting such as %c...%c)") + (funcall prefix) ?' ?` ?')) ;; There's a "Unicode quote" in the string -- it should probably ;; be an ASCII one instead. (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes) - (when (string-match-p "\\( \"\\|[ \t]\\|^\\)[‘’]" docs) + (when (string-match-p (rx (| " \"" (in " \t") bol) + (in "‘’")) + docs) (byte-compile-warn-x - name "%s%sdocstring has wrong usage of \"fancy\" single quotation marks" - kind name)))))) + name + "%sdocstring uses curved single quotes; use %s instead of ‘...’" + (funcall prefix) "`...'")))))) form) ;; If we have compiled any calls to functions which are not known to be @@ -1828,8 +1861,6 @@ It is too wide if it has any lines longer than the largest of (byte-compile-dynamic byte-compile-dynamic) (byte-compile-dynamic-docstrings byte-compile-dynamic-docstrings) - ;; (byte-compile-generate-emacs19-bytecodes - ;; byte-compile-generate-emacs19-bytecodes) (byte-compile-warnings byte-compile-warnings) ;; Indicate that we're not currently loading some file. ;; This is used in `macroexp-file-name' to make sure that @@ -1845,35 +1876,37 @@ It is too wide if it has any lines longer than the largest of (defmacro displaying-byte-compile-warnings (&rest body) (declare (debug (def-body))) - `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body)) - (warning-series-started - (and (markerp warning-series) - (eq (marker-buffer warning-series) - (get-buffer byte-compile-log-buffer)))) - (byte-compile-form-stack byte-compile-form-stack)) - (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))))) - ;; 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)))))))) + `(bytecomp--displaying-warnings (lambda () ,@body))) + +(defun bytecomp--displaying-warnings (body-fn) + (let* ((warning-series-started + (and (markerp warning-series) + (eq (marker-buffer warning-series) + (get-buffer byte-compile-log-buffer)))) + (byte-compile-form-stack byte-compile-form-stack)) + (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 body-fn) + (condition-case error-info + (funcall body-fn) + (error (byte-compile-report-error error-info))))) + ;; 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 body-fn) + (condition-case error-info + (funcall body-fn) + (error (byte-compile-report-error error-info)))))))) ;;;###autoload (defun byte-force-recompile (directory) @@ -2170,6 +2203,11 @@ See also `emacs-lisp-byte-compile-and-load'." filename buffer-file-name)) ;; Don't inherit lexical-binding from caller (bug#12938). (unless (local-variable-p 'lexical-binding) + (let ((byte-compile-current-buffer (current-buffer))) + (displaying-byte-compile-warnings + (byte-compile-warn-x + (position-symbol 'a (point-min)) + "file has no `lexical-binding' directive on its first line"))) (setq-local lexical-binding nil)) ;; Set the default directory, in case an eval-when-compile uses it. (setq default-directory (file-name-directory filename))) @@ -2436,17 +2474,15 @@ Call from the source buffer." ;; Spill output for the native compiler here (push (make-byte-to-native-top-level :form form :lexical lexical-binding) byte-to-native-top-level-forms)) - (let ((print-symbols-bare t) ; Possibly redundant binding. - (print-escape-newlines t) + (let ((print-escape-newlines t) (print-length nil) (print-level nil) (print-quoted t) (print-gensym t) (print-circle t)) ; Handle circular data structures. - (if (and (memq (car-safe form) '(defvar defvaralias defconst - autoload custom-declare-variable)) - (stringp (nth 3 form))) - (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil + (if (memq (car-safe form) '(defvar defvaralias defconst + autoload custom-declare-variable)) + (byte-compile-output-docform nil nil nil '("\n(" ")") form nil 3 nil (memq (car form) '(defvaralias autoload custom-declare-variable))) @@ -2456,10 +2492,105 @@ Call from the source buffer." (defvar byte-compile--for-effect) -(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, -before INFO and the FORM but after the doc string itself. +(defun byte-compile--output-docform-recurse + (info position form cvecindex docindex specindex quoted) + "Print a form with a doc string. INFO is (prefix postfix). +POSITION is where the next doc string is to be inserted. +CVECINDEX is the index in the FORM of the constant vector, or nil. +DOCINDEX is the index of the doc string (or nil) in the FORM. +If SPECINDEX is non-nil, it is the index in FORM +of the function bytecode string. In that case, +we output that argument and the following argument +\(the constants vector) together, for lazy loading. +QUOTED says that we have to put a quote before the +list that represents a doc string reference. +`defvaralias', `autoload' and `custom-declare-variable' need that. + +Return the position after any inserted docstrings as comments." + (let ((index 0) + doc-string-position) + ;; Insert the doc string, and make it a comment with #@LENGTH. + (when (and byte-compile-dynamic-docstrings + (stringp (nth docindex form))) + (goto-char position) + (setq doc-string-position + (byte-compile-output-as-comment + (nth docindex form) nil) + position (point)) + (goto-char (point-max))) + + (insert (car info)) + (prin1 (car form) byte-compile--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) + (when (hash-table-p print-number-table) + (maphash (lambda (_k v) (if v (setq non-nil t))) + print-number-table)) + (not non-nil))) + ;; Output the byte code and constants specially + ;; for lazy dynamic loading. + (goto-char position) + (let ((lazy-position (byte-compile-output-as-comment + (cons (car form) (nth 1 form)) + t))) + (setq position (point)) + (goto-char (point-max)) + (princ (format "(#$ . %d) nil" lazy-position) + byte-compile--outbuffer) + (setq form (cdr form)) + (setq index (1+ index)))) + ((eq index cvecindex) + (let* ((cvec (car form)) + (len (length cvec)) + (index2 0) + elt) + (insert "[") + (while (< index2 len) + (setq elt (aref cvec index2)) + (if (byte-code-function-p elt) + (setq position + (byte-compile--output-docform-recurse + '("#[" "]") position + (append elt nil) ; Convert the vector to a list. + 2 4 specindex nil)) + (prin1 elt byte-compile--outbuffer)) + (setq index2 (1+ index2)) + (unless (eq index2 len) + (insert " "))) + (insert "]"))) + ((= index docindex) + (cond + (doc-string-position + (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") + doc-string-position) + byte-compile--outbuffer)) + ((stringp (car form)) + (let ((print-escape-newlines nil)) + (goto-char (prog1 (1+ (point)) + (prin1 (car form) + byte-compile--outbuffer))) + (insert "\\\n") + (goto-char (point-max)))) + (t (prin1 (car form) byte-compile--outbuffer)))) + (t (prin1 (car form) byte-compile--outbuffer)))) + (insert (cadr info)) + position)) + +(defun byte-compile-output-docform (preface tailpiece name info form + cvecindex docindex + specindex quoted) + "Print a form with a doc string. INFO is (prefix postfix). +If PREFACE, NAME, and TAILPIECE are non-nil, print them too, +before/after INFO and the FORM but after the doc string itself. +CVECINDEX is the index in the FORM of the constant vector, or nil. +DOCINDEX is the index of the doc string (or nil) in the FORM. If SPECINDEX is non-nil, it is the index in FORM of the function bytecode string. In that case, we output that argument and the following argument @@ -2469,74 +2600,30 @@ list that represents a doc string reference. `defvaralias', `autoload' and `custom-declare-variable' need that." ;; 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)) + (let ((byte-compile-dynamic-docstrings byte-compile-dynamic-docstrings)) (with-current-buffer byte-compile--outbuffer - (let (position - (print-symbols-bare t)) ; Possibly redundant binding. - ;; Insert the doc string, and make it a comment with #@LENGTH. - (when (and (>= (nth 1 info) 0) dynamic-docstrings) - (setq position (byte-compile-output-as-comment - (nth (nth 1 info) form) nil))) - - (let ((print-continuous-numbering t) - print-number-table - (index 0) - ;; FIXME: The bindings below are only needed for when we're - ;; called from ...-defmumble. - (print-escape-newlines t) - (print-length nil) - (print-level nil) - (print-quoted t) - (print-gensym t) - (print-circle t)) ; Handle circular data structures. - (if preface - (progn - ;; FIXME: We don't handle uninterned names correctly. - ;; E.g. if cl-define-compiler-macro uses uninterned name we get: - ;; (defalias '#1=#:foo--cmacro #[514 ...]) - ;; (put 'foo 'compiler-macro '#:foo--cmacro) - (insert preface) - (prin1 name byte-compile--outbuffer))) - (insert (car info)) - (prin1 (car form) byte-compile--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) - (when (hash-table-p print-number-table) - (maphash (lambda (_k v) (if v (setq non-nil t))) - print-number-table)) - (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))) - (princ (format "(#$ . %d) nil" position) - byte-compile--outbuffer) - (setq form (cdr form)) - (setq index (1+ index)))) - ((= index (nth 1 info)) - (if position - (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)") - position) - byte-compile--outbuffer) - (let ((print-escape-newlines nil)) - (goto-char (prog1 (1+ (point)) - (prin1 (car form) - byte-compile--outbuffer))) - (insert "\\\n") - (goto-char (point-max))))) - (t - (prin1 (car form) byte-compile--outbuffer))))) - (insert (nth 2 info))))) - nil) + (let ((position (point)) + (print-continuous-numbering t) + print-number-table + ;; FIXME: The bindings below are only needed for when we're + ;; called from ...-defmumble. + (print-escape-newlines t) + (print-length nil) + (print-level nil) + (print-quoted t) + (print-gensym t) + (print-circle t)) ; Handle circular data structures. + (when preface + ;; FIXME: We don't handle uninterned names correctly. + ;; E.g. if cl-define-compiler-macro uses uninterned name we get: + ;; (defalias '#1=#:foo--cmacro #[514 ...]) + ;; (put 'foo 'compiler-macro '#:foo--cmacro) + (insert preface) + (prin1 name byte-compile--outbuffer)) + (byte-compile--output-docform-recurse + info position form cvecindex docindex specindex quoted) + (when tailpiece + (insert tailpiece)))))) (defun byte-compile-keep-pending (form &optional handler) (if (memq byte-optimize '(t source)) @@ -2568,8 +2655,7 @@ list that represents a doc string reference. byte-compile-jump-tables nil)))) (defun byte-compile-preprocess (form &optional _for-effect) - (let ((print-symbols-bare t)) ; Possibly redundant binding. - (setq form (macroexpand-all form byte-compile-macro-environment))) + (setq form (macroexpand-all form byte-compile-macro-environment)) ;; FIXME: We should run byte-optimize-form here, but it currently does not ;; recurse through all the code, so we'd have to fix this first. ;; Maybe a good fix would be to merge byte-optimize-form into @@ -2580,16 +2666,12 @@ list that represents a doc string reference. ;; byte-hunk-handlers cannot call this! (defun byte-compile-toplevel-file-form (top-level-form) - ;; (let ((byte-compile-form-stack - ;; (cons top-level-form byte-compile-form-stack))) - (push top-level-form byte-compile-form-stack) - (prog1 - (byte-compile-recurse-toplevel - top-level-form - (lambda (form) - (let ((byte-compile-current-form nil)) ; close over this for warnings. - (byte-compile-file-form (byte-compile-preprocess form t))))) - (pop byte-compile-form-stack))) + (macroexp--with-extended-form-stack top-level-form + (byte-compile-recurse-toplevel + top-level-form + (lambda (form) + (let ((byte-compile-current-form nil)) ; close over this for warnings. + (byte-compile-file-form (byte-compile-preprocess form t))))))) ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) @@ -2865,60 +2947,58 @@ not to take responsibility for the actual compilation of the code." ;; Otherwise, we have a bona-fide defun/defmacro definition, and use ;; special code to allow dynamic docstrings and byte-code. (byte-compile-flush-pending) - (let ((index - ;; If there's no doc string, provide -1 as the "doc string - ;; index" so that no element will be treated as a doc string. - (if (not (stringp (documentation code t))) -1 4))) - (when byte-native-compiling - ;; Spill output for the native compiler here. - (push - (if macro - (make-byte-to-native-top-level - :form `(defalias ',name '(macro . ,code) nil) - :lexical lexical-binding) - (make-byte-to-native-func-def :name name - :byte-func code)) - byte-to-native-top-level-forms)) - ;; Output the form by hand, that's much simpler than having - ;; b-c-output-file-form analyze the defalias. - (byte-compile-output-docform - "\n(defalias '" - bare-name - (if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]")) - (append code nil) ; Turn byte-code-function-p into list. - (and (atom code) byte-compile-dynamic - 1) - nil)) - (princ ")" byte-compile--outbuffer) + (when byte-native-compiling + ;; Spill output for the native compiler here. + (push + (if macro + (make-byte-to-native-top-level + :form `(defalias ',name '(macro . ,code) nil) + :lexical lexical-binding) + (make-byte-to-native-func-def :name name + :byte-func code)) + byte-to-native-top-level-forms)) + ;; Output the form by hand, that's much simpler than having + ;; b-c-output-file-form analyze the defalias. + (byte-compile-output-docform + "\n(defalias '" ")" + bare-name + (if macro '(" '(macro . #[" "])") '(" #[" "]")) + (append code nil) ; Turn byte-code-function-p into list. + 2 4 + (and (atom code) byte-compile-dynamic 1) + nil) t))))) (defun byte-compile-output-as-comment (exp quoted) - "Print Lisp object EXP in the output file, inside a comment. -Return the file (byte) position it will have. -If QUOTED is non-nil, print with quoting; otherwise, print without quoting." + "Print Lisp object EXP in the output file at point, inside a comment. +Return the file (byte) position it will have. Leave point after +the inserted text. If QUOTED is non-nil, print with quoting; +otherwise, print without quoting." (with-current-buffer byte-compile--outbuffer - (let ((position (point))) - + (let ((position (point)) end) ;; Insert EXP, and make it a comment with #@LENGTH. (insert " ") (if quoted (prin1 exp byte-compile--outbuffer) (princ exp byte-compile--outbuffer)) + (setq end (point-marker)) + (set-marker-insertion-type end t) + (goto-char position) ;; Quote certain special characters as needed. ;; get_doc_string in doc.c does the unquoting. - (while (search-forward "\^A" nil t) + (while (search-forward "\^A" end t) (replace-match "\^A\^A" t t)) (goto-char position) - (while (search-forward "\000" nil t) + (while (search-forward "\000" end t) (replace-match "\^A0" t t)) (goto-char position) - (while (search-forward "\037" nil t) + (while (search-forward "\037" end t) (replace-match "\^A_" t t)) - (goto-char (point-max)) + (goto-char end) (insert "\037") (goto-char position) - (insert "#@" (format "%d" (- (position-bytes (point-max)) + (insert "#@" (format "%d" (- (position-bytes end) (position-bytes position)))) ;; Save the file position of the object. @@ -2927,7 +3007,8 @@ If QUOTED is non-nil, print with quoting; otherwise, print without quoting." ;; position to a file position. (prog1 (- (position-bytes (point)) (point-min) -1) - (goto-char (point-max)))))) + (goto-char end) + (set-marker end nil))))) (defun byte-compile--reify-function (fun) "Return an expression which will evaluate to a function value FUN. @@ -3030,6 +3111,14 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-warn-x arg "repeated variable %s in lambda-list" arg)) (t + (when (and lexical-binding + (cconv--not-lexical-var-p + arg byte-compile-bound-variables) + (byte-compile-warning-enabled-p 'lexical arg)) + (byte-compile-warn-x + arg + "Lexical argument shadows the dynamic variable %S" + arg)) (push arg vars)))) (setq list (cdr list))))) @@ -3393,92 +3482,257 @@ lambda-expression." ;; (defun byte-compile-form (form &optional for-effect) (let ((byte-compile--for-effect for-effect)) - (push form byte-compile-form-stack) - (cond - ((not (consp form)) - (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) - (byte-compile-constant form)) - ((and byte-compile--for-effect byte-compile-delete-errors) - (setq byte-compile--for-effect nil)) - (t (byte-compile-variable-ref form)))) - ((symbolp (car form)) - (let* ((fn (car form)) - (handler (get fn 'byte-compile)) - (interactive-only - (or (get fn 'interactive-only) - (memq fn byte-compile-interactive-only-functions)))) - (when (memq fn '(set symbol-value run-hooks ;; add-to-list - add-hook remove-hook run-hook-with-args - run-hook-with-args-until-success - run-hook-with-args-until-failure)) - (pcase (cdr form) - (`(',var . ,_) - (when (memq var byte-compile-lexical-variables) - (byte-compile-report-error - (format-message "%s cannot use lexical var `%s'" fn var)))))) - ;; Warn about using obsolete hooks. - (if (memq fn '(add-hook remove-hook)) - (let ((hook (car-safe (cdr form)))) - (if (eq (car-safe hook) 'quote) - (byte-compile-check-variable (cadr hook) nil)))) - (when (and (byte-compile-warning-enabled-p 'suspicious) - (macroexp--const-symbol-p fn)) - (byte-compile-warn-x fn "`%s' called as a function" fn)) - (when (and (byte-compile-warning-enabled-p 'interactive-only fn) - interactive-only) - (byte-compile-warn-x fn "`%s' is for interactive use only%s" - fn - (cond ((stringp interactive-only) - (format "; %s" - (substitute-command-keys - interactive-only))) - ((and (symbolp 'interactive-only) - (not (eq interactive-only t))) - (format-message "; use `%s' instead." - interactive-only)) - (t ".")))) - (if (eq (car-safe (symbol-function (car form))) 'macro) - (byte-compile-report-error - (format "`%s' defined after use in %S (missing `require' of a library file?)" - (car form) form))) - (if (and handler - ;; Make sure that function exists. - (and (functionp handler) - ;; Ignore obsolete byte-compile function used by former - ;; CL code to handle compiler macros (we do it - ;; differently now). - (not (eq handler 'cl-byte-compile-compiler-macro)))) - (funcall handler form) - (byte-compile-normal-call form)))) - ((and (byte-code-function-p (car form)) - (memq byte-optimize '(t lap))) - (byte-compile-unfold-bcf form)) - ((and (eq (car-safe (car form)) 'lambda) - ;; if the form comes out the same way it went in, that's - ;; because it was malformed, and we couldn't unfold it. - (not (eq form (setq form (macroexp--unfold-lambda form))))) - (byte-compile-form form byte-compile--for-effect) - (setq byte-compile--for-effect nil)) - ((byte-compile-normal-call form))) - (if byte-compile--for-effect - (byte-compile-discard)) - (pop byte-compile-form-stack))) + (macroexp--with-extended-form-stack form + (cond + ((not (consp form)) + (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) + (byte-compile-constant form)) + ((and byte-compile--for-effect byte-compile-delete-errors) + (setq byte-compile--for-effect nil)) + (t (byte-compile-variable-ref form)))) + ((symbolp (car form)) + (let* ((fn (car form)) + (handler (get fn 'byte-compile)) + (interactive-only + (or (function-get fn 'interactive-only) + (memq fn byte-compile-interactive-only-functions)))) + (when (memq fn '(set symbol-value run-hooks ;; add-to-list + add-hook remove-hook run-hook-with-args + run-hook-with-args-until-success + run-hook-with-args-until-failure)) + (pcase (cdr form) + (`(',var . ,_) + (when (and (memq var byte-compile-lexical-variables) + (byte-compile-warning-enabled-p 'lexical var)) + (byte-compile-warn + (format-message "%s cannot use lexical var `%s'" fn var)))))) + ;; Warn about using obsolete hooks. + (if (memq fn '(add-hook remove-hook)) + (let ((hook (car-safe (cdr form)))) + (if (eq (car-safe hook) 'quote) + (byte-compile-check-variable (cadr hook) nil)))) + (when (and (byte-compile-warning-enabled-p 'suspicious) + (macroexp--const-symbol-p fn)) + (byte-compile-warn-x fn "`%s' called as a function" fn)) + (when (and (byte-compile-warning-enabled-p 'interactive-only fn) + interactive-only) + (byte-compile-warn-x fn "`%s' is for interactive use only%s" + fn + (cond ((stringp interactive-only) + (format "; %s" + (substitute-command-keys + interactive-only))) + ((and (symbolp interactive-only) + (not (eq interactive-only t))) + (format-message "; use `%s' instead." + interactive-only)) + (t ".")))) + (let ((mutargs (function-get (car form) 'mutates-arguments))) + (when mutargs + (dolist (idx (if (eq mutargs 'all-but-last) + (number-sequence 1 (- (length form) 2)) + mutargs)) + (let ((arg (nth idx form))) + (when (and (or (and (eq (car-safe arg) 'quote) + (consp (nth 1 arg))) + (arrayp arg)) + (byte-compile-warning-enabled-p + 'mutate-constant (car form))) + (byte-compile-warn-x form "`%s' on constant %s (arg %d)" + (car form) + (if (consp arg) "list" (type-of arg)) + idx)))))) + + (let ((funargs (function-get (car form) 'funarg-positions))) + (dolist (funarg funargs) + (let ((arg (if (numberp funarg) + (nth funarg form) + (cadr (memq funarg form))))) + (when (and (eq 'quote (car-safe arg)) + (eq 'lambda (car-safe (cadr arg)))) + (byte-compile-warn-x + arg "(lambda %s ...) quoted with %s rather than with #%s" + (or (nth 1 (cadr arg)) "()") + "'" "'"))))) ; avoid styled quotes + + (if (eq (car-safe (symbol-function (car form))) 'macro) + (byte-compile-report-error + (format-message "`%s' defined after use in %S (missing `require' of a library file?)" + (car form) form))) + + (when byte-compile--for-effect + (let ((sef (function-get (car form) 'side-effect-free))) + (cond + ((and sef (or (eq sef 'error-free) + byte-compile-delete-errors)) + ;; This transform is normally done in the Lisp optimizer, + ;; so maybe we don't need to bother about it here? + (setq form (cons 'progn (cdr form))) + (setq handler #'byte-compile-progn)) + ((and (or sef (function-get (car form) 'important-return-value)) + ;; Don't warn for arguments to `ignore'. + (not (eq byte-compile--for-effect 'for-effect-no-warn)) + (byte-compile-warning-enabled-p + 'ignored-return-value (car form))) + (byte-compile-warn-x + (car form) + "value from call to `%s' is unused%s" + (car form) + (cond ((eq (car form) 'mapcar) + "; use `mapc' or `dolist' instead") + (t ""))))))) + + (if (and handler + ;; Make sure that function exists. + (and (functionp handler) + ;; Ignore obsolete byte-compile function used by former + ;; CL code to handle compiler macros (we do it + ;; differently now). + (not (eq handler 'cl-byte-compile-compiler-macro)))) + (funcall handler form) + (byte-compile-normal-call form)))) + ((and (byte-code-function-p (car form)) + (memq byte-optimize '(t lap))) + (byte-compile-unfold-bcf form)) + ((byte-compile-normal-call form))) + (if byte-compile--for-effect + (byte-compile-discard))))) + +(let ((important-return-value-fns + '( + ;; These functions are side-effect-free except for the + ;; behavior of functions passed as argument. + mapcar mapcan mapconcat + assoc plist-get plist-member + + ;; It's safe to ignore the value of `sort' and `nreverse' + ;; when used on arrays, but most calls pass lists. + nreverse sort + + match-data + + ;; Warning about these functions causes some false positives that are + ;; laborious to eliminate; see bug#61730. + ;;delq delete + ;;nconc plist-put + ))) + (dolist (fn important-return-value-fns) + (put fn 'important-return-value t))) + +(let ((mutating-fns + ;; FIXME: Should there be a function declaration for this? + ;; + ;; (FUNC . ARGS) means that FUNC mutates arguments whose indices are + ;; in the list ARGS, starting at 1, or all but the last argument if + ;; ARGS is `all-but-last'. + '( + (setcar 1) (setcdr 1) (aset 1) + (nreverse 1) + (nconc . all-but-last) + (nbutlast 1) (ntake 2) + (sort 1) + (delq 2) (delete 2) + (delete-dups 1) (delete-consecutive-dups 1) + (plist-put 1) + (assoc-delete-all 2) (assq-delete-all 2) (rassq-delete-all 2) + (fillarray 1) + (store-substring 1) + (clear-string 1) + + (add-text-properties 4) (put-text-property 5) (set-text-properties 4) + (remove-text-properties 4) (remove-list-of-text-properties 4) + (alter-text-property 5) + (add-face-text-property 5) (add-display-text-property 5) + + (cl-delete 2) (cl-delete-if 2) (cl-delete-if-not 2) + (cl-delete-duplicates 1) + (cl-nsubst 3) (cl-nsubst-if 3) (cl-nsubst-if-not 3) + (cl-nsubstitute 3) (cl-nsubstitute-if 3) (cl-nsubstitute-if-not 3) + (cl-nsublis 2) + (cl-nunion 1 2) (cl-nintersection 1 2) (cl-nset-difference 1 2) + (cl-nset-exclusive-or 1 2) + (cl-nreconc 1) + (cl-sort 1) (cl-stable-sort 1) (cl-merge 2 3) + ))) + (dolist (entry mutating-fns) + (put (car entry) 'mutates-arguments (cdr entry)))) + +;; Record which arguments expect functions, so we can warn when those +;; are accidentally quoted with ' rather than with #' +;; The value of the `funarg-positions' property is a list of function +;; argument positions, starting with 1, and keywords. +(dolist (f '( funcall apply mapcar mapatoms mapconcat mapc maphash + mapcan map-char-table map-keymap map-keymap-internal + functionp + seq-do seq-do-indexed seq-sort seq-sort-by seq-group-by + seq-find seq-count + seq-filter seq-reduce seq-remove seq-keep + seq-map seq-map-indexed seq-mapn seq-mapcat + seq-drop-while seq-take-while + seq-some seq-every-p + cl-every cl-some + cl-mapcar cl-mapcan cl-mapcon cl-mapc cl-mapl cl-maplist + )) + (put f 'funarg-positions '(1))) +(dolist (f '( defalias fset sort + replace-regexp-in-string + add-hook remove-hook advice-remove advice--remove-function + global-set-key local-set-key keymap-global-set keymap-local-set + set-process-filter set-process-sentinel + )) + (put f 'funarg-positions '(2))) +(dolist (f '( assoc assoc-default assoc-delete-all + plist-get plist-member + advice-add define-key keymap-set + run-at-time run-with-idle-timer run-with-timer + seq-contains seq-contains-p seq-set-equal-p + seq-position seq-positions seq-uniq + seq-union seq-intersection seq-difference)) + (put f 'funarg-positions '(3))) +(dolist (f '( cl-find cl-member cl-assoc cl-rassoc cl-position cl-count + cl-remove cl-delete + cl-subst cl-nsubst + cl-substitute cl-nsubstitute + cl-remove-duplicates cl-delete-duplicates + cl-union cl-nunion cl-intersection cl-nintersection + cl-set-difference cl-nset-difference + cl-set-exclusive-or cl-nset-exclusive-or + cl-nsublis + cl-search + )) + (put f 'funarg-positions '(:test :test-not :key))) +(dolist (f '( cl-find-if cl-find-if-not cl-member-if cl-member-if-not + cl-assoc-if cl-assoc-if-not cl-rassoc-if cl-rassoc-if-not + cl-position-if cl-position-if-not cl-count-if cl-count-if-not + cl-remove-if cl-remove-if-not cl-delete-if cl-delete-if-not + cl-reduce cl-adjoin + cl-subsetp + )) + (put f 'funarg-positions '(1 :key))) +(dolist (f '( cl-subst-if cl-subst-if-not cl-nsubst-if cl-nsubst-if-not + cl-substitute-if cl-substitute-if-not + cl-nsubstitute-if cl-nsubstitute-if-not + cl-sort cl-stable-sort + )) + (put f 'funarg-positions '(2 :key))) +(dolist (fa '((plist-put 4) (alist-get 5) (add-to-list 5) + (cl-merge 4 :key) + (custom-declare-variable :set :get :initialize :safe) + (make-process :filter :sentinel) + (make-network-process :filter :sentinel) + (all-completions 2 3) (try-completion 2 3) (test-completion 2 3) + (completing-read 2 3) + )) + (put (car fa) 'funarg-positions (cdr fa))) + (defun byte-compile-normal-call (form) (when (and (symbolp (car form)) (byte-compile-warning-enabled-p 'callargs (car form))) - (if (memq (car form) - '(custom-declare-group custom-declare-variable - custom-declare-face)) - (byte-compile-nogroup-warn form)) (byte-compile-callargs-warn form)) (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) - (when (and byte-compile--for-effect (eq (car form) 'mapcar) - (byte-compile-warning-enabled-p 'mapcar 'mapcar)) - (byte-compile-warn-x - (car form) - "`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)))) @@ -3736,7 +3990,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" '((0 . byte-compile-no-args) (1 . byte-compile-one-arg) (2 . byte-compile-two-args) - (2-and . byte-compile-and-folded) + (2-cmp . byte-compile-cmp) (3 . byte-compile-three-args) (0-1 . byte-compile-zero-or-one-arg) (1-2 . byte-compile-one-or-two-args) @@ -3815,11 +4069,12 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler cons 2) (byte-defop-compiler aref 2) (byte-defop-compiler set 2) -(byte-defop-compiler (= byte-eqlsign) 2-and) -(byte-defop-compiler (< byte-lss) 2-and) -(byte-defop-compiler (> byte-gtr) 2-and) -(byte-defop-compiler (<= byte-leq) 2-and) -(byte-defop-compiler (>= byte-geq) 2-and) +(byte-defop-compiler fset 2) +(byte-defop-compiler (= byte-eqlsign) 2-cmp) +(byte-defop-compiler (< byte-lss) 2-cmp) +(byte-defop-compiler (> byte-gtr) 2-cmp) +(byte-defop-compiler (<= byte-leq) 2-cmp) +(byte-defop-compiler (>= byte-geq) 2-cmp) (byte-defop-compiler get 2) (byte-defop-compiler nth 2) (byte-defop-compiler substring 1-3) @@ -3883,18 +4138,20 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-compile-form (nth 2 form)) (byte-compile-out (get (car form) 'byte-opcode) 0))) -(defun byte-compile-and-folded (form) - "Compile calls to functions like `<='. -These implicitly `and' together a bunch of two-arg bytecodes." - (let ((l (length form))) - (cond - ((< l 3) (byte-compile-form `(progn ,(nth 1 form) t))) - ((= l 3) (byte-compile-two-args form)) - ;; Don't use `cl-every' here (see comment where we require cl-lib). - ((not (memq nil (mapcar #'macroexp-copyable-p (nthcdr 2 form)))) - (byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form)) - (,(car form) ,@(nthcdr 2 form))))) - (t (byte-compile-normal-call form))))) +(defun byte-compile-cmp (form) + "Compile calls to numeric comparisons such as `<', `=' etc." + ;; Lisp-level transforms should already have reduced valid calls to 2 args. + (if (not (= (length form) 3)) + (byte-compile-subr-wrong-args form "1 or more") + (byte-compile-two-args + (if (macroexp-const-p (nth 1 form)) + ;; First argument is constant: flip it so that the constant + ;; is last, which may allow more lapcode optimizations. + (let* ((op (car form)) + (flipped-op (cdr (assq op '((< . >) (<= . >=) + (> . <) (>= . <=) (= . =)))))) + (list flipped-op (nth 2 form) (nth 1 form))) + form)))) (defun byte-compile-three-args (form) (if (not (= (length form) 4)) @@ -4049,9 +4306,15 @@ This function is never called when `lexical-binding' is nil." (byte-compile-constant 1) (byte-compile-out (get '* 'byte-opcode) 0)) (3 - (byte-compile-form (nth 1 form)) - (byte-compile-form (nth 2 form)) - (byte-compile-out (get (car form) 'byte-opcode) 0)) + (let ((arg1 (nth 1 form)) + (arg2 (nth 2 form))) + (when (and (memq (car form) '(+ *)) + (macroexp-const-p arg1)) + ;; Put constant argument last for better LAP optimization. + (cl-rotatef arg1 arg2)) + (byte-compile-form arg1) + (byte-compile-form arg2) + (byte-compile-out (get (car form) 'byte-opcode) 0))) (_ ;; >2 args: compile as a single function call. (byte-compile-normal-call form)))) @@ -4066,12 +4329,8 @@ This function is never called when `lexical-binding' is nil." ;; more complicated compiler macros -(byte-defop-compiler char-before) -(byte-defop-compiler backward-char) -(byte-defop-compiler backward-word) (byte-defop-compiler list) (byte-defop-compiler concat) -(byte-defop-compiler fset) (byte-defop-compiler (indent-to-column byte-indent-to) byte-compile-indent-to) (byte-defop-compiler indent-to) (byte-defop-compiler insert) @@ -4080,40 +4339,6 @@ This function is never called when `lexical-binding' is nil." (byte-defop-compiler (/ byte-quo) byte-compile-quo) (byte-defop-compiler nconc) -;; Is this worth it? Both -before and -after are written in C. -(defun byte-compile-char-before (form) - (cond ((or (= 1 (length form)) - (and (= 2 (length form)) (not (nth 1 form)))) - (byte-compile-form '(char-after (1- (point))))) - ((= 2 (length form)) - (byte-compile-form (list 'char-after (if (numberp (nth 1 form)) - (1- (nth 1 form)) - `(1- (or ,(nth 1 form) - (point))))))) - (t (byte-compile-subr-wrong-args form "0-1")))) - -;; backward-... ==> forward-... with negated argument. -;; Is this worth it? Both -backward and -forward are written in C. -(defun byte-compile-backward-char (form) - (cond ((or (= 1 (length form)) - (and (= 2 (length form)) (not (nth 1 form)))) - (byte-compile-form '(forward-char -1))) - ((= 2 (length form)) - (byte-compile-form (list 'forward-char (if (numberp (nth 1 form)) - (- (nth 1 form)) - `(- (or ,(nth 1 form) 1)))))) - (t (byte-compile-subr-wrong-args form "0-1")))) - -(defun byte-compile-backward-word (form) - (cond ((or (= 1 (length form)) - (and (= 2 (length form)) (not (nth 1 form)))) - (byte-compile-form '(forward-word -1))) - ((= 2 (length form)) - (byte-compile-form (list 'forward-word (if (numberp (nth 1 form)) - (- (nth 1 form)) - `(- (or ,(nth 1 form) 1)))))) - (t (byte-compile-subr-wrong-args form "0-1")))) - (defun byte-compile-list (form) (let ((count (length (cdr form)))) (cond ((= count 0) @@ -4168,26 +4393,6 @@ This function is never called when `lexical-binding' is nil." (byte-compile-form (car form)) (byte-compile-out 'byte-nconc 0)))))) -(defun byte-compile-fset (form) - ;; warn about forms like (fset 'foo '(lambda () ...)) - ;; (where the lambda expression is non-trivial...) - (let ((fn (nth 2 form)) - body) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (setq fn (nth 1 fn))) 'lambda)) - (progn - (setq body (cdr (cdr fn))) - (if (stringp (car body)) (setq body (cdr body))) - (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) - (if (and (consp (car body)) - (not (eq 'byte-code (car (car body))))) - (byte-compile-warn-x - (nth 2 form) - "A quoted lambda form is the second argument of `fset'. This is probably - not what you want, as that lambda cannot be compiled. Consider using - the syntax #'(lambda (...) ...) instead."))))) - (byte-compile-two-args form)) - ;; (function foo) must compile like 'foo, not like (symbol-function 'foo). ;; Otherwise it will be incompatible with the interpreter, ;; and (funcall (function foo)) will lose with autoloads. @@ -4310,7 +4515,8 @@ This function is never called when `lexical-binding' is nil." (defun byte-compile-ignore (form) (dolist (arg (cdr form)) - (byte-compile-form arg t)) + ;; Compile each argument for-effect but suppress unused-value warnings. + (byte-compile-form arg 'for-effect-no-warn)) (byte-compile-form nil)) ;; Return the list of items in CONDITION-PARAM that match PRED-LIST. @@ -4571,6 +4777,7 @@ Return (TAIL VAR TEST CASES), where: (if switch-prefix (progn (byte-compile-cond-jump-table (cdr switch-prefix) donetag) + (setq clause nil) (setq clauses (car switch-prefix))) (setq clause (car clauses)) (cond ((or (eq (car clause) t) @@ -4835,6 +5042,15 @@ binding slots have been popped." (dolist (clause (reverse clauses)) (let ((condition (nth 1 clause))) + (when (and (eq (car-safe condition) 'quote) + (cdr condition) (null (cddr condition))) + (byte-compile-warn-x + condition "`condition-case' condition should not be quoted: %S" + condition)) + (when (and (consp condition) (memq :success condition)) + (byte-compile-warn-x + condition + "`:success' must be the first element of a `condition-case' handler")) (unless (consp condition) (setq condition (list condition))) (dolist (c condition) (unless (and c (symbolp c)) @@ -5055,7 +5271,10 @@ binding slots have been popped." (defun byte-compile-suppressed-warnings (form) (let ((byte-compile--suppressed-warnings (append (cadadr form) byte-compile--suppressed-warnings))) - (byte-compile-form (macroexp-progn (cddr form))))) + ;; Propagate the for-effect mode explicitly so that warnings about + ;; ignored return values can be detected and suppressed correctly. + (byte-compile-form (macroexp-progn (cddr form)) byte-compile--for-effect) + (setq byte-compile--for-effect nil))) ;; Warn about misuses of make-variable-buffer-local. (byte-defop-compiler-1 make-variable-buffer-local @@ -5080,6 +5299,194 @@ binding slots have been popped." (pcase form (`(,_ ',var) (byte-compile--declare-var var))) (byte-compile-normal-call form)) +;; Warn about mistakes in `defcustom', `defface', `defgroup', `define-widget' + +(defvar bytecomp--cus-function) +(defvar bytecomp--cus-name) + +(defun bytecomp--cus-warn (form format &rest args) + "Emit a warning about a `defcustom' type. +FORM is used to provide location, `bytecomp--cus-function' and +`bytecomp--cus-name' for context." + (let* ((actual-fun (or (cdr (assq bytecomp--cus-function + '((custom-declare-group . defgroup) + (custom-declare-face . defface) + (custom-declare-variable . defcustom)))) + bytecomp--cus-function)) + (prefix (format "in %s%s: " + actual-fun + (if bytecomp--cus-name + (format " for `%s'" bytecomp--cus-name) + "")))) + (apply #'byte-compile-warn-x form (concat prefix format) args))) + +(defun bytecomp--check-cus-type (type) + "Warn about common mistakes in the `defcustom' type TYPE." + (let ((invalid-types + '( + ;; Lisp type predicates, often confused with customization types: + functionp numberp integerp fixnump natnump floatp booleanp + characterp listp stringp consp vectorp symbolp keywordp + hash-table-p facep + ;; other mistakes occasionally seen (oh yes): + or and nil t + interger intger lits bool boolen constant filename + kbd any list-of auto + ;; from botched backquoting + \, \,@ \` + ))) + (cond + ((consp type) + (let* ((head (car type)) + (tail (cdr type))) + (while (and (keywordp (car tail)) (cdr tail)) + (setq tail (cddr tail))) + (cond + ((plist-member (cdr type) :convert-widget) nil) + ((let ((tl tail)) + (and (not (keywordp (car tail))) + (progn + (while (and tl (not (keywordp (car tl)))) + (setq tl (cdr tl))) + (and tl + (progn + (bytecomp--cus-warn + tl "misplaced %s keyword in `%s' type" (car tl) head) + t)))))) + ((memq head '(choice radio)) + (unless tail + (bytecomp--cus-warn type "`%s' without any types inside" head)) + (let ((clauses tail) + (constants nil) + (tags nil)) + (while clauses + (let* ((ty (car clauses)) + (ty-head (car-safe ty))) + (when (and (eq ty-head 'other) (cdr clauses)) + (bytecomp--cus-warn ty "`other' not last in `%s'" head)) + (when (memq ty-head '(const other)) + (let ((ty-tail (cdr ty)) + (val nil)) + (while (and (keywordp (car ty-tail)) (cdr ty-tail)) + (when (eq (car ty-tail) :value) + (setq val (cadr ty-tail))) + (setq ty-tail (cddr ty-tail))) + (when ty-tail + (setq val (car ty-tail))) + (when (member val constants) + (bytecomp--cus-warn + ty "duplicated value in `%s': `%S'" head val)) + (push val constants))) + (let ((tag (and (consp ty) (plist-get (cdr ty) :tag)))) + (when (stringp tag) + (when (member tag tags) + (bytecomp--cus-warn + ty "duplicated :tag string in `%s': %S" head tag)) + (push tag tags))) + (bytecomp--check-cus-type ty)) + (setq clauses (cdr clauses))))) + ((eq head 'cons) + (unless (= (length tail) 2) + (bytecomp--cus-warn + type "`cons' requires 2 type specs, found %d" (length tail))) + (dolist (ty tail) + (bytecomp--check-cus-type ty))) + ((memq head '(list group vector set repeat)) + (unless tail + (bytecomp--cus-warn type "`%s' without type specs" head)) + (dolist (ty tail) + (bytecomp--check-cus-type ty))) + ((memq head '(alist plist)) + (let ((key-tag (memq :key-type (cdr type))) + (value-tag (memq :value-type (cdr type)))) + (when key-tag + (bytecomp--check-cus-type (cadr key-tag))) + (when value-tag + (bytecomp--check-cus-type (cadr value-tag))))) + ((memq head '(const other)) + (let* ((value-tag (memq :value (cdr type))) + (n (length tail)) + (val (car tail))) + (cond + ((or (> n 1) (and value-tag tail)) + (bytecomp--cus-warn type "`%s' with too many values" head)) + (value-tag + (setq val (cadr value-tag))) + ;; ;; This is a useful check but it results in perhaps + ;; ;; a bit too many complaints. + ;; ((null tail) + ;; (bytecomp--cus-warn + ;; type "`%s' without value is implicitly nil" head)) + ) + (when (memq (car-safe val) '(quote function)) + (bytecomp--cus-warn type "`%s' with quoted value: %S" head val)))) + ((eq head 'quote) + (bytecomp--cus-warn type "type should not be quoted: %s" (cadr type))) + ((memq head invalid-types) + (bytecomp--cus-warn type "`%s' is not a valid type" head)) + ((or (not (symbolp head)) (keywordp head)) + (bytecomp--cus-warn type "irregular type `%S'" head)) + ))) + ((or (not (symbolp type)) (keywordp type)) + (bytecomp--cus-warn type "irregular type `%S'" type)) + ((memq type '( list cons group vector choice radio const other + function-item variable-item set repeat restricted-sexp)) + (bytecomp--cus-warn type "`%s' without arguments" type)) + ((memq type invalid-types) + (bytecomp--cus-warn type "`%s' is not a valid type" type)) + ))) + +;; Unified handler for multiple functions with similar arguments: +;; (NAME SOMETHING DOC KEYWORD-ARGS...) +(byte-defop-compiler-1 define-widget bytecomp--custom-declare) +(byte-defop-compiler-1 custom-declare-group bytecomp--custom-declare) +(byte-defop-compiler-1 custom-declare-face bytecomp--custom-declare) +(byte-defop-compiler-1 custom-declare-variable bytecomp--custom-declare) +(defun bytecomp--custom-declare (form) + (when (>= (length form) 4) + (let* ((name-arg (nth 1 form)) + (name (and (eq (car-safe name-arg) 'quote) + (symbolp (nth 1 name-arg)) + (nth 1 name-arg))) + (keyword-args (nthcdr 4 form)) + (fun (car form)) + (bytecomp--cus-function fun) + (bytecomp--cus-name name)) + + ;; Check :type + (when (memq fun '(custom-declare-variable define-widget)) + (let ((type-tag (memq :type keyword-args))) + (if (null type-tag) + ;; :type only mandatory for `defcustom' + (when (eq fun 'custom-declare-variable) + (bytecomp--cus-warn form "missing :type keyword parameter")) + (let ((dup-type (memq :type (cdr type-tag)))) + (when dup-type + (bytecomp--cus-warn + dup-type "duplicated :type keyword argument"))) + (let ((type-arg (cadr type-tag))) + (when (or (null type-arg) + (eq (car-safe type-arg) 'quote)) + (bytecomp--check-cus-type (cadr type-arg))))))) + + ;; Check :group + (when (cond + ((memq fun '(custom-declare-variable custom-declare-face)) + (not byte-compile-current-group)) + ((eq fun 'custom-declare-group) + (not (eq name 'emacs)))) + (unless (plist-get keyword-args :group) + (bytecomp--cus-warn form "fails to specify containing group"))) + + ;; Update current group + (when (and name + byte-compile-current-file ; only when compiling a whole file + (eq fun 'custom-declare-group)) + (setq byte-compile-current-group name)))) + + (byte-compile-normal-call form)) + + (put 'function-put 'byte-hunk-handler 'byte-compile-define-symbol-prop) (put 'define-symbol-prop 'byte-hunk-handler 'byte-compile-define-symbol-prop) (defun byte-compile-define-symbol-prop (form) @@ -5487,6 +5894,173 @@ and corresponding effects." (eval form) form))) +;; Check for (in)comparable constant values in calls to `eq', `memq' etc. + +(defun bytecomp--dodgy-eq-arg-p (x number-ok) + "Whether X is a bad argument to `eq' (or `eql' if NUMBER-OK is non-nil)." + (pcase x + ((or `(quote ,(pred consp)) `(function (lambda . ,_))) t) + ((or (pred consp) (pred symbolp)) nil) + ((pred integerp) + (not (or (<= -536870912 x 536870911) number-ok))) + ((pred floatp) (not number-ok)) + (_ t))) + +(defun bytecomp--value-type-description (x) + (cond + ((proper-list-p x) "list") + ((recordp x) "record") + (t (symbol-name (type-of x))))) + +(defun bytecomp--arg-type-description (x) + (pcase x + (`(function (lambda . ,_)) "function") + (`(quote . ,val) (bytecomp--value-type-description val)) + (_ (bytecomp--value-type-description x)))) + +(defun bytecomp--warn-dodgy-eq-arg (form type parenthesis) + (macroexp-warn-and-return + (format-message "`%s' called with literal %s that may never match (%s)" + (car form) type parenthesis) + form (list 'suspicious (car form)) t)) + +(defun bytecomp--check-eq-args (form &optional a b &rest _ignore) + (let* ((number-ok (eq (car form) 'eql)) + (bad-arg (cond ((bytecomp--dodgy-eq-arg-p a number-ok) 1) + ((bytecomp--dodgy-eq-arg-p b number-ok) 2)))) + (if bad-arg + (bytecomp--warn-dodgy-eq-arg + form + (bytecomp--arg-type-description (nth bad-arg form)) + (format "arg %d" bad-arg)) + form))) + +(put 'eq 'compiler-macro #'bytecomp--check-eq-args) +(put 'eql 'compiler-macro #'bytecomp--check-eq-args) + +(defun bytecomp--check-memq-args (form &optional elem list &rest _ignore) + (let* ((fn (car form)) + (number-ok (eq fn 'memql))) + (cond + ((bytecomp--dodgy-eq-arg-p elem number-ok) + (bytecomp--warn-dodgy-eq-arg + form (bytecomp--arg-type-description elem) "arg 1")) + ((and (consp list) (eq (car list) 'quote) + (proper-list-p (cadr list))) + (named-let loop ((elts (cadr list)) (i 1)) + (if elts + (let* ((elt (car elts)) + (x (cond ((eq fn 'assq) (car-safe elt)) + ((eq fn 'rassq) (cdr-safe elt)) + (t elt)))) + (if (or (symbolp x) + (and (integerp x) + (or (<= -536870912 x 536870911) number-ok)) + (and (floatp x) number-ok)) + (loop (cdr elts) (1+ i)) + (bytecomp--warn-dodgy-eq-arg + form (bytecomp--value-type-description x) + (format "element %d of arg 2" i)))) + form))) + (t form)))) + +(put 'memq 'compiler-macro #'bytecomp--check-memq-args) +(put 'memql 'compiler-macro #'bytecomp--check-memq-args) +(put 'assq 'compiler-macro #'bytecomp--check-memq-args) +(put 'rassq 'compiler-macro #'bytecomp--check-memq-args) +(put 'remq 'compiler-macro #'bytecomp--check-memq-args) +(put 'delq 'compiler-macro #'bytecomp--check-memq-args) + +;; Implement `char-before', `backward-char' and `backward-word' in +;; terms of `char-after', `forward-char' and `forward-word' which have +;; their own byte-ops. + +(put 'char-before 'compiler-macro #'bytecomp--char-before) +(defun bytecomp--char-before (form &optional arg &rest junk-args) + (if junk-args + form ; arity error + `(char-after (1- (or ,arg (point)))))) + +(put 'backward-char 'compiler-macro #'bytecomp--backward-char) +(defun bytecomp--backward-char (form &optional arg &rest junk-args) + (if junk-args + form ; arity error + `(forward-char (- (or ,arg 1))))) + +(put 'backward-word 'compiler-macro #'bytecomp--backward-word) +(defun bytecomp--backward-word (form &optional arg &rest junk-args) + (if junk-args + form ; arity error + `(forward-word (- (or ,arg 1))))) + +(defun bytecomp--check-keyword-args (form arglist allowed-keys required-keys) + (let ((fun (car form))) + (cl-flet ((missing (form keyword) + (byte-compile-warn-x + form + "`%S´ called without required keyword argument %S" + fun keyword)) + (unrecognized (form keyword) + (byte-compile-warn-x + form + "`%S´ called with unknown keyword argument %S" + fun keyword)) + (duplicate (form keyword) + (byte-compile-warn-x + form + "`%S´ called with repeated keyword argument %S" + fun keyword)) + (missing-val (form keyword) + (byte-compile-warn-x + form + "missing value for keyword argument %S" + keyword))) + (let* ((seen '()) + (l arglist)) + (while (consp l) + (let ((key (car l))) + (cond ((and (keywordp key) (memq key allowed-keys)) + (cond ((memq key seen) + (duplicate l key)) + (t + (push key seen)))) + (t (unrecognized l key))) + (when (null (cdr l)) + (missing-val l key))) + (setq l (cddr l))) + (dolist (key required-keys) + (unless (memq key seen) + (missing form key)))))) + form) + +(put 'make-process 'compiler-macro + #'(lambda (form &rest args) + (bytecomp--check-keyword-args + form args + '(:name + :buffer :command :coding :noquery :stop :connection-type + :filter :sentinel :stderr :file-handler) + '(:name :command)))) + +(put 'make-pipe-process 'compiler-macro + #'(lambda (form &rest args) + (bytecomp--check-keyword-args + form args + '(:name :buffer :coding :noquery :stop :filter :sentinel) + '(:name)))) + +(put 'make-network-process 'compiler-macro + #'(lambda (form &rest args) + (bytecomp--check-keyword-args + form args + '(:name + :buffer :host :service :type :family :local :remote :coding + :nowait :noquery :stop :filter :filter-multibyte :sentinel + :log :plist :tls-parameters :server :broadcast :dontroute + :keepalive :linger :oobinline :priority :reuseaddr :bindtodevice + :use-external-socket) + '(:name :service)))) + (provide 'byte-compile) (provide 'bytecomp) |