summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
authorAlan Mackenzie <acm@muc.de>2021-11-29 11:19:31 +0000
committerAlan Mackenzie <acm@muc.de>2021-11-29 11:19:31 +0000
commit368570b3fd09d03ac5b9276d1ca85ae813c3f385 (patch)
tree4d81fdc1a866120157147226c35597073592722d /lisp/emacs-lisp
parent9721dcf2754ebad28ac60a9d3152fd26e4c652c4 (diff)
downloademacs-368570b3fd09d03ac5b9276d1ca85ae813c3f385.tar.gz
emacs-368570b3fd09d03ac5b9276d1ca85ae813c3f385.tar.bz2
emacs-368570b3fd09d03ac5b9276d1ca85ae813c3f385.zip
First commit of scratch/correct-warning-pos.
This branch is intended to generate correct position information in warning and error messages from the byte compiler, and is intended thereby to fix bugs It introduces a new mechanism, the symbol with position. This is taken over from the previous git branch scratch/accurate-warning-pos which was abandoned for being too slow. The main difference in the current branch is that the symbol `nil' is never given a position, thus speeding up NILP markedly. * lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand) (byte-optimize-form-code-walker, byte-optimize-let-form, byte-optimize-while) (byte-optimize-apply): Use byte-compile-warn-x in place of byte-compile-warn. * lisp/emacs-lisp/bytecomp.el (byte-compile--form-stack): New variable. (byte-compile-strip-s-p-1, byte-compile-strip-symbol-positions): New functions. (byte-compile-recurse-toplevel, byte-compile-initial-macro-environment) (byte-compile-preprocess, byte-compile-macroexpand-declare-function): Bind print-symbols-bare to non-nil. (byte-compile--first-symbol, byte-compile--warning-source-offset): New functions. (byte-compile-warning-prefix): Modify to output two sets of position information, the old (incorrect) set and the new set. (byte-compile-warn): Strip positions from symbols before outputting. (byte-compile-warn-x): New function which outputs a correct position supplied in an argument. (byte-compile-warn-obsolete, byte-compile-emit-callargs-warn) (byte-compile-format-warn, byte-compile-nogroup-warn) (byte-compile-arglist-warn, byte-compile-docstring-length-warn) (byte-compile-warn-about-unresolved-functions, byte-compile-file) (byte-compile--check-prefixed-var, byte-compile--declare-var) (byte-compile-file-form-defvar-function, byte-compile-file-form-defmumble) (byte-compile-check-lambda-list, byte-compile--warn-lexical-dynamic) (byte-compile-lambda, byte-compile-form, byte-compile-normal-call) (byte-compile-check-variable, byte-compile-free-vars-warn) (byte-compile-subr-wrong-args, byte-compile-fset, byte-compile-set-default) (byte-compile-condition-case, byte-compile-save-excursion) (byte-compile-defvar, byte-compile-autoload) (byte-compile-make-variable-buffer-local, byte-compile-define-symbol-prop) (byte-compile-define-keymap): Replace byte-compile-warn with byte-compile-warn-x. (byte-compile-file, compile-defun): Bind symbols-with-pos-enabled to non-nil. (compile-defun, byte-compile-from-buffer): Use `read-positioning-symbols' rather than plain `read'. (byte-compile-toplevel-file-form, byte-compile-form): Dynamically bind byte-compile--form-stack. (byte-compile-file-form-autoload, byte-compile-file-form-defvar) (byte-compile-file-form-make-obsolete, byte-compile-lambda) (byte-compile-push-constant, byte-compile-cond-jump-table) (byte-compile-define-keymap, byte-compile-annotate-call-tree): Strip positions from symbols where they are unwanted. (byte-compile-file-form-defvar): Strip positions from symbols using `bare-symbol'. (byte-compile-file-form-defmumble): New variable bare-name, a version of name without its position. (byte-compile-lambda): Similarly, new variable bare-arglist. (byte-compile-free-vars-warn): New argument arg supplying position information to byte-compile-warn-x. (byte-compile-push-constant): Manipulation of symbol positions. (display-call-tree): Strip positions from symbols. * lisp/emacs-lisp/cconv.el (cconv-convert, cconv--analyze-use) (cconv--analyze-function, cconv-analyze-form): Replace use of byte-compile-warn with byte-compile-warn-x. * lisp/emacs-lisp/cl-generic.el (cl-defmethod): New variable org-name which will supply position information to a new macroexp-warn-and-return. * lisp/emacs-lisp/cl-macs.el (cl-macs--strip-s-p-1) (cl-macs--strip-symbol-positions): New functions to strip positions from symbols in an expression. These duplicaate similarly named functions in bytecomp.el. * lisp/emacs-lisp/macroexpand.el (macroexp--warn-wrap): Calls byte-compile-warn-x in place of byte-compile-warn. (macroexp-warn-and-return): Commented out new position parameter _arg. * src/.gdbinit: Add in code to handle symbols with position. * src/alloc.c (XPNTR, set_symbol_name, valid_lisp_object_p, purecopy) (mark_char_table, mark_object, survives_gc_p, symbol_uses_obj): Use BARE_SYMBOL_P and XBARE_SYMBOL in place of the former SYMBOLP and XSYMBOL. (build_symbol_with_pos): New function. (Fgarbage_collect): Bind Qsymbols_with_pos_enabled to nil around the call to garbage_collect. * src/data.c (Ftype_of): Add case for PVEC_SYMBOL_WITH_POS. (Fbare_symbol_p, Fsymbol_with_pos_p, Fbare_symbol, Fsymbol_with_pos_pos) (Fposition_symbol): New functions. (symbols_with_pos_enabled): New boolean variable. * src/fns.c (internal_equal, hash_lookup): Handle symbols with position. * src/keyboard.c (recursive_edit_1): Bind Qsymbols_with_pos_enabled and Qprint_symbols_bare to nil. * src/lisp.h (lisp_h_PSEUDOVECTORP): New macro. (lisp_h_BASE_EQ): New name for the former lisp_h_EQ. (lisp_h_EQ): Extended to handle symbols with position. (lisp_h_NILP): Now uses BASE_EQ rather than EQ. (lisp_h_SYMBOL_WITH_POS_P, lisp_h_BARE_SYMBOL_P): New macros. (lisp_h_SYMBOLP): Redefined to handle symbols with position. (BARE_SYMBOL_P, BASE_EQ): New macros. (SYMBOLP (macro)): Removed. (SYMBOLP (function), XSYMBOL, make_lisp_symbol, builtin_lisp_symbol) (c_symbol_p): Moved to later in file. (struct Lisp_Symbol_With_Pos): New data type. (pvec_type): PVEC_SYMBOL_WITH_POS: New type code. (PSEUDOVECTORP): Redefined to use the lisp_h_PSEUDOVECTORP. (BARE_SYMBOL_P, SYMBOL_WITH_POS_P, SYMBOLP, XSYMBOL_WITH_POS, XBARE_SYMBOL) (XSYMBOL, make_lisp_symbol, builtin_lisp_symbol, c_symbol_p, CHECK_SYMBOL) (BASE_EQ): New functions, or functions moved from earlier in the file. (SYMBOL_WITH_POS_SYM, SYMBOL_WITH_POS_POS): New INLINE functions. * src/lread.c (read0, read1, read_list, read_vector, read_internal_start) (list2): Add a new bool parameter locate_syms. (Fread_positioning_symbols): New function. (Fread_from_string, read_internal_start, read0, read1, read_list): Pass around suitable values for locate_syms. (read1): Build symbols with position when locate_syms is true. * src/print.c (print_vectorlike): Add handling for PVEC_SYMBOL_WITH_POS. (print_object): Replace EQ with BASE_EQ. (print_symbols_bare): New boolean variable.
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/byte-opt.el38
-rw-r--r--lisp/emacs-lisp/bytecomp.el476
-rw-r--r--lisp/emacs-lisp/cconv.el22
-rw-r--r--lisp/emacs-lisp/cl-generic.el4
-rw-r--r--lisp/emacs-lisp/cl-macs.el42
-rw-r--r--lisp/emacs-lisp/eieio-core.el1
-rw-r--r--lisp/emacs-lisp/eieio.el1
-rw-r--r--lisp/emacs-lisp/gv.el5
-rw-r--r--lisp/emacs-lisp/macroexp.el8
-rw-r--r--lisp/emacs-lisp/pcase.el1
10 files changed, 411 insertions, 187 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index f6db803b78e..7750f723ba0 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -264,8 +264,9 @@ Earlier variables shadow later ones with the same name.")
(cdr (assq name byte-compile-function-environment)))))
(pcase fn
('nil
- (byte-compile-warn "attempt to inline `%s' before it was defined"
- name)
+ (byte-compile-warn-x name
+ "attempt to inline `%s' before it was defined"
+ name)
form)
(`(autoload . ,_)
(error "File `%s' didn't define `%s'" (nth 1 fn) name))
@@ -417,8 +418,8 @@ for speeding up processing.")
(t form)))
(`(quote . ,v)
(if (or (not v) (cdr v))
- (byte-compile-warn "malformed quote form: `%s'"
- (prin1-to-string form)))
+ (byte-compile-warn-x form "malformed quote form: `%s'"
+ form))
;; Map (quote nil) to nil to simplify optimizer logic.
;; Map quoted constants to nil if for-effect (just because).
(and (car v)
@@ -436,8 +437,9 @@ for speeding up processing.")
(cons
(byte-optimize-form (car clause) nil)
(byte-optimize-body (cdr clause) for-effect))
- (byte-compile-warn "malformed cond form: `%s'"
- (prin1-to-string clause))
+ (byte-compile-warn-x
+ clause "malformed cond form: `%s'"
+ clause)
clause))
clauses)))
(`(progn . ,exps)
@@ -513,8 +515,7 @@ for speeding up processing.")
`(while ,condition . ,body)))
(`(interactive . ,_)
- (byte-compile-warn "misplaced interactive spec: `%s'"
- (prin1-to-string form))
+ (byte-compile-warn-x form "misplaced interactive spec: `%s'" form)
nil)
(`(function . ,_)
@@ -582,7 +583,7 @@ for speeding up processing.")
(while args
(unless (and (consp args)
(symbolp (car args)) (consp (cdr args)))
- (byte-compile-warn "malformed setq form: %S" form))
+ (byte-compile-warn-x form "malformed setq form: %S" form))
(let* ((var (car args))
(expr (cadr args))
(lexvar (assq var byte-optimize--lexvars))
@@ -615,8 +616,7 @@ for speeding up processing.")
(cons fn (mapcar #'byte-optimize-form exps)))
(`(,(pred (not symbolp)) . ,_)
- (byte-compile-warn "`%s' is a malformed function"
- (prin1-to-string fn))
+ (byte-compile-warn-x fn "`%s' is a malformed function" fn)
form)
((guard (when for-effect
@@ -624,8 +624,10 @@ for speeding up processing.")
(or byte-compile-delete-errors
(eq tmp 'error-free)
(progn
- (byte-compile-warn "value returned from %s is unused"
- (prin1-to-string form))
+ (byte-compile-warn-x
+ form
+ "value returned from %s is unused"
+ form)
nil)))))
(byte-compile-log " %s called for effect; deleted" fn)
;; appending a nil here might not be necessary, but it can't hurt.
@@ -821,7 +823,8 @@ for speeding up processing.")
(if (symbolp binding)
binding
(when (or (atom binding) (cddr binding))
- (byte-compile-warn "malformed let binding: `%S'" binding))
+ (byte-compile-warn-x
+ binding "malformed let binding: `%S'" binding))
(list (car binding)
(byte-optimize-form (nth 1 binding) nil))))
(car form))
@@ -1304,7 +1307,7 @@ See Info node `(elisp) Integer Basics'."
(defun byte-optimize-while (form)
(when (< (length form) 2)
- (byte-compile-warn "too few arguments for `while'"))
+ (byte-compile-warn-x form "too few arguments for `while'"))
(if (nth 1 form)
form))
@@ -1342,9 +1345,10 @@ See Info node `(elisp) Integer Basics'."
(let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
(nconc (list 'funcall fn) butlast
(mapcar (lambda (x) (list 'quote x)) (nth 1 last))))
- (byte-compile-warn
+ (byte-compile-warn-x
+ last
"last arg to apply can't be a literal atom: `%s'"
- (prin1-to-string last))
+ last)
nil))
form))))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 566a3fdf99c..869b6c01b8a 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -459,6 +459,42 @@ Filled in `cconv-analyze-form' but initialized and consulted here.")
(defvar byte-compiler-error-flag)
+(defvar byte-compile--form-stack nil
+ "Dynamic list of successive enclosing forms.
+This is used by the warning message routines to determine a
+source code position. The most accessible element is the current
+most deeply nested form.")
+
+(defun byte-compile-strip-s-p-1 (arg)
+ "Strip all positions from symbols in ARG, destructively modifying ARG.
+Return the modified ARG."
+ (cond
+ ((symbolp arg)
+ (bare-symbol arg))
+ ((consp arg)
+ (let ((a arg))
+ (while (consp (cdr a))
+ (setcar a (byte-compile-strip-s-p-1 (car a)))
+ (setq a (cdr a)))
+ (setcar a (byte-compile-strip-s-p-1 (car a)))
+ ;; (if (cdr a)
+ (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil.
+ (setcdr a (byte-compile-strip-s-p-1 (cdr a)))))
+ arg)
+ ((vectorp arg)
+ (let ((i 0)
+ (len (length arg)))
+ (while (< i len)
+ (aset arg i (byte-compile-strip-s-p-1 (aref arg i)))
+ (setq i (1+ i))))
+ arg)
+ (t arg)))
+
+(defun byte-compile-strip-symbol-positions (arg)
+ "Strip all positions from symbols (recursively) in ARG. Don't modify ARG."
+ (let ((arg1 (copy-tree arg t)))
+ (byte-compile-strip-s-p-1 arg1)))
+
(defun byte-compile-recurse-toplevel (form non-toplevel-case)
"Implement `eval-when-compile' and `eval-and-compile'.
Return the compile-time value of FORM."
@@ -467,7 +503,8 @@ 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.
- (setf form (macroexp-macroexpand form byte-compile-macro-environment))
+ (let ((print-symbols-bare t))
+ (setf form (macroexp-macroexpand form byte-compile-macro-environment)))
(if (eq (car-safe form) 'progn)
(cons 'progn
(mapcar (lambda (subform)
@@ -508,7 +545,8 @@ 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 ((expanded
+ (let* ((print-symbols-bare t)
+ (expanded
(macroexpand-all
form
macroexpand-all-environment)))
@@ -1212,6 +1250,41 @@ message buffer `default-directory'."
(f2 (file-relative-name file dir)))
(if (< (length f2) (length f1)) f2 f1)))
+(defun byte-compile--first-symbol (form)
+ "Return the \"first\" symbol found in form, or 0 if there is none.
+Here, \"first\" is by a depth first search."
+ (let (sym)
+ (cond
+ ((symbolp form) form)
+ ((consp form)
+ (or (and (symbolp (setq sym (byte-compile--first-symbol (car form))))
+ sym)
+ (and (symbolp (setq sym (byte-compile--first-symbol (cdr form))))
+ sym)
+ 0))
+ ((and (vectorp form)
+ (> (length form) 0))
+ (let ((i 0)
+ (len (length form))
+ elt)
+ (catch 'sym
+ (while (< i len)
+ (when (symbolp
+ (setq elt (byte-compile--first-symbol (aref form i))))
+ (throw 'sym elt))
+ (setq i (1+ i)))
+ 0)))
+ (t 0))))
+
+(defun byte-compile--warning-source-offset ()
+ "Return a source offset from `byte-compile--form-stack'.
+Return nil if such is not found."
+ (catch 'offset
+ (dolist (form byte-compile--form-stack)
+ (let ((s (byte-compile--first-symbol form)))
+ (if (symbol-with-pos-p s)
+ (throw 'offset (symbol-with-pos-pos s)))))))
+
;; This is used as warning-prefix for the compiler.
;; It is always called with the warnings buffer current.
(defun byte-compile-warning-prefix (level entry)
@@ -1229,16 +1302,36 @@ message buffer `default-directory'."
(format "%s:" (byte-compile-abbreviate-file
load-file-name dir)))
(t "")))
+ (offset (byte-compile--warning-source-offset))
(pos (if (and byte-compile-current-file
- (integerp byte-compile-read-position))
+ (integerp byte-compile-read-position)
+ (or offset (not symbols-with-pos-enabled)))
(with-current-buffer byte-compile-current-buffer
- (format "%d:%d:"
- (save-excursion
- (goto-char byte-compile-last-position)
- (1+ (count-lines (point-min) (point-at-bol))))
- (save-excursion
- (goto-char byte-compile-last-position)
- (1+ (current-column)))))
+ ;; (format "%d:%d:"
+ ;; (save-excursion
+ ;; (goto-char (if symbols-with-pos-enabled
+ ;; (+ byte-compile-read-position offset)
+ ;; byte-compile-last-position)
+ ;; )
+ ;; (1+ (count-lines (point-min) (point-at-bol))))
+ ;; (save-excursion
+ ;; (goto-char (if symbols-with-pos-enabled
+ ;; (+ byte-compile-read-position offset)
+ ;; byte-compile-last-position)
+ ;; )
+ ;; (1+ (current-column))))
+;;;; EXPERIMENTAL STOUGH, 2018-11-22
+ (let (old-l old-c new-l new-c)
+ (save-excursion
+ (goto-char byte-compile-last-position)
+ (setq old-l (1+ (count-lines (point-min) (point-at-bol)))
+ old-c (1+ (current-column)))
+ (goto-char (+ byte-compile-read-position offset))
+ (setq new-l (1+ (count-lines (point-min) (point-at-bol)))
+ new-c (1+ (current-column)))
+ (format "%d:%d:%d:%d:" old-l old-c new-l new-c)))
+;;;; END OF EXPERIMENTAL STOUGH
+ )
""))
(form (if (eq byte-compile-current-form :end) "end of data"
(or byte-compile-current-form "toplevel form"))))
@@ -1342,11 +1435,25 @@ function directly; use `byte-compile-warn' or
(defun byte-compile-warn (format &rest args)
"Issue a byte compiler warning; use (format-message FORMAT ARGS...) for message."
+ (setq args
+ (mapcar (lambda (arg)
+ (if (symbolp arg)
+ (bare-symbol arg)
+ arg))
+ args))
(setq format (apply #'format-message format args))
(if byte-compile-error-on-warn
(error "%s" format) ; byte-compile-file catches and logs it
(byte-compile-log-warning format t :warning)))
+(defun byte-compile-warn-x (arg format &rest args)
+ "Issue a byte compiler warning.
+ARG is the source element (likely a symbol with position) central to
+ the warning, intended to supply source position information.
+FORMAT and ARGS are as in `byte-compile-warn'."
+ (let ((byte-compile--form-stack (cons arg byte-compile--form-stack)))
+ (apply #'byte-compile-warn format args)))
+
(defun byte-compile-warn-obsolete (symbol)
"Warn that SYMBOL (a variable or function) is obsolete."
(when (byte-compile-warning-enabled-p 'obsolete symbol)
@@ -1356,7 +1463,7 @@ function directly; use `byte-compile-warn' or
(or funcp (get symbol 'byte-obsolete-variable))
(if funcp "function" "variable"))))
(unless (and funcp (memq symbol byte-compile-not-obsolete-funcs))
- (byte-compile-warn "%s" msg)))))
+ (byte-compile-warn-x symbol "%s" msg)))))
(defun byte-compile-report-error (error-info &optional fill)
"Report Lisp error in compilation.
@@ -1481,7 +1588,8 @@ when printing the error message."
(defun byte-compile-emit-callargs-warn (name actual-args min-args max-args)
(byte-compile-set-symbol-position name)
- (byte-compile-warn
+ (byte-compile-warn-x
+ name
"%s called with %d argument%s, but %s %s"
name actual-args
(if (= 1 actual-args) "" "s")
@@ -1547,7 +1655,7 @@ extra args."
n)))
(nargs (- (length form) 2)))
(unless (= nargs nfields)
- (byte-compile-warn
+ (byte-compile-warn-x (car form)
"`%s' called with %d args to fill %d format field(s)" (car form)
nargs nfields)))))
@@ -1561,7 +1669,7 @@ extra args."
(when (eq (car-safe name) 'quote)
(or (not (eq (car form) 'custom-declare-variable))
(plist-get keyword-args :type)
- (byte-compile-warn
+ (byte-compile-warn-x (cadr name)
"defcustom for `%s' fails to specify type" (cadr name)))
(if (and (memq (car form) '(custom-declare-face custom-declare-variable))
byte-compile-current-group)
@@ -1570,7 +1678,7 @@ extra args."
(or (and (eq (car form) 'custom-declare-group)
(equal name ''emacs))
(plist-get keyword-args :group)
- (byte-compile-warn
+ (byte-compile-warn-x (cadr name)
"%s for `%s' fails to specify containing group"
(cdr (assq (car form)
'((custom-declare-group . defgroup)
@@ -1589,7 +1697,7 @@ extra args."
(let ((calls (assq name byte-compile-unresolved-functions))
nums sig min max)
(when (and calls macrop)
- (byte-compile-warn "macro `%s' defined too late" name))
+ (byte-compile-warn-x name "macro `%s' defined too late" name))
(setq byte-compile-unresolved-functions
(delq calls byte-compile-unresolved-functions))
(setq calls (delq t calls)) ;Ignore higher-order uses of the function.
@@ -1597,8 +1705,8 @@ extra args."
(when (and (symbolp name)
(eq (function-get name 'byte-optimizer)
'byte-compile-inline-expand))
- (byte-compile-warn "defsubst `%s' was used before it was defined"
- name))
+ (byte-compile-warn-x name "defsubst `%s' was used before it was defined"
+ name))
(setq sig (byte-compile-arglist-signature arglist)
nums (sort (copy-sequence (cddr calls)) (function <))
min (car nums)
@@ -1606,7 +1714,8 @@ extra args."
(when (or (< min (car sig))
(and (cdr sig) (> max (cdr sig))))
(byte-compile-set-symbol-position name)
- (byte-compile-warn
+ (byte-compile-warn-x
+ name
"%s being defined to take %s%s, but was previously called with %s"
name
(byte-compile-arglist-signature-string sig)
@@ -1625,7 +1734,8 @@ extra args."
(sig2 (byte-compile-arglist-signature arglist)))
(unless (byte-compile-arglist-signatures-congruent-p sig1 sig2)
(byte-compile-set-symbol-position name)
- (byte-compile-warn
+ (byte-compile-warn-x
+ name
"%s %s used to take %s %s, now takes %s"
(if macrop "macro" "function")
name
@@ -1714,8 +1824,10 @@ It is too wide if it has any lines longer than the largest of
(setq name (if name (format " `%s'" name) ""))
(when (and kind docs (stringp docs)
(byte-compile--wide-docstring-p docs col))
- (byte-compile-warn "%s%s docstring wider than %s characters"
- kind name col))))
+ (byte-compile-warn-x
+ name
+ "%s%s docstring wider than %s characters"
+ kind name col))))
form)
;; If we have compiled any calls to functions which are not known to be
@@ -1730,7 +1842,8 @@ It is too wide if it has any lines longer than the largest of
(let ((f (car urf)))
(when (not (memq f byte-compile-new-defuns))
(let ((byte-compile-last-position (cadr urf)))
- (byte-compile-warn
+ (byte-compile-warn-x
+ f
(if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.")
(car urf))))))))
nil)
@@ -2083,7 +2196,8 @@ See also `emacs-lisp-byte-compile-and-load'."
;; within byte-compile-from-buffer lingers in that buffer.
(setq output-buffer
(save-current-buffer
- (let ((byte-compile-level (1+ byte-compile-level)))
+ (let ((symbols-with-pos-enabled t)
+ (byte-compile-level (1+ byte-compile-level)))
(byte-compile-from-buffer input-buffer))))
(if byte-compiler-error-flag
nil
@@ -2195,11 +2309,12 @@ With argument ARG, insert value in current buffer after the form."
(byte-compile-last-warned-form 'nothing)
(value (eval
(let ((read-with-symbol-positions (current-buffer))
- (read-symbol-positions-list nil))
+ (read-symbol-positions-list nil)
+ (symbols-with-pos-enabled t))
(displaying-byte-compile-warnings
(byte-compile-sexp
(eval-sexp-add-defvars
- (read (current-buffer))
+ (read-positioning-symbols (current-buffer))
byte-compile-read-position))))
lexical-binding)))
(cond (arg
@@ -2284,9 +2399,9 @@ With argument ARG, insert value in current buffer after the form."
(setq byte-compile-read-position (point)
byte-compile-last-position byte-compile-read-position)
(let* ((lread--unescaped-character-literals nil)
- (form (read inbuffer))
+ (form (read-positioning-symbols inbuffer))
(warning (byte-run--unescaped-character-literals-warning)))
- (when warning (byte-compile-warn "%s" warning))
+ (when warning (byte-compile-warn-x form "%s" warning))
(byte-compile-toplevel-file-form form)))
;; Compile pending forms at end of file.
(byte-compile-flush-pending)
@@ -2496,7 +2611,8 @@ list that represents a doc string reference.
byte-compile-jump-tables nil))))
(defun byte-compile-preprocess (form &optional _for-effect)
- (setq form (macroexpand-all form byte-compile-macro-environment))
+ (let ((print-symbols-bare t))
+ (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
@@ -2509,11 +2625,13 @@ list that represents a doc string reference.
;; byte-hunk-handlers cannot call this!
(defun byte-compile-toplevel-file-form (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))))))
+ (let ((byte-compile--form-stack
+ (cons top-level-form byte-compile--form-stack)))
+ (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)
@@ -2546,7 +2664,8 @@ list that represents a doc string reference.
;; byte-compile-noruntime-functions, in case we have an autoload
;; of foo-func following an (eval-when-compile (require 'foo)).
(unless (fboundp funsym)
- (push (cons funsym (cons 'autoload (cdr (cdr form))))
+ (push (byte-compile-strip-symbol-positions
+ (cons funsym (cons 'autoload (cdr (cdr form)))))
byte-compile-function-environment))
;; If an autoload occurs _before_ the first call to a function,
;; byte-compile-callargs-warn does not add an entry to
@@ -2562,7 +2681,7 @@ list that represents a doc string reference.
(delq (assq funsym byte-compile-unresolved-functions)
byte-compile-unresolved-functions)))))
(if (stringp (nth 3 form))
- (prog1 form
+ (prog1 (byte-compile-strip-symbol-positions form)
(byte-compile-docstring-length-warn form))
;; No doc string, so we can compile this as a normal form.
(byte-compile-keep-pending form 'byte-compile-normal-call)))
@@ -2574,7 +2693,8 @@ list that represents a doc string reference.
(when (and (symbolp sym)
(not (string-match "[-*/:$]" (symbol-name sym)))
(byte-compile-warning-enabled-p 'lexical sym))
- (byte-compile-warn "global/dynamic var `%s' lacks a prefix" sym)))
+ (byte-compile-warn-x
+ sym "global/dynamic var `%s' lacks a prefix" sym)))
(defun byte-compile--declare-var (sym)
(byte-compile--check-prefixed-var sym)
@@ -2582,7 +2702,7 @@ list that represents a doc string reference.
(setq byte-compile-lexical-variables
(delq sym byte-compile-lexical-variables))
(when (byte-compile-warning-enabled-p 'lexical sym)
- (byte-compile-warn "Variable `%S' declared after its first use" sym)))
+ (byte-compile-warn-x sym "Variable `%S' declared after its first use" sym)))
(push sym byte-compile-bound-variables)
(push sym byte-compile--seen-defvars))
@@ -2595,10 +2715,17 @@ list that represents a doc string reference.
(eq (car form) 'defvar)) ;Just a declaration.
nil
(byte-compile-docstring-length-warn form)
+ (setq form (copy-sequence form))
(cond ((consp (nth 2 form))
- (setq form (copy-sequence form))
(setcar (cdr (cdr form))
- (byte-compile-top-level (nth 2 form) nil 'file))))
+ (byte-compile-top-level (nth 2 form) nil 'file)))
+ ((symbolp (nth 2 form))
+ (setcar (cddr form) (bare-symbol (nth 2 form))))
+ (t (setcar (cddr form)
+ (byte-compile-strip-symbol-positions (nth 2 form)))))
+ (setcar form (bare-symbol (car form)))
+ (if (symbolp (nth 1 form))
+ (setcar (cdr form) (bare-symbol (nth 1 form))))
form))
(put 'define-abbrev-table 'byte-hunk-handler
@@ -2616,7 +2743,8 @@ list that represents a doc string reference.
(`(defvaralias ,_ ',newname . ,_)
(when (memq newname byte-compile-bound-variables)
(if (byte-compile-warning-enabled-p 'suspicious)
- (byte-compile-warn
+ (byte-compile-warn-x
+ newname
"Alias for `%S' should be declared before its referent" newname)))))
(byte-compile-docstring-length-warn form)
(byte-compile-keep-pending form))
@@ -2675,7 +2803,9 @@ list that represents a doc string reference.
(put 'make-obsolete 'byte-hunk-handler 'byte-compile-file-form-make-obsolete)
(defun byte-compile-file-form-make-obsolete (form)
(prog1 (byte-compile-keep-pending form)
- (apply 'make-obsolete (mapcar 'eval (cdr form)))))
+ (apply 'make-obsolete
+ (mapcar 'eval
+ (byte-compile-strip-symbol-positions (cdr form))))))
;; This handler is not necessary, but it makes the output from dont-compile
;; and similar macros cleaner.
@@ -2699,23 +2829,24 @@ not to take responsibility for the actual compilation of the code."
'byte-compile-macro-environment))
(this-one (assq name (symbol-value this-kind)))
(that-one (assq name (symbol-value that-kind)))
+ (bare-name (bare-symbol name))
(byte-compile-current-form name)) ; For warnings.
(byte-compile-set-symbol-position name)
- (push name byte-compile-new-defuns)
+ (push bare-name byte-compile-new-defuns)
;; When a function or macro is defined, add it to the call tree so that
;; we can tell when functions are not used.
(if byte-compile-generate-call-tree
- (or (assq name byte-compile-call-tree)
+ (or (assq bare-name byte-compile-call-tree)
(setq byte-compile-call-tree
- (cons (list name nil nil) byte-compile-call-tree))))
+ (cons (list bare-name nil nil) byte-compile-call-tree))))
(if (byte-compile-warning-enabled-p 'redefine name)
(byte-compile-arglist-warn name arglist macro))
(if byte-compile-verbose
(message "Compiling %s... (%s)"
- (or byte-compile-current-file "") name))
+ (or byte-compile-current-file "") bare-name))
(cond ((not (or macro (listp body)))
;; We do not know positively if the definition is a macro
;; or a function, so we shouldn't emit warnings.
@@ -2724,29 +2855,34 @@ not to take responsibility for the actual compilation of the code."
(that-one
(if (and (byte-compile-warning-enabled-p 'redefine name)
;; Don't warn when compiling the stubs in byte-run...
- (not (assq name byte-compile-initial-macro-environment)))
- (byte-compile-warn
+ (not (assq bare-name byte-compile-initial-macro-environment)))
+ (byte-compile-warn-x
+ name
"`%s' defined multiple times, as both function and macro"
- name))
+ bare-name))
(setcdr that-one nil))
(this-one
(when (and (byte-compile-warning-enabled-p 'redefine name)
;; Hack: Don't warn when compiling the magic internal
;; byte-compiler macros in byte-run.el...
- (not (assq name byte-compile-initial-macro-environment)))
- (byte-compile-warn "%s `%s' defined multiple times in this file"
- (if macro "macro" "function")
- name)))
- ((eq (car-safe (symbol-function name))
+ (not (assq bare-name byte-compile-initial-macro-environment)))
+ (byte-compile-warn-x
+ name
+ "%s `%s' defined multiple times in this file"
+ (if macro "macro" "function")
+ bare-name)))
+ ((eq (car-safe (symbol-function bare-name))
(if macro 'lambda 'macro))
- (when (byte-compile-warning-enabled-p 'redefine name)
- (byte-compile-warn "%s `%s' being redefined as a %s"
- (if macro "function" "macro")
- name
- (if macro "macro" "function")))
+ (when (byte-compile-warning-enabled-p 'redefine bare-name)
+ (byte-compile-warn-x
+ name
+ "%s `%s' being redefined as a %s"
+ (if macro "function" "macro")
+ bare-name
+ (if macro "macro" "function")))
;; Shadow existing definition.
(set this-kind
- (cons (cons name nil)
+ (cons (cons bare-name nil)
(symbol-value this-kind))))
)
@@ -2757,8 +2893,8 @@ not to take responsibility for the actual compilation of the code."
(stringp (car-safe (cdr-safe (cdr-safe body)))))
;; FIXME: We've done that already just above, so this looks wrong!
;;(byte-compile-set-symbol-position name)
- (byte-compile-warn "probable `\"' without `\\' in doc string of %s"
- name))
+ (byte-compile-warn-x
+ name "probable `\"' without `\\' in doc string of %s" bare-name))
(if (not (listp body))
;; The precise definition requires evaluation to find out, so it
@@ -2766,7 +2902,7 @@ not to take responsibility for the actual compilation of the code."
;; For a macro, that means we can't use that macro in the same file.
(progn
(unless macro
- (push (cons name (if (listp arglist) `(declared ,arglist) t))
+ (push (cons bare-name (if (listp arglist) `(declared ,arglist) t))
byte-compile-function-environment))
;; Tell the caller that we didn't compile it yet.
nil)
@@ -2776,10 +2912,10 @@ not to take responsibility for the actual compilation of the code."
;; A definition in b-c-initial-m-e should always take precedence
;; during compilation, so don't let it be redefined. (Bug#8647)
(or (and macro
- (assq name byte-compile-initial-macro-environment))
+ (assq bare-name byte-compile-initial-macro-environment))
(setcdr this-one code))
(set this-kind
- (cons (cons name code)
+ (cons (cons bare-name code)
(symbol-value this-kind))))
(if rest
@@ -2806,7 +2942,7 @@ not to take responsibility for the actual compilation of the code."
;; b-c-output-file-form analyze the defalias.
(byte-compile-output-docform
"\n(defalias '"
- name
+ bare-name
(if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]"))
(append code nil) ; Turn byte-code-function-p into list.
(and (atom code) byte-compile-dynamic
@@ -2950,7 +3086,8 @@ If FORM is a lambda or a macro, byte-compile it as a function."
((and (memq arg vars)
;; Allow repetitions for unused args.
(not (string-match "\\`_" (symbol-name arg))))
- (byte-compile-warn "repeated variable %s in lambda-list" arg))
+ (byte-compile-warn-x
+ arg "repeated variable %s in lambda-list" arg))
(t
(push arg vars))))
(setq list (cdr list)))))
@@ -2993,7 +3130,8 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(defun byte-compile--warn-lexical-dynamic (var context)
(when (byte-compile-warning-enabled-p 'lexical-dynamic var)
- (byte-compile-warn
+ (byte-compile-warn-x
+ var
"`%s' lexically bound in %s here but declared dynamic in: %s"
var context
(mapconcat #'identity
@@ -3045,8 +3183,8 @@ for symbols generated by the byte compiler itself."
;; Check that the bit after the `interactive' spec is
;; just a list of symbols (i.e., modes).
(unless (seq-every-p #'symbolp (cdr (cdr int)))
- (byte-compile-warn "malformed interactive specc: %s"
- (prin1-to-string int)))
+ (byte-compile-warn-x int "malformed interactive specc: %s"
+ int))
(setq command-modes (cdr (cdr int)))
;; If the interactive spec is a call to `list', don't
;; compile it, because `call-interactively' looks at the
@@ -3058,16 +3196,17 @@ for symbols generated by the byte compiler itself."
(while (consp (cdr form))
(setq form (cdr form)))
(setq form (car form)))
- (when (or (not (eq (car-safe form) 'list))
- ;; For code using lexical-binding, form is not
- ;; valid lisp, but rather an intermediate form
- ;; which may include "calls" to
- ;; internal-make-closure (Bug#29988).
- lexical-binding)
- (setq int `(interactive ,newform)))))
+ (if (or (not (eq (car-safe form) 'list))
+ ;; For code using lexical-binding, form is not
+ ;; valid lisp, but rather an intermediate form
+ ;; which may include "calls" to
+ ;; internal-make-closure (Bug#29988).
+ lexical-binding)
+ (setq int (byte-compile-strip-symbol-positions `(interactive ,newform)))
+ (setq int (byte-compile-strip-symbol-positions int)))))
((cdr int) ; Invalid (interactive . something).
- (byte-compile-warn "malformed interactive spec: %s"
- (prin1-to-string int)))))
+ (byte-compile-warn-x int "malformed interactive spec: %s"
+ int))))
;; Process the body.
(let ((compiled
(byte-compile-top-level (cons 'progn body) nil 'lambda
@@ -3078,14 +3217,15 @@ for symbols generated by the byte compiler itself."
(and lexical-binding
(byte-compile-make-lambda-lexenv
arglistvars))
- reserved-csts)))
+ reserved-csts))
+ (bare-arglist (byte-compile-strip-symbol-positions arglist)))
;; Build the actual byte-coded function.
(cl-assert (eq 'byte-code (car-safe compiled)))
(let ((out
(apply #'make-byte-code
(if lexical-binding
(byte-compile-make-args-desc arglist)
- arglist)
+ bare-arglist)
(append
;; byte-string, constants-vector, stack depth
(cdr compiled)
@@ -3093,7 +3233,7 @@ for symbols generated by the byte compiler itself."
(cond ((and lexical-binding arglist)
;; byte-compile-make-args-desc lost the args's names,
;; so preserve them in the docstring.
- (list (help-add-fundoc-usage doc arglist)))
+ (list (help-add-fundoc-usage doc bare-arglist)))
((or doc int)
(list doc)))
;; optionally, the interactive spec (and the modes the
@@ -3101,7 +3241,9 @@ for symbols generated by the byte compiler itself."
(cond
;; We have some command modes, so use the vector form.
(command-modes
- (list (vector (nth 1 int) command-modes)))
+ (list (vector (nth 1 int)
+ (byte-compile-strip-symbol-positions
+ command-modes))))
;; No command modes, use the simple form with just the
;; interactive spec.
(int
@@ -3298,7 +3440,8 @@ for symbols generated by the byte compiler itself."
(setq byte-compile-noruntime-functions
(delq fn byte-compile-noruntime-functions))
;; Delegate the rest to the normal macro definition.
- (macroexpand `(declare-function ,fn ,file ,@args)))
+ (let ((print-symbols-bare t))
+ (macroexpand `(declare-function ,fn ,file ,@args))))
;; This is the recursive entry point for compiling each subform of an
@@ -3315,19 +3458,21 @@ for symbols generated by the byte compiler itself."
;; byte-compile--for-effect flag too.)
;;
(defun byte-compile-form (form &optional for-effect)
- (let ((byte-compile--for-effect for-effect))
+ (let ((byte-compile--for-effect for-effect)
+ (byte-compile--form-stack (cons form byte-compile--form-stack)))
(cond
((not (consp form))
(cond ((or (not (symbolp form)) (macroexp--const-symbol-p form))
(when (symbolp form)
(byte-compile-set-symbol-position form))
- (byte-compile-constant form))
+ (byte-compile-constant
+ (if (symbolp form) (bare-symbol form) form)))
((and byte-compile--for-effect byte-compile-delete-errors)
(when (symbolp form)
(byte-compile-set-symbol-position form))
(setq byte-compile--for-effect nil))
(t
- (byte-compile-variable-ref form))))
+ (byte-compile-variable-ref (bare-symbol form)))))
((symbolp (car form))
(let* ((fn (car form))
(handler (get fn 'byte-compile))
@@ -3350,20 +3495,20 @@ for symbols generated by the byte compiler itself."
(byte-compile-check-variable (cadr hook) nil))))
(when (and (byte-compile-warning-enabled-p 'suspicious)
(macroexp--const-symbol-p fn))
- (byte-compile-warn "`%s' called as a function" 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 "`%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 "."))))
+ (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?)"
@@ -3403,7 +3548,8 @@ for symbols generated by the byte compiler itself."
(when (and byte-compile--for-effect (eq (car form) 'mapcar)
(byte-compile-warning-enabled-p 'mapcar 'mapcar))
(byte-compile-set-symbol-position 'mapcar)
- (byte-compile-warn
+ (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.
@@ -3539,11 +3685,13 @@ for symbols generated by the byte compiler itself."
(cond ((or (not (symbolp var)) (macroexp--const-symbol-p var))
(when (byte-compile-warning-enabled-p 'constants
(and (symbolp var) var))
- (byte-compile-warn (if (eq access-type 'let-bind)
- "attempt to let-bind %s `%s'"
- "variable reference to %s `%s'")
- (if (symbolp var) "constant" "nonvariable")
- (prin1-to-string var))))
+ (byte-compile-warn-x
+ var
+ (if (eq access-type 'let-bind)
+ "attempt to let-bind %s `%s'"
+ "variable reference to %s `%s'")
+ (if (symbolp var) "constant" "nonvariable")
+ var)))
((let ((od (get var 'byte-obsolete-variable)))
(and od
(not (memq var byte-compile-not-obsolete-vars))
@@ -3556,6 +3704,7 @@ for symbols generated by the byte compiler itself."
(byte-compile-warn-obsolete var))))
(defsubst byte-compile-dynamic-variable-op (base-op var)
+ (if (symbolp var) (setq var (bare-symbol var)))
(let ((tmp (assq var byte-compile-variables)))
(unless tmp
(setq tmp (list var))
@@ -3568,9 +3717,10 @@ for symbols generated by the byte compiler itself."
(push var byte-compile-bound-variables)
(byte-compile-dynamic-variable-op 'byte-varbind var))
-(defun byte-compile-free-vars-warn (var &optional assignment)
+(defun byte-compile-free-vars-warn (arg var &optional assignment)
"Warn if symbol VAR refers to a free variable.
VAR must not be lexically bound.
+ARG is a position argument, used by byte-compile-warn-x.
If optional argument ASSIGNMENT is non-nil, this is treated as an
assignment (i.e. `setq')."
(unless (or (not (byte-compile-warning-enabled-p 'free-vars var))
@@ -3582,9 +3732,9 @@ assignment (i.e. `setq')."
(let* ((varname (prin1-to-string var))
(desc (if assignment "assignment" "reference"))
(suggestions (help-uni-confusable-suggestions varname)))
- (byte-compile-warn "%s to free variable `%s'%s"
- desc varname
- (if suggestions (concat "\n " suggestions) "")))
+ (byte-compile-warn-x arg "%s to free variable `%s'%s"
+ desc var
+ (if suggestions (concat "\n " suggestions) "")))
(push var (if assignment
byte-compile-free-assignments
byte-compile-free-references))))
@@ -3597,7 +3747,7 @@ assignment (i.e. `setq')."
;; VAR is lexically bound
(byte-compile-stack-ref (cdr lex-binding))
;; VAR is dynamically bound
- (byte-compile-free-vars-warn var)
+ (byte-compile-free-vars-warn var var)
(byte-compile-dynamic-variable-op 'byte-varref var))))
(defun byte-compile-variable-set (var)
@@ -3608,7 +3758,7 @@ assignment (i.e. `setq')."
;; VAR is lexically bound.
(byte-compile-stack-set (cdr lex-binding))
;; VAR is dynamically bound.
- (byte-compile-free-vars-warn var t)
+ (byte-compile-free-vars-warn var var t)
(byte-compile-dynamic-variable-op 'byte-varset var))))
(defmacro byte-compile-get-constant (const)
@@ -3628,14 +3778,19 @@ assignment (i.e. `setq')."
(defun byte-compile-constant (const)
(if byte-compile--for-effect
(setq byte-compile--for-effect nil)
- (inline (byte-compile-push-constant const))))
+ (inline (byte-compile-push-constant
+ (if (symbolp const) (bare-symbol const) const)))))
;; Use this for a constant that is not the value of its containing form.
;; This ignores byte-compile--for-effect.
(defun byte-compile-push-constant (const)
(when (symbolp const)
- (byte-compile-set-symbol-position const))
- (byte-compile-out 'byte-constant (byte-compile-get-constant const)))
+ (byte-compile-set-symbol-position const)
+ (setq const (bare-symbol const)))
+ (byte-compile-out
+ 'byte-constant
+ (byte-compile-get-constant
+ (byte-compile-strip-symbol-positions const))))
;; Compile those primitive ordinary functions
;; which have special byte codes just for speed.
@@ -3788,9 +3943,10 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(defun byte-compile-subr-wrong-args (form n)
(byte-compile-set-symbol-position (car form))
- (byte-compile-warn "`%s' called with %d arg%s, but requires %s"
- (car form) (length (cdr form))
- (if (= 1 (length (cdr form))) "" "s") n)
+ (byte-compile-warn-x (car form)
+ "`%s' called with %d arg%s, but requires %s"
+ (car form) (length (cdr form))
+ (if (= 1 (length (cdr form))) "" "s") n)
;; Get run-time wrong-number-of-args error.
(byte-compile-normal-call form))
@@ -4099,7 +4255,8 @@ discarding."
(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
+ (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.")))))
@@ -4184,10 +4341,11 @@ discarding."
(macroexp--const-symbol-p var t))
(byte-compile-warning-enabled-p 'constants
(and (symbolp var) var))
- (byte-compile-warn
+ (byte-compile-warn-x
+ var
"variable assignment to %s `%s'"
(if (symbolp var) "constant" "nonvariable")
- (prin1-to-string var)))))
+ var))))
(byte-compile-normal-call form)))
(defun byte-compile-quote (form)
@@ -4466,7 +4624,7 @@ Return (TAIL VAR TEST CASES), where:
(dolist (case cases)
(setq tag (byte-compile-make-tag)
- test-objects (car case)
+ test-objects (byte-compile-strip-symbol-positions (car case))
body (cdr case))
(byte-compile-out-tag tag)
(dolist (value test-objects)
@@ -4772,16 +4930,16 @@ binding slots have been popped."
(endtag (byte-compile-make-tag)))
(byte-compile-set-symbol-position 'condition-case)
(unless (symbolp var)
- (byte-compile-warn
- "`%s' is not a variable-name or nil (in condition-case)" var))
+ (byte-compile-warn-x
+ var "`%s' is not a variable-name or nil (in condition-case)" var))
(dolist (clause (reverse clauses))
(let ((condition (nth 1 clause)))
(unless (consp condition) (setq condition (list condition)))
(dolist (c condition)
(unless (and c (symbolp c))
- (byte-compile-warn
- "`%S' is not a condition name (in condition-case)" c))
+ (byte-compile-warn-x
+ c "`%S' is not a condition name (in condition-case)" c))
;; In reality, the `error-conditions' property is only required
;; for the argument to `signal', not to `condition-case'.
;;(unless (consp (get c 'error-conditions))
@@ -4832,7 +4990,8 @@ binding slots have been popped."
(defun byte-compile-save-excursion (form)
(if (and (eq 'set-buffer (car-safe (car-safe (cdr form))))
(byte-compile-warning-enabled-p 'suspicious 'set-buffer))
- (byte-compile-warn
+ (byte-compile-warn-x
+ form
"Use `with-current-buffer' rather than save-excursion+set-buffer"))
(byte-compile-out 'byte-save-excursion 0)
(byte-compile-body-do-effect (cdr form))
@@ -4873,8 +5032,10 @@ binding slots have been popped."
(when (and (symbolp (nth 1 form))
(not (string-match "[-*/:$]" (symbol-name (nth 1 form))))
(byte-compile-warning-enabled-p 'lexical (nth 1 form)))
- (byte-compile-warn "global/dynamic var `%s' lacks a prefix"
- (nth 1 form)))
+ (byte-compile-warn-x
+ (nth 1 form)
+ "global/dynamic var `%s' lacks a prefix"
+ (nth 1 form)))
(byte-compile-docstring-length-warn form)
(let ((fun (nth 0 form))
(var (nth 1 form))
@@ -4884,7 +5045,8 @@ binding slots have been popped."
(when (or (> (length form) 4)
(and (eq fun 'defconst) (null (cddr form))))
(let ((ncall (length (cdr form))))
- (byte-compile-warn
+ (byte-compile-warn-x
+ fun
"`%s' called with %d argument%s, but %s %s"
fun ncall
(if (= 1 ncall) "" "s")
@@ -4894,8 +5056,10 @@ binding slots have been popped."
(if (eq fun 'defconst)
(push var byte-compile-const-variables))
(when (and string (not (stringp string)))
- (byte-compile-warn "third arg to `%s %s' is not a string: %s"
- fun var string))
+ (byte-compile-warn-x
+ string
+ "third arg to `%s %s' is not a string: %s"
+ fun var string))
(byte-compile-form-do-effect
(if (cddr form) ; `value' provided
;; Quote with `quote' to prevent byte-compiling the body,
@@ -4915,7 +5079,8 @@ binding slots have been popped."
(macroexp-const-p (nth 5 form))
(memq (eval (nth 5 form)) '(t macro)) ; macro-p
(not (fboundp (eval (nth 1 form))))
- (byte-compile-warn
+ (byte-compile-warn-x
+ form
"The compiler ignores `autoload' except at top level. You should
probably put the autoload of the macro `%s' at top-level."
(eval (nth 1 form))))
@@ -5004,7 +5169,8 @@ binding slots have been popped."
(defun byte-compile-make-variable-buffer-local (form)
(if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote)
(byte-compile-warning-enabled-p 'make-local))
- (byte-compile-warn
+ (byte-compile-warn-x
+ form
"`make-variable-buffer-local' not called at toplevel"))
(byte-compile-normal-call form))
(put 'make-variable-buffer-local
@@ -5062,7 +5228,7 @@ binding slots have been popped."
(when (or (vectorp key)
(and (stringp key)
(not (key-valid-p key))))
- (byte-compile-warn "Invalid `kbd' syntax: %S" key))))
+ (byte-compile-warn-x form "Invalid `kbd' syntax: %S" key))))
form)))
;; Functions and the place(s) for the key definition(s).
'((keymap-set 2)
@@ -5088,23 +5254,23 @@ binding slots have been popped."
(not (eq (car form) :menu)))
(unless (memq (car form)
'(:full :keymap :parent :suppress :name :prefix))
- (byte-compile-warn "Invalid keyword: %s" (car form)))
+ (byte-compile-warn-x (car form) "Invalid keyword: %s" (car form)))
(push (pop form) result)
(when (null form)
- (byte-compile-warn "Uneven number of keywords in %S" form))
+ (byte-compile-warn-x orig-form "Uneven number of keywords in %S" form))
(push (pop form) result))
;; Bindings.
(while form
(let ((key (pop form)))
(when (stringp key)
(unless (key-valid-p key)
- (byte-compile-warn "Invalid `kbd' syntax: %S" key)))
+ (byte-compile-warn-x form "Invalid `kbd' syntax: %S" key)))
;; No improvement.
(push key result))
(when (null form)
- (byte-compile-warn "Uneven number of key bindings in %S" form))
+ (byte-compile-warn-x form "Uneven number of key bindings in %S" form))
(push (pop form) result))
- orig-form))
+ (byte-compile-strip-symbol-positions orig-form)))
(put 'define-keymap--define 'byte-hunk-handler
#'byte-compile-define-keymap--define)
@@ -5171,24 +5337,26 @@ OP and OPERAND are as passed to `byte-compile-out'."
;;; call tree stuff
(defun byte-compile-annotate-call-tree (form)
- (let (entry)
+ (let ((current-form (byte-compile-strip-symbol-positions
+ byte-compile-current-form))
+ (bare-car-form (byte-compile-strip-symbol-positions (car form)))
+ entry)
;; annotate the current call
- (if (setq entry (assq (car form) byte-compile-call-tree))
- (or (memq byte-compile-current-form (nth 1 entry)) ;callers
+ (if (setq entry (assq bare-car-form byte-compile-call-tree))
+ (or (memq current-form (nth 1 entry)) ;callers
(setcar (cdr entry)
- (cons byte-compile-current-form (nth 1 entry))))
+ (cons current-form (nth 1 entry))))
(setq byte-compile-call-tree
- (cons (list (car form) (list byte-compile-current-form) nil)
+ (cons (list bare-car-form (list current-form) nil)
byte-compile-call-tree)))
;; annotate the current function
- (if (setq entry (assq byte-compile-current-form byte-compile-call-tree))
- (or (memq (car form) (nth 2 entry)) ;called
+ (if (setq entry (assq current-form byte-compile-call-tree))
+ (or (memq bare-car-form (nth 2 entry)) ;called
(setcar (cdr (cdr entry))
- (cons (car form) (nth 2 entry))))
+ (cons bare-car-form (nth 2 entry))))
(setq byte-compile-call-tree
- (cons (list byte-compile-current-form nil (list (car form)))
- byte-compile-call-tree)))
- ))
+ (cons (list current-form nil (list bare-car-form))
+ byte-compile-call-tree)))))
;; Renamed from byte-compile-report-call-tree
;; to avoid interfering with completion of byte-compile-file.
@@ -5213,14 +5381,15 @@ invoked interactively."
(set-buffer "*Call-Tree*")
(erase-buffer)
(message "Generating call tree... (sorting on %s)"
- byte-compile-call-tree-sort)
+ (remove-pos-from-symbol byte-compile-call-tree-sort))
(insert "Call tree for "
(cond ((null byte-compile-current-file) (or filename "???"))
((stringp byte-compile-current-file)
byte-compile-current-file)
(t (buffer-name byte-compile-current-file)))
" sorted on "
- (prin1-to-string byte-compile-call-tree-sort)
+ (prin1-to-string (remove-pos-from-symbol
+ byte-compile-call-tree-sort))
":\n\n")
(if byte-compile-call-tree-sort
(setq byte-compile-call-tree
@@ -5240,7 +5409,8 @@ invoked interactively."
('name
(lambda (x y) (string< (car x) (car y))))
(_ (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode"
- byte-compile-call-tree-sort))))))
+ (remove-pos-from-symbol
+ byte-compile-call-tree-sort)))))))
(message "Generating call tree...")
(let ((rest byte-compile-call-tree)
(b (current-buffer))
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 03e109f2508..9c9ebe15d5d 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -353,7 +353,8 @@ places where they originally did not directly appear."
(var (if (not (consp binder))
(prog1 binder (setq binder (list binder)))
(when (cddr binder)
- (byte-compile-warn
+ (byte-compile-warn-x
+ binder
"Malformed `%S' binding: %S"
letsym binder))
(setq value (cadr binder))
@@ -361,9 +362,9 @@ places where they originally did not directly appear."
(cond
;; Ignore bindings without a valid name.
((not (symbolp var))
- (byte-compile-warn "attempt to let-bind nonvariable `%S'" var))
+ (byte-compile-warn-x var "attempt to let-bind nonvariable `%S'" var))
((or (booleanp var) (keywordp var))
- (byte-compile-warn "attempt to let-bind constant `%S'" var))
+ (byte-compile-warn-x var "attempt to let-bind constant `%S'" var))
(t
(let ((new-val
(pcase (cconv--var-classification binder form)
@@ -610,7 +611,8 @@ FORM is the parent form that binds this var."
;; FIXME: Convert this warning to use `macroexp--warn-wrap'
;; so as to give better position information.
(when (byte-compile-warning-enabled-p 'not-unused var)
- (byte-compile-warn "%s `%S' not left unused" varkind var)))
+ (byte-compile-warn-x
+ var "%s `%S' not left unused" varkind var)))
((and (let (or 'let* 'let) (car form))
`((,var) ;; (or `(,var nil) : Too many false positives: bug#47080
t nil ,_ ,_))
@@ -618,7 +620,7 @@ FORM is the parent form that binds this var."
;; so as to give better position information and obey
;; `byte-compile-warnings'.
(unless (not (intern-soft var))
- (byte-compile-warn "Variable `%S' left uninitialized" var))))
+ (byte-compile-warn-x var "Variable `%S' left uninitialized" var))))
(pcase vardata
(`(,binder nil ,_ ,_ nil)
(push (cons (cons binder form) :unused) cconv-var-classification))
@@ -647,7 +649,8 @@ FORM is the parent form that binds this var."
(dolist (arg args)
(cond
((byte-compile-not-lexical-var-p arg)
- (byte-compile-warn
+ (byte-compile-warn-x
+ arg
"Lexical argument shadows the dynamic variable %S"
arg))
((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ...
@@ -730,7 +733,8 @@ This function does not return anything but instead fills the
(setq forms (cddr forms))))
(`((lambda . ,_) . ,_) ; First element is lambda expression.
- (byte-compile-warn
+ (byte-compile-warn-x
+ (nth 1 (car form))
"Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form)))
(dolist (exp `((function ,(car form)) . ,(cdr form)))
(cconv-analyze-form exp env)))
@@ -749,8 +753,8 @@ This function does not return anything but instead fills the
(`(condition-case ,var ,protected-form . ,handlers)
(cconv-analyze-form protected-form env)
(when (and var (symbolp var) (byte-compile-not-lexical-var-p var))
- (byte-compile-warn
- "Lexical variable shadows the dynamic variable %S" var))
+ (byte-compile-warn-x
+ var "Lexical variable shadows the dynamic variable %S" var))
(let* ((varstruct (list var nil nil nil nil)))
(if var (push varstruct env))
(dolist (handler handlers)
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 9de47e4987d..b94737e0fee 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -496,7 +496,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
cl--generic-edebug-make-name nil]
lambda-doc ; documentation string
def-body))) ; part to be debugged
- (let ((qualifiers nil))
+ (let ((qualifiers nil)
+ (org-name name))
(while (cl-generic--method-qualifier-p args)
(push args qualifiers)
(setq args (pop body)))
@@ -511,6 +512,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
(byte-compile-warning-enabled-p 'obsolete name))
(let* ((obsolete (get name 'byte-obsolete-info)))
(macroexp-warn-and-return
+ ;; org-name
(macroexp--obsolete-warning name obsolete "generic function")
nil)))
;; You could argue that `defmethod' modifies rather than defines the
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 1852471bcbb..dbe0eb1b0e2 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -53,6 +53,36 @@
`(prog1 (car (cdr ,place))
(setq ,place (cdr (cdr ,place)))))
+(defun cl-macs--strip-s-p-1 (arg)
+ "Strip all positions from symbols with position in ARG, destructively modifying ARG
+Return the modified ARG."
+ (cond
+ ((symbolp arg)
+ (bare-symbol arg))
+ ((consp arg)
+ (let ((a arg))
+ (while (consp (cdr a))
+ (setcar a (cl-macs--strip-s-p-1 (car a)))
+ (setq a (cdr a)))
+ (setcar a (cl-macs--strip-s-p-1 (car a)))
+ ;; (if (cdr a)
+ (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil.
+ (setcdr a (cl-macs--strip-s-p-1 (cdr a)))))
+ arg)
+ ((vectorp arg)
+ (let ((i 0)
+ (len (length arg)))
+ (while (< i len)
+ (aset arg i (cl-macs--strip-s-p-1 (aref arg i)))
+ (setq i (1+ i))))
+ arg)
+ (t arg)))
+
+(defun cl-macs--strip-symbol-positions (arg)
+ "Strip all positions from symbols (recursively) in ARG. Don't modify ARG."
+ (let ((arg1 (copy-tree arg t)))
+ (cl-macs--strip-s-p-1 arg1)))
+
(defvar cl--optimize-safety)
(defvar cl--optimize-speed)
@@ -2417,10 +2447,12 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
(append bindings venv))
macroexpand-all-environment))))
(if malformed-bindings
- (macroexp-warn-and-return
- (format-message "Malformed `cl-symbol-macrolet' binding(s): %S"
- (nreverse malformed-bindings))
- expansion)
+ (let ((rev-malformed-bindings (nreverse malformed-bindings)))
+ (macroexp-warn-and-return
+ ;; rev-malformed-bindings
+ (format-message "Malformed `cl-symbol-macrolet' binding(s): %S"
+ rev-malformed-bindings)
+ expansion))
expansion)))
(unless advised
(advice-remove 'macroexpand #'cl--sm-macroexpand)))))
@@ -3104,6 +3136,7 @@ To see the documentation for a defined struct type, use
(when (cl-oddp (length desc))
(push
(macroexp-warn-and-return
+ ;; (car (last desc))
(format "Missing value for option `%S' of slot `%s' in struct %s!"
(car (last desc)) slot name)
'nil)
@@ -3113,6 +3146,7 @@ To see the documentation for a defined struct type, use
(let ((kw (car defaults)))
(push
(macroexp-warn-and-return
+ ;; kw
(format " I'll take `%s' to be an option rather than a default value."
kw)
'nil)
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 7c5babcf54c..4e9357c2ada 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -744,6 +744,7 @@ Argument FN is the function calling this verifier."
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
+ ;; name
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only))
(_ exp))))
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 3fbfe011e29..76f7b661a62 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -292,6 +292,7 @@ This method is obsolete."
(if (not (stringp (car slots)))
whole
(macroexp-warn-and-return
+ ;; (car slots)
(format "Obsolete name arg %S to constructor %S"
(car slots) (car whole))
;; Keep the name arg, for backward compatibility,
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index ebcc63cc2a5..ed33524f2dc 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -581,7 +581,9 @@ This is like the `&' operator of the C language.
Note: this only works reliably with lexical binding mode, except for very
simple PLACEs such as (symbol-function \\='foo) which will also work in dynamic
binding mode."
- (let ((code
+ (let ((org-place place) ; It's too difficult to determine by inspection whether
+ ; the functions modify place.
+ (code
(gv-letplace (getter setter) place
`(cons (lambda () ,getter)
(lambda (gv--val) ,(funcall setter 'gv--val))))))
@@ -593,6 +595,7 @@ binding mode."
(eq (car-safe code) 'cons))
code
(macroexp-warn-and-return
+ ;; org-place
"Use of gv-ref probably requires lexical-binding"
code))))
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 1e4fdd126cb..6d114a8a547 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -138,14 +138,15 @@ Other uses risk returning non-nil value that point to the wrong file."
(defun macroexp--warn-wrap (msg form category)
(let ((when-compiled (lambda ()
(when (byte-compile-warning-enabled-p category)
- (byte-compile-warn "%s" msg)))))
+ (byte-compile-warn-x form "%s" msg)))))
`(progn
(macroexp--funcall-if-compiled ',when-compiled)
,form)))
(define-obsolete-function-alias 'macroexp--warn-and-return
#'macroexp-warn-and-return "28.1")
-(defun macroexp-warn-and-return (msg form &optional category compile-only)
+(defun macroexp-warn-and-return (;; _arg
+ msg form &optional category compile-only)
"Return code equivalent to FORM labeled with warning MSG.
CATEGORY is the category of the warning, like the categories that
can appear in `byte-compile-warnings'.
@@ -216,6 +217,7 @@ is executed without being compiled first."
(let* ((fun (car form))
(obsolete (get fun 'byte-obsolete-info)))
(macroexp-warn-and-return
+ ;; fun
(macroexp--obsolete-warning
fun obsolete
(if (symbolp (symbol-function fun))
@@ -330,6 +332,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
(if (null body)
(macroexp-unprogn
(macroexp-warn-and-return
+ ;; fun
(format "Empty %s body" fun)
nil nil 'compile-only))
(macroexp--all-forms body))
@@ -367,6 +370,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
(eq 'lambda (car-safe (cadr arg))))
(setcar (nthcdr funarg form)
(macroexp-warn-and-return
+ ;; (nth 1 f)
(format "%S quoted with ' rather than with #'"
(let ((f (cadr arg)))
(if (symbolp f) f `(lambda ,(nth 1 f) ...))))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index a3498d2da8d..430ae97078c 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -940,6 +940,7 @@ Otherwise, it defers to REST which is a list of branches of the form
(let ((code (pcase--u1 matches code vars rest)))
(if (eq upat '_) code
(macroexp-warn-and-return
+ ;; upat
"Pattern t is deprecated. Use `_' instead"
code))))
((eq upat 'pcase--dontcare) :pcase--dontcare)