mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-06 06:20:55 -08:00
Code Issues Projects Releases Wiki Activity

First commit of scratch/correct-warning-pos.

Browse source 
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.
This commit is contained in:
Alan Mackenzie 2021-11-29 11:19:31 +00:00
parent 9721dcf275
commit 368570b3fd
18 changed files with 809 additions and 311 deletions
Download patch file Download diff file Expand all files Collapse all files

38
lisp/emacs-lisp/byte-opt.el
View file

@ -264,8 +264,9 @@ Earlier variables shadow later ones with the same name.")
(cdr (assq name byte-compile-function-environment))))) (cdr (assq name byte-compile-function-environment)))))
(pcase fn (pcase fn
('nil ('nil
(byte-compile-warn "attempt to inline `%s' before it was defined" (byte-compile-warn-x name
name) "attempt to inline `%s' before it was defined"
name)
form) form)
(`(autoload . ,_) (`(autoload . ,_)
(error "File `%s' didn't define `%s'" (nth 1 fn) name)) (error "File `%s' didn't define `%s'" (nth 1 fn) name))
@ -417,8 +418,8 @@ for speeding up processing.")
(t form))) (t form)))
(`(quote . ,v) (`(quote . ,v)
(if (or (not v) (cdr v)) (if (or (not v) (cdr v))
(byte-compile-warn "malformed quote form: `%s'" (byte-compile-warn-x form "malformed quote form: `%s'"
(prin1-to-string form))) form))
;; Map (quote nil) to nil to simplify optimizer logic. ;; Map (quote nil) to nil to simplify optimizer logic.
;; Map quoted constants to nil if for-effect (just because). ;; Map quoted constants to nil if for-effect (just because).
(and (car v) (and (car v)
@ -436,8 +437,9 @@ for speeding up processing.")
(cons (cons
(byte-optimize-form (car clause) nil) (byte-optimize-form (car clause) nil)
(byte-optimize-body (cdr clause) for-effect)) (byte-optimize-body (cdr clause) for-effect))
(byte-compile-warn "malformed cond form: `%s'" (byte-compile-warn-x
(prin1-to-string clause)) clause "malformed cond form: `%s'"
clause)
clause)) clause))
clauses))) clauses)))
(`(progn . ,exps) (`(progn . ,exps)
@ -513,8 +515,7 @@ for speeding up processing.")
`(while ,condition . ,body))) `(while ,condition . ,body)))
(`(interactive . ,_) (`(interactive . ,_)
(byte-compile-warn "misplaced interactive spec: `%s'" (byte-compile-warn-x form "misplaced interactive spec: `%s'" form)
(prin1-to-string form))
nil) nil)
(`(function . ,_) (`(function . ,_)
@ -582,7 +583,7 @@ for speeding up processing.")
(while args (while args
(unless (and (consp args) (unless (and (consp args)
(symbolp (car args)) (consp (cdr 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)) (let* ((var (car args))
(expr (cadr args)) (expr (cadr args))
(lexvar (assq var byte-optimize--lexvars)) (lexvar (assq var byte-optimize--lexvars))
@ -615,8 +616,7 @@ for speeding up processing.")
(cons fn (mapcar #'byte-optimize-form exps))) (cons fn (mapcar #'byte-optimize-form exps)))
(`(,(pred (not symbolp)) . ,_) (`(,(pred (not symbolp)) . ,_)
(byte-compile-warn "`%s' is a malformed function" (byte-compile-warn-x fn "`%s' is a malformed function" fn)
(prin1-to-string fn))
form) form)
((guard (when for-effect ((guard (when for-effect
@ -624,8 +624,10 @@ for speeding up processing.")
(or byte-compile-delete-errors (or byte-compile-delete-errors
(eq tmp 'error-free) (eq tmp 'error-free)
(progn (progn
(byte-compile-warn "value returned from %s is unused" (byte-compile-warn-x
(prin1-to-string form)) form
"value returned from %s is unused"
form)
nil))))) nil)))))
(byte-compile-log " %s called for effect; deleted" fn) (byte-compile-log " %s called for effect; deleted" fn)
;; appending a nil here might not be necessary, but it can't hurt. ;; appending a nil here might not be necessary, but it can't hurt.
@ -821,7 +823,8 @@ for speeding up processing.")
(if (symbolp binding) (if (symbolp binding)
binding binding
(when (or (atom binding) (cddr 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) (list (car binding)
(byte-optimize-form (nth 1 binding) nil)))) (byte-optimize-form (nth 1 binding) nil))))
(car form)) (car form))
@ -1304,7 +1307,7 @@ See Info node `(elisp) Integer Basics'."
(defun byte-optimize-while (form) (defun byte-optimize-while (form)
(when (< (length form) 2) (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) (if (nth 1 form)
form)) form))
@ -1342,9 +1345,10 @@ See Info node `(elisp) Integer Basics'."
(let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) (let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
(nconc (list 'funcall fn) butlast (nconc (list 'funcall fn) butlast
(mapcar (lambda (x) (list 'quote x)) (nth 1 last)))) (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'" "last arg to apply can't be a literal atom: `%s'"
(prin1-to-string last)) last)
nil)) nil))
form)))) form))))

476
lisp/emacs-lisp/bytecomp.el
View file

@ -459,6 +459,42 @@ Filled in `cconv-analyze-form' but initialized and consulted here.")
(defvar byte-compiler-error-flag) (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) (defun byte-compile-recurse-toplevel (form non-toplevel-case)
"Implement `eval-when-compile' and `eval-and-compile'. "Implement `eval-when-compile' and `eval-and-compile'.
Return the compile-time value of FORM." 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 ;; 3.2.3.1, "Processing of Top Level Forms". The semantics are very
;; subtle: see test/lisp/emacs-lisp/bytecomp-tests.el for interesting ;; subtle: see test/lisp/emacs-lisp/bytecomp-tests.el for interesting
;; cases. ;; 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) (if (eq (car-safe form) 'progn)
(cons 'progn (cons 'progn
(mapcar (lambda (subform) (mapcar (lambda (subform)
@ -508,7 +545,8 @@ Return the compile-time value of FORM."
;; Don't compile here, since we don't know ;; Don't compile here, since we don't know
;; whether to compile as byte-compile-form ;; whether to compile as byte-compile-form
;; or byte-compile-file-form. ;; or byte-compile-file-form.
(let ((expanded (let* ((print-symbols-bare t)
(expanded
(macroexpand-all (macroexpand-all
form form
macroexpand-all-environment))) macroexpand-all-environment)))
@ -1212,6 +1250,41 @@ message buffer `default-directory'."
(f2 (file-relative-name file dir))) (f2 (file-relative-name file dir)))
(if (< (length f2) (length f1)) f2 f1))) (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. ;; This is used as warning-prefix for the compiler.
;; It is always called with the warnings buffer current. ;; It is always called with the warnings buffer current.
(defun byte-compile-warning-prefix (level entry) (defun byte-compile-warning-prefix (level entry)
@ -1229,16 +1302,36 @@ message buffer `default-directory'."
(format "%s:" (byte-compile-abbreviate-file (format "%s:" (byte-compile-abbreviate-file
load-file-name dir))) load-file-name dir)))
(t ""))) (t "")))
(offset (byte-compile--warning-source-offset))
(pos (if (and byte-compile-current-file (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 (with-current-buffer byte-compile-current-buffer
(format "%d:%d:" ;; (format "%d:%d:"
(save-excursion ;; (save-excursion
(goto-char byte-compile-last-position) ;; (goto-char (if symbols-with-pos-enabled
(1+ (count-lines (point-min) (point-at-bol)))) ;; (+ byte-compile-read-position offset)
(save-excursion ;; byte-compile-last-position)
(goto-char byte-compile-last-position) ;; )
(1+ (current-column))))) ;; (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" (form (if (eq byte-compile-current-form :end) "end of data"
(or byte-compile-current-form "toplevel form")))) (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) (defun byte-compile-warn (format &rest args)
"Issue a byte compiler warning; use (format-message FORMAT ARGS...) for message." "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)) (setq format (apply #'format-message format args))
(if byte-compile-error-on-warn (if byte-compile-error-on-warn
(error "%s" format) ; byte-compile-file catches and logs it (error "%s" format) ; byte-compile-file catches and logs it
(byte-compile-log-warning format t :warning))) (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) (defun byte-compile-warn-obsolete (symbol)
"Warn that SYMBOL (a variable or function) is obsolete." "Warn that SYMBOL (a variable or function) is obsolete."
(when (byte-compile-warning-enabled-p 'obsolete symbol) (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)) (or funcp (get symbol 'byte-obsolete-variable))
(if funcp "function" "variable")))) (if funcp "function" "variable"))))
(unless (and funcp (memq symbol byte-compile-not-obsolete-funcs)) (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) (defun byte-compile-report-error (error-info &optional fill)
"Report Lisp error in compilation. "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) (defun byte-compile-emit-callargs-warn (name actual-args min-args max-args)
(byte-compile-set-symbol-position name) (byte-compile-set-symbol-position name)
(byte-compile-warn (byte-compile-warn-x
name
"%s called with %d argument%s, but %s %s" "%s called with %d argument%s, but %s %s"
name actual-args name actual-args
(if (= 1 actual-args) "" "s") (if (= 1 actual-args) "" "s")
@ -1547,7 +1655,7 @@ extra args."
n))) n)))
(nargs (- (length form) 2))) (nargs (- (length form) 2)))
(unless (= nargs nfields) (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) "`%s' called with %d args to fill %d format field(s)" (car form)
nargs nfields))))) nargs nfields)))))
@ -1561,7 +1669,7 @@ extra args."
(when (eq (car-safe name) 'quote) (when (eq (car-safe name) 'quote)
(or (not (eq (car form) 'custom-declare-variable)) (or (not (eq (car form) 'custom-declare-variable))
(plist-get keyword-args :type) (plist-get keyword-args :type)
(byte-compile-warn (byte-compile-warn-x (cadr name)
"defcustom for `%s' fails to specify type" (cadr name))) "defcustom for `%s' fails to specify type" (cadr name)))
(if (and (memq (car form) '(custom-declare-face custom-declare-variable)) (if (and (memq (car form) '(custom-declare-face custom-declare-variable))
byte-compile-current-group) byte-compile-current-group)
@ -1570,7 +1678,7 @@ extra args."
(or (and (eq (car form) 'custom-declare-group) (or (and (eq (car form) 'custom-declare-group)
(equal name ''emacs)) (equal name ''emacs))
(plist-get keyword-args :group) (plist-get keyword-args :group)
(byte-compile-warn (byte-compile-warn-x (cadr name)
"%s for `%s' fails to specify containing group" "%s for `%s' fails to specify containing group"
(cdr (assq (car form) (cdr (assq (car form)
'((custom-declare-group . defgroup) '((custom-declare-group . defgroup)
@ -1589,7 +1697,7 @@ extra args."
(let ((calls (assq name byte-compile-unresolved-functions)) (let ((calls (assq name byte-compile-unresolved-functions))
nums sig min max) nums sig min max)
(when (and calls macrop) (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 (setq byte-compile-unresolved-functions
(delq calls byte-compile-unresolved-functions)) (delq calls byte-compile-unresolved-functions))
(setq calls (delq t calls)) ;Ignore higher-order uses of the function. (setq calls (delq t calls)) ;Ignore higher-order uses of the function.
@ -1597,8 +1705,8 @@ extra args."
(when (and (symbolp name) (when (and (symbolp name)
(eq (function-get name 'byte-optimizer) (eq (function-get name 'byte-optimizer)
'byte-compile-inline-expand)) 'byte-compile-inline-expand))
(byte-compile-warn "defsubst `%s' was used before it was defined" (byte-compile-warn-x name "defsubst `%s' was used before it was defined"
name)) name))
(setq sig (byte-compile-arglist-signature arglist) (setq sig (byte-compile-arglist-signature arglist)
nums (sort (copy-sequence (cddr calls)) (function <)) nums (sort (copy-sequence (cddr calls)) (function <))
min (car nums) min (car nums)
@ -1606,7 +1714,8 @@ extra args."
(when (or (< min (car sig)) (when (or (< min (car sig))
(and (cdr sig) (> max (cdr sig)))) (and (cdr sig) (> max (cdr sig))))
(byte-compile-set-symbol-position name) (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" "%s being defined to take %s%s, but was previously called with %s"
name name
(byte-compile-arglist-signature-string sig) (byte-compile-arglist-signature-string sig)
@ -1625,7 +1734,8 @@ extra args."
(sig2 (byte-compile-arglist-signature arglist))) (sig2 (byte-compile-arglist-signature arglist)))
(unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2)
(byte-compile-set-symbol-position name) (byte-compile-set-symbol-position name)
(byte-compile-warn (byte-compile-warn-x
name
"%s %s used to take %s %s, now takes %s" "%s %s used to take %s %s, now takes %s"
(if macrop "macro" "function") (if macrop "macro" "function")
name 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) "")) (setq name (if name (format " `%s'" name) ""))
(when (and kind docs (stringp docs) (when (and kind docs (stringp docs)
(byte-compile--wide-docstring-p docs col)) (byte-compile--wide-docstring-p docs col))
(byte-compile-warn "%s%s docstring wider than %s characters" (byte-compile-warn-x
kind name col)))) name
"%s%s docstring wider than %s characters"
kind name col))))
form) form)
;; If we have compiled any calls to functions which are not known to be ;; 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))) (let ((f (car urf)))
(when (not (memq f byte-compile-new-defuns)) (when (not (memq f byte-compile-new-defuns))
(let ((byte-compile-last-position (cadr urf))) (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.") (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.")
(car urf)))))))) (car urf))))))))
nil) nil)
@ -2083,7 +2196,8 @@ See also `emacs-lisp-byte-compile-and-load'."
;; within byte-compile-from-buffer lingers in that buffer. ;; within byte-compile-from-buffer lingers in that buffer.
(setq output-buffer (setq output-buffer
(save-current-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)))) (byte-compile-from-buffer input-buffer))))
(if byte-compiler-error-flag (if byte-compiler-error-flag
nil nil
@ -2195,11 +2309,12 @@ With argument ARG, insert value in current buffer after the form."
(byte-compile-last-warned-form 'nothing) (byte-compile-last-warned-form 'nothing)
(value (eval (value (eval
(let ((read-with-symbol-positions (current-buffer)) (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 (displaying-byte-compile-warnings
(byte-compile-sexp (byte-compile-sexp
(eval-sexp-add-defvars (eval-sexp-add-defvars
(read (current-buffer)) (read-positioning-symbols (current-buffer))
byte-compile-read-position)))) byte-compile-read-position))))
lexical-binding))) lexical-binding)))
(cond (arg (cond (arg
@ -2284,9 +2399,9 @@ With argument ARG, insert value in current buffer after the form."
(setq byte-compile-read-position (point) (setq byte-compile-read-position (point)
byte-compile-last-position byte-compile-read-position) byte-compile-last-position byte-compile-read-position)
(let* ((lread--unescaped-character-literals nil) (let* ((lread--unescaped-character-literals nil)
(form (read inbuffer)) (form (read-positioning-symbols inbuffer))
(warning (byte-run--unescaped-character-literals-warning))) (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))) (byte-compile-toplevel-file-form form)))
;; Compile pending forms at end of file. ;; Compile pending forms at end of file.
(byte-compile-flush-pending) (byte-compile-flush-pending)
@ -2496,7 +2611,8 @@ list that represents a doc string reference.
byte-compile-jump-tables nil)))) byte-compile-jump-tables nil))))
(defun byte-compile-preprocess (form &optional _for-effect) (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 ;; 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. ;; 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 ;; 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! ;; byte-hunk-handlers cannot call this!
(defun byte-compile-toplevel-file-form (top-level-form) (defun byte-compile-toplevel-file-form (top-level-form)
(byte-compile-recurse-toplevel (let ((byte-compile--form-stack
top-level-form (cons top-level-form byte-compile--form-stack)))
(lambda (form) (byte-compile-recurse-toplevel
(let ((byte-compile-current-form nil)) ; close over this for warnings. top-level-form
(byte-compile-file-form (byte-compile-preprocess form t)))))) (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. ;; byte-hunk-handlers can call this.
(defun byte-compile-file-form (form) (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 ;; byte-compile-noruntime-functions, in case we have an autoload
;; of foo-func following an (eval-when-compile (require 'foo)). ;; of foo-func following an (eval-when-compile (require 'foo)).
(unless (fboundp funsym) (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)) byte-compile-function-environment))
;; If an autoload occurs _before_ the first call to a function, ;; If an autoload occurs _before_ the first call to a function,
;; byte-compile-callargs-warn does not add an entry to ;; 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) (delq (assq funsym byte-compile-unresolved-functions)
byte-compile-unresolved-functions))))) byte-compile-unresolved-functions)))))
(if (stringp (nth 3 form)) (if (stringp (nth 3 form))
(prog1 form (prog1 (byte-compile-strip-symbol-positions form)
(byte-compile-docstring-length-warn form)) (byte-compile-docstring-length-warn form))
;; No doc string, so we can compile this as a normal form. ;; No doc string, so we can compile this as a normal form.
(byte-compile-keep-pending form 'byte-compile-normal-call))) (byte-compile-keep-pending form 'byte-compile-normal-call)))
@ -2574,7 +2693,8 @@ list that represents a doc string reference.
(when (and (symbolp sym) (when (and (symbolp sym)
(not (string-match "[-*/:$]" (symbol-name sym))) (not (string-match "[-*/:$]" (symbol-name sym)))
(byte-compile-warning-enabled-p 'lexical 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) (defun byte-compile--declare-var (sym)
(byte-compile--check-prefixed-var sym) (byte-compile--check-prefixed-var sym)
@ -2582,7 +2702,7 @@ list that represents a doc string reference.
(setq byte-compile-lexical-variables (setq byte-compile-lexical-variables
(delq sym byte-compile-lexical-variables)) (delq sym byte-compile-lexical-variables))
(when (byte-compile-warning-enabled-p 'lexical sym) (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-bound-variables)
(push sym byte-compile--seen-defvars)) (push sym byte-compile--seen-defvars))
@ -2595,10 +2715,17 @@ list that represents a doc string reference.
(eq (car form) 'defvar)) ;Just a declaration. (eq (car form) 'defvar)) ;Just a declaration.
nil nil
(byte-compile-docstring-length-warn form) (byte-compile-docstring-length-warn form)
(setq form (copy-sequence form))
(cond ((consp (nth 2 form)) (cond ((consp (nth 2 form))
(setq form (copy-sequence form))
(setcar (cdr (cdr 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)) form))
(put 'define-abbrev-table 'byte-hunk-handler (put 'define-abbrev-table 'byte-hunk-handler
@ -2616,7 +2743,8 @@ list that represents a doc string reference.
(`(defvaralias ,_ ',newname . ,_) (`(defvaralias ,_ ',newname . ,_)
(when (memq newname byte-compile-bound-variables) (when (memq newname byte-compile-bound-variables)
(if (byte-compile-warning-enabled-p 'suspicious) (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))))) "Alias for `%S' should be declared before its referent" newname)))))
(byte-compile-docstring-length-warn form) (byte-compile-docstring-length-warn form)
(byte-compile-keep-pending 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) (put 'make-obsolete 'byte-hunk-handler 'byte-compile-file-form-make-obsolete)
(defun byte-compile-file-form-make-obsolete (form) (defun byte-compile-file-form-make-obsolete (form)
(prog1 (byte-compile-keep-pending 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 ;; This handler is not necessary, but it makes the output from dont-compile
;; and similar macros cleaner. ;; and similar macros cleaner.
@ -2699,23 +2829,24 @@ not to take responsibility for the actual compilation of the code."
'byte-compile-macro-environment)) 'byte-compile-macro-environment))
(this-one (assq name (symbol-value this-kind))) (this-one (assq name (symbol-value this-kind)))
(that-one (assq name (symbol-value that-kind))) (that-one (assq name (symbol-value that-kind)))
(bare-name (bare-symbol name))
(byte-compile-current-form name)) ; For warnings. (byte-compile-current-form name)) ; For warnings.
(byte-compile-set-symbol-position name) (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 ;; When a function or macro is defined, add it to the call tree so that
;; we can tell when functions are not used. ;; we can tell when functions are not used.
(if byte-compile-generate-call-tree (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 (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) (if (byte-compile-warning-enabled-p 'redefine name)
(byte-compile-arglist-warn name arglist macro)) (byte-compile-arglist-warn name arglist macro))
(if byte-compile-verbose (if byte-compile-verbose
(message "Compiling %s... (%s)" (message "Compiling %s... (%s)"
(or byte-compile-current-file "") name)) (or byte-compile-current-file "") bare-name))
(cond ((not (or macro (listp body))) (cond ((not (or macro (listp body)))
;; We do not know positively if the definition is a macro ;; We do not know positively if the definition is a macro
;; or a function, so we shouldn't emit warnings. ;; 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 (that-one
(if (and (byte-compile-warning-enabled-p 'redefine name) (if (and (byte-compile-warning-enabled-p 'redefine name)
;; Don't warn when compiling the stubs in byte-run... ;; Don't warn when compiling the stubs in byte-run...
(not (assq name byte-compile-initial-macro-environment))) (not (assq bare-name byte-compile-initial-macro-environment)))
(byte-compile-warn (byte-compile-warn-x
name
"`%s' defined multiple times, as both function and macro" "`%s' defined multiple times, as both function and macro"
name)) bare-name))
(setcdr that-one nil)) (setcdr that-one nil))
(this-one (this-one
(when (and (byte-compile-warning-enabled-p 'redefine name) (when (and (byte-compile-warning-enabled-p 'redefine name)
;; Hack: Don't warn when compiling the magic internal ;; Hack: Don't warn when compiling the magic internal
;; byte-compiler macros in byte-run.el... ;; byte-compiler macros in byte-run.el...
(not (assq name byte-compile-initial-macro-environment))) (not (assq bare-name byte-compile-initial-macro-environment)))
(byte-compile-warn "%s `%s' defined multiple times in this file" (byte-compile-warn-x
(if macro "macro" "function") name
name))) "%s `%s' defined multiple times in this file"
((eq (car-safe (symbol-function name)) (if macro "macro" "function")
bare-name)))
((eq (car-safe (symbol-function bare-name))
(if macro 'lambda 'macro)) (if macro 'lambda 'macro))
(when (byte-compile-warning-enabled-p 'redefine name) (when (byte-compile-warning-enabled-p 'redefine bare-name)
(byte-compile-warn "%s `%s' being redefined as a %s" (byte-compile-warn-x
(if macro "function" "macro") name
name "%s `%s' being redefined as a %s"
(if macro "macro" "function"))) (if macro "function" "macro")
bare-name
(if macro "macro" "function")))
;; Shadow existing definition. ;; Shadow existing definition.
(set this-kind (set this-kind
(cons (cons name nil) (cons (cons bare-name nil)
(symbol-value this-kind)))) (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))))) (stringp (car-safe (cdr-safe (cdr-safe body)))))
;; FIXME: We've done that already just above, so this looks wrong! ;; FIXME: We've done that already just above, so this looks wrong!
;;(byte-compile-set-symbol-position name) ;;(byte-compile-set-symbol-position name)
(byte-compile-warn "probable `\"' without `\\' in doc string of %s" (byte-compile-warn-x
name)) name "probable `\"' without `\\' in doc string of %s" bare-name))
(if (not (listp body)) (if (not (listp body))
;; The precise definition requires evaluation to find out, so it ;; 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. ;; For a macro, that means we can't use that macro in the same file.
(progn (progn
(unless macro (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)) byte-compile-function-environment))
;; Tell the caller that we didn't compile it yet. ;; Tell the caller that we didn't compile it yet.
nil) 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 ;; A definition in b-c-initial-m-e should always take precedence
;; during compilation, so don't let it be redefined. (Bug#8647) ;; during compilation, so don't let it be redefined. (Bug#8647)
(or (and macro (or (and macro
(assq name byte-compile-initial-macro-environment)) (assq bare-name byte-compile-initial-macro-environment))
(setcdr this-one code)) (setcdr this-one code))
(set this-kind (set this-kind
(cons (cons name code) (cons (cons bare-name code)
(symbol-value this-kind)))) (symbol-value this-kind))))
(if rest (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. ;; b-c-output-file-form analyze the defalias.
(byte-compile-output-docform (byte-compile-output-docform
"\n(defalias '" "\n(defalias '"
name bare-name
(if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]")) (if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]"))
(append code nil) ; Turn byte-code-function-p into list. (append code nil) ; Turn byte-code-function-p into list.
(and (atom code) byte-compile-dynamic (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) ((and (memq arg vars)
;; Allow repetitions for unused args. ;; Allow repetitions for unused args.
(not (string-match "\\`_" (symbol-name arg)))) (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 (t
(push arg vars)))) (push arg vars))))
(setq list (cdr list))))) (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) (defun byte-compile--warn-lexical-dynamic (var context)
(when (byte-compile-warning-enabled-p 'lexical-dynamic var) (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" "`%s' lexically bound in %s here but declared dynamic in: %s"
var context var context
(mapconcat #'identity (mapconcat #'identity
@ -3045,8 +3183,8 @@ for symbols generated by the byte compiler itself."
;; Check that the bit after the `interactive' spec is ;; Check that the bit after the `interactive' spec is
;; just a list of symbols (i.e., modes). ;; just a list of symbols (i.e., modes).
(unless (seq-every-p #'symbolp (cdr (cdr int))) (unless (seq-every-p #'symbolp (cdr (cdr int)))
(byte-compile-warn "malformed interactive specc: %s" (byte-compile-warn-x int "malformed interactive specc: %s"
(prin1-to-string int))) int))
(setq command-modes (cdr (cdr int))) (setq command-modes (cdr (cdr int)))
;; If the interactive spec is a call to `list', don't ;; If the interactive spec is a call to `list', don't
;; compile it, because `call-interactively' looks at the ;; compile it, because `call-interactively' looks at the
@ -3058,16 +3196,17 @@ for symbols generated by the byte compiler itself."
(while (consp (cdr form)) (while (consp (cdr form))
(setq form (cdr form))) (setq form (cdr form)))
(setq form (car form))) (setq form (car form)))
(when (or (not (eq (car-safe form) 'list)) (if (or (not (eq (car-safe form) 'list))
;; For code using lexical-binding, form is not ;; For code using lexical-binding, form is not
;; valid lisp, but rather an intermediate form ;; valid lisp, but rather an intermediate form
;; which may include "calls" to ;; which may include "calls" to
;; internal-make-closure (Bug#29988). ;; internal-make-closure (Bug#29988).
lexical-binding) lexical-binding)
(setq int `(interactive ,newform))))) (setq int (byte-compile-strip-symbol-positions `(interactive ,newform)))
(setq int (byte-compile-strip-symbol-positions int)))))
((cdr int) ; Invalid (interactive . something). ((cdr int) ; Invalid (interactive . something).
(byte-compile-warn "malformed interactive spec: %s" (byte-compile-warn-x int "malformed interactive spec: %s"
(prin1-to-string int))))) int))))
;; Process the body. ;; Process the body.
(let ((compiled (let ((compiled
(byte-compile-top-level (cons 'progn body) nil 'lambda (byte-compile-top-level (cons 'progn body) nil 'lambda
@ -3078,14 +3217,15 @@ for symbols generated by the byte compiler itself."
(and lexical-binding (and lexical-binding
(byte-compile-make-lambda-lexenv (byte-compile-make-lambda-lexenv
arglistvars)) arglistvars))
reserved-csts))) reserved-csts))
(bare-arglist (byte-compile-strip-symbol-positions arglist)))
;; Build the actual byte-coded function. ;; Build the actual byte-coded function.
(cl-assert (eq 'byte-code (car-safe compiled))) (cl-assert (eq 'byte-code (car-safe compiled)))
(let ((out (let ((out
(apply #'make-byte-code (apply #'make-byte-code
(if lexical-binding (if lexical-binding
(byte-compile-make-args-desc arglist) (byte-compile-make-args-desc arglist)
arglist) bare-arglist)
(append (append
;; byte-string, constants-vector, stack depth ;; byte-string, constants-vector, stack depth
(cdr compiled) (cdr compiled)
@ -3093,7 +3233,7 @@ for symbols generated by the byte compiler itself."
(cond ((and lexical-binding arglist) (cond ((and lexical-binding arglist)
;; byte-compile-make-args-desc lost the args's names, ;; byte-compile-make-args-desc lost the args's names,
;; so preserve them in the docstring. ;; so preserve them in the docstring.
(list (help-add-fundoc-usage doc arglist))) (list (help-add-fundoc-usage doc bare-arglist)))
((or doc int) ((or doc int)
(list doc))) (list doc)))
;; optionally, the interactive spec (and the modes the ;; optionally, the interactive spec (and the modes the
@ -3101,7 +3241,9 @@ for symbols generated by the byte compiler itself."
(cond (cond
;; We have some command modes, so use the vector form. ;; We have some command modes, so use the vector form.
(command-modes (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 ;; No command modes, use the simple form with just the
;; interactive spec. ;; interactive spec.
(int (int
@ -3298,7 +3440,8 @@ for symbols generated by the byte compiler itself."
(setq byte-compile-noruntime-functions (setq byte-compile-noruntime-functions
(delq fn byte-compile-noruntime-functions)) (delq fn byte-compile-noruntime-functions))
;; Delegate the rest to the normal macro definition. ;; 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 ;; 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.) ;; byte-compile--for-effect flag too.)
;; ;;
(defun byte-compile-form (form &optional for-effect) (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 (cond
((not (consp form)) ((not (consp form))
(cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form))
(when (symbolp form) (when (symbolp form)
(byte-compile-set-symbol-position 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) ((and byte-compile--for-effect byte-compile-delete-errors)
(when (symbolp form) (when (symbolp form)
(byte-compile-set-symbol-position form)) (byte-compile-set-symbol-position form))
(setq byte-compile--for-effect nil)) (setq byte-compile--for-effect nil))
(t (t
(byte-compile-variable-ref form)))) (byte-compile-variable-ref (bare-symbol form)))))
((symbolp (car form)) ((symbolp (car form))
(let* ((fn (car form)) (let* ((fn (car form))
(handler (get fn 'byte-compile)) (handler (get fn 'byte-compile))
@ -3350,20 +3495,20 @@ for symbols generated by the byte compiler itself."
(byte-compile-check-variable (cadr hook) nil)))) (byte-compile-check-variable (cadr hook) nil))))
(when (and (byte-compile-warning-enabled-p 'suspicious) (when (and (byte-compile-warning-enabled-p 'suspicious)
(macroexp--const-symbol-p fn)) (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) (when (and (byte-compile-warning-enabled-p 'interactive-only fn)
interactive-only) interactive-only)
(byte-compile-warn "`%s' is for interactive use only%s" (byte-compile-warn-x fn "`%s' is for interactive use only%s"
fn fn
(cond ((stringp interactive-only) (cond ((stringp interactive-only)
(format "; %s" (format "; %s"
(substitute-command-keys (substitute-command-keys
interactive-only))) interactive-only)))
((and (symbolp 'interactive-only) ((and (symbolp 'interactive-only)
(not (eq interactive-only t))) (not (eq interactive-only t)))
(format-message "; use `%s' instead." (format-message "; use `%s' instead."
interactive-only)) interactive-only))
(t ".")))) (t "."))))
(if (eq (car-safe (symbol-function (car form))) 'macro) (if (eq (car-safe (symbol-function (car form))) 'macro)
(byte-compile-report-error (byte-compile-report-error
(format "`%s' defined after use in %S (missing `require' of a library file?)" (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) (when (and byte-compile--for-effect (eq (car form) 'mapcar)
(byte-compile-warning-enabled-p 'mapcar 'mapcar)) (byte-compile-warning-enabled-p 'mapcar 'mapcar))
(byte-compile-set-symbol-position '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")) "`mapcar' called for effect; use `mapc' or `dolist' instead"))
(byte-compile-push-constant (car form)) (byte-compile-push-constant (car form))
(mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. (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)) (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var))
(when (byte-compile-warning-enabled-p 'constants (when (byte-compile-warning-enabled-p 'constants
(and (symbolp var) var)) (and (symbolp var) var))
(byte-compile-warn (if (eq access-type 'let-bind) (byte-compile-warn-x
"attempt to let-bind %s `%s'" var
"variable reference to %s `%s'") (if (eq access-type 'let-bind)
(if (symbolp var) "constant" "nonvariable") "attempt to let-bind %s `%s'"
(prin1-to-string var)))) "variable reference to %s `%s'")
(if (symbolp var) "constant" "nonvariable")
var)))
((let ((od (get var 'byte-obsolete-variable))) ((let ((od (get var 'byte-obsolete-variable)))
(and od (and od
(not (memq var byte-compile-not-obsolete-vars)) (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)))) (byte-compile-warn-obsolete var))))
(defsubst byte-compile-dynamic-variable-op (base-op 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))) (let ((tmp (assq var byte-compile-variables)))
(unless tmp (unless tmp
(setq tmp (list var)) (setq tmp (list var))
@ -3568,9 +3717,10 @@ for symbols generated by the byte compiler itself."
(push var byte-compile-bound-variables) (push var byte-compile-bound-variables)
(byte-compile-dynamic-variable-op 'byte-varbind var)) (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. "Warn if symbol VAR refers to a free variable.
VAR must not be lexically bound. 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 If optional argument ASSIGNMENT is non-nil, this is treated as an
assignment (i.e. `setq')." assignment (i.e. `setq')."
(unless (or (not (byte-compile-warning-enabled-p 'free-vars var)) (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)) (let* ((varname (prin1-to-string var))
(desc (if assignment "assignment" "reference")) (desc (if assignment "assignment" "reference"))
(suggestions (help-uni-confusable-suggestions varname))) (suggestions (help-uni-confusable-suggestions varname)))
(byte-compile-warn "%s to free variable `%s'%s" (byte-compile-warn-x arg "%s to free variable `%s'%s"
desc varname desc var
(if suggestions (concat "\n " suggestions) ""))) (if suggestions (concat "\n " suggestions) "")))
(push var (if assignment (push var (if assignment
byte-compile-free-assignments byte-compile-free-assignments
byte-compile-free-references)))) byte-compile-free-references))))
@ -3597,7 +3747,7 @@ assignment (i.e. `setq')."
;; VAR is lexically bound ;; VAR is lexically bound
(byte-compile-stack-ref (cdr lex-binding)) (byte-compile-stack-ref (cdr lex-binding))
;; VAR is dynamically bound ;; 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)))) (byte-compile-dynamic-variable-op 'byte-varref var))))
(defun byte-compile-variable-set (var) (defun byte-compile-variable-set (var)
@ -3608,7 +3758,7 @@ assignment (i.e. `setq')."
;; VAR is lexically bound. ;; VAR is lexically bound.
(byte-compile-stack-set (cdr lex-binding)) (byte-compile-stack-set (cdr lex-binding))
;; VAR is dynamically bound. ;; 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)))) (byte-compile-dynamic-variable-op 'byte-varset var))))
(defmacro byte-compile-get-constant (const) (defmacro byte-compile-get-constant (const)
@ -3628,14 +3778,19 @@ assignment (i.e. `setq')."
(defun byte-compile-constant (const) (defun byte-compile-constant (const)
(if byte-compile--for-effect (if byte-compile--for-effect
(setq byte-compile--for-effect nil) (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. ;; Use this for a constant that is not the value of its containing form.
;; This ignores byte-compile--for-effect. ;; This ignores byte-compile--for-effect.
(defun byte-compile-push-constant (const) (defun byte-compile-push-constant (const)
(when (symbolp const) (when (symbolp const)
(byte-compile-set-symbol-position const)) (byte-compile-set-symbol-position const)
(byte-compile-out 'byte-constant (byte-compile-get-constant 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 ;; Compile those primitive ordinary functions
;; which have special byte codes just for speed. ;; 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) (defun byte-compile-subr-wrong-args (form n)
(byte-compile-set-symbol-position (car form)) (byte-compile-set-symbol-position (car form))
(byte-compile-warn "`%s' called with %d arg%s, but requires %s" (byte-compile-warn-x (car form)
(car form) (length (cdr form)) "`%s' called with %d arg%s, but requires %s"
(if (= 1 (length (cdr form))) "" "s") n) (car form) (length (cdr form))
(if (= 1 (length (cdr form))) "" "s") n)
;; Get run-time wrong-number-of-args error. ;; Get run-time wrong-number-of-args error.
(byte-compile-normal-call form)) (byte-compile-normal-call form))
@ -4099,7 +4255,8 @@ discarding."
(if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) (if (eq 'interactive (car-safe (car body))) (setq body (cdr body)))
(if (and (consp (car body)) (if (and (consp (car body))
(not (eq 'byte-code (car (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 "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 not what you want, as that lambda cannot be compiled. Consider using
the syntax #'(lambda (...) ...) instead."))))) the syntax #'(lambda (...) ...) instead.")))))
@ -4184,10 +4341,11 @@ discarding."
(macroexp--const-symbol-p var t)) (macroexp--const-symbol-p var t))
(byte-compile-warning-enabled-p 'constants (byte-compile-warning-enabled-p 'constants
(and (symbolp var) var)) (and (symbolp var) var))
(byte-compile-warn (byte-compile-warn-x
var
"variable assignment to %s `%s'" "variable assignment to %s `%s'"
(if (symbolp var) "constant" "nonvariable") (if (symbolp var) "constant" "nonvariable")
(prin1-to-string var))))) var))))
(byte-compile-normal-call form))) (byte-compile-normal-call form)))
(defun byte-compile-quote (form) (defun byte-compile-quote (form)
@ -4466,7 +4624,7 @@ Return (TAIL VAR TEST CASES), where:
(dolist (case cases) (dolist (case cases)
(setq tag (byte-compile-make-tag) (setq tag (byte-compile-make-tag)
test-objects (car case) test-objects (byte-compile-strip-symbol-positions (car case))
body (cdr case)) body (cdr case))
(byte-compile-out-tag tag) (byte-compile-out-tag tag)
(dolist (value test-objects) (dolist (value test-objects)
@ -4772,16 +4930,16 @@ binding slots have been popped."
(endtag (byte-compile-make-tag))) (endtag (byte-compile-make-tag)))
(byte-compile-set-symbol-position 'condition-case) (byte-compile-set-symbol-position 'condition-case)
(unless (symbolp var) (unless (symbolp var)
(byte-compile-warn (byte-compile-warn-x
"`%s' is not a variable-name or nil (in condition-case)" var)) var "`%s' is not a variable-name or nil (in condition-case)" var))
(dolist (clause (reverse clauses)) (dolist (clause (reverse clauses))
(let ((condition (nth 1 clause))) (let ((condition (nth 1 clause)))
(unless (consp condition) (setq condition (list condition))) (unless (consp condition) (setq condition (list condition)))
(dolist (c condition) (dolist (c condition)
(unless (and c (symbolp c)) (unless (and c (symbolp c))
(byte-compile-warn (byte-compile-warn-x
"`%S' is not a condition name (in condition-case)" c)) c "`%S' is not a condition name (in condition-case)" c))
;; In reality, the `error-conditions' property is only required ;; In reality, the `error-conditions' property is only required
;; for the argument to `signal', not to `condition-case'. ;; for the argument to `signal', not to `condition-case'.
;;(unless (consp (get c 'error-conditions)) ;;(unless (consp (get c 'error-conditions))
@ -4832,7 +4990,8 @@ binding slots have been popped."
(defun byte-compile-save-excursion (form) (defun byte-compile-save-excursion (form)
(if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form))))
(byte-compile-warning-enabled-p 'suspicious 'set-buffer)) (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")) "Use `with-current-buffer' rather than save-excursion+set-buffer"))
(byte-compile-out 'byte-save-excursion 0) (byte-compile-out 'byte-save-excursion 0)
(byte-compile-body-do-effect (cdr form)) (byte-compile-body-do-effect (cdr form))
@ -4873,8 +5032,10 @@ binding slots have been popped."
(when (and (symbolp (nth 1 form)) (when (and (symbolp (nth 1 form))
(not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) (not (string-match "[-*/:$]" (symbol-name (nth 1 form))))
(byte-compile-warning-enabled-p 'lexical (nth 1 form))) (byte-compile-warning-enabled-p 'lexical (nth 1 form)))
(byte-compile-warn "global/dynamic var `%s' lacks a prefix" (byte-compile-warn-x
(nth 1 form))) (nth 1 form)
"global/dynamic var `%s' lacks a prefix"
(nth 1 form)))
(byte-compile-docstring-length-warn form) (byte-compile-docstring-length-warn form)
(let ((fun (nth 0 form)) (let ((fun (nth 0 form))
(var (nth 1 form)) (var (nth 1 form))
@ -4884,7 +5045,8 @@ binding slots have been popped."
(when (or (> (length form) 4) (when (or (> (length form) 4)
(and (eq fun 'defconst) (null (cddr form)))) (and (eq fun 'defconst) (null (cddr form))))
(let ((ncall (length (cdr form)))) (let ((ncall (length (cdr form))))
(byte-compile-warn (byte-compile-warn-x
fun
"`%s' called with %d argument%s, but %s %s" "`%s' called with %d argument%s, but %s %s"
fun ncall fun ncall
(if (= 1 ncall) "" "s") (if (= 1 ncall) "" "s")
@ -4894,8 +5056,10 @@ binding slots have been popped."
(if (eq fun 'defconst) (if (eq fun 'defconst)
(push var byte-compile-const-variables)) (push var byte-compile-const-variables))
(when (and string (not (stringp string))) (when (and string (not (stringp string)))
(byte-compile-warn "third arg to `%s %s' is not a string: %s" (byte-compile-warn-x
fun var string)) string
"third arg to `%s %s' is not a string: %s"
fun var string))
(byte-compile-form-do-effect (byte-compile-form-do-effect
(if (cddr form) ; `value' provided (if (cddr form) ; `value' provided
;; Quote with `quote' to prevent byte-compiling the body, ;; Quote with `quote' to prevent byte-compiling the body,
@ -4915,7 +5079,8 @@ binding slots have been popped."
(macroexp-const-p (nth 5 form)) (macroexp-const-p (nth 5 form))
(memq (eval (nth 5 form)) '(t macro)) ; macro-p (memq (eval (nth 5 form)) '(t macro)) ; macro-p
(not (fboundp (eval (nth 1 form)))) (not (fboundp (eval (nth 1 form))))
(byte-compile-warn (byte-compile-warn-x
form
"The compiler ignores `autoload' except at top level. You should "The compiler ignores `autoload' except at top level. You should
probably put the autoload of the macro `%s' at top-level." probably put the autoload of the macro `%s' at top-level."
(eval (nth 1 form)))) (eval (nth 1 form))))
@ -5004,7 +5169,8 @@ binding slots have been popped."
(defun byte-compile-make-variable-buffer-local (form) (defun byte-compile-make-variable-buffer-local (form)
(if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote) (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote)
(byte-compile-warning-enabled-p 'make-local)) (byte-compile-warning-enabled-p 'make-local))
(byte-compile-warn (byte-compile-warn-x
form
"`make-variable-buffer-local' not called at toplevel")) "`make-variable-buffer-local' not called at toplevel"))
(byte-compile-normal-call form)) (byte-compile-normal-call form))
(put 'make-variable-buffer-local (put 'make-variable-buffer-local
@ -5062,7 +5228,7 @@ binding slots have been popped."
(when (or (vectorp key) (when (or (vectorp key)
(and (stringp key) (and (stringp key)
(not (key-valid-p 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))) form)))
;; Functions and the place(s) for the key definition(s). ;; Functions and the place(s) for the key definition(s).
'((keymap-set 2) '((keymap-set 2)
@ -5088,23 +5254,23 @@ binding slots have been popped."
(not (eq (car form) :menu))) (not (eq (car form) :menu)))
(unless (memq (car form) (unless (memq (car form)
'(:full :keymap :parent :suppress :name :prefix)) '(: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) (push (pop form) result)
(when (null form) (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)) (push (pop form) result))
;; Bindings. ;; Bindings.
(while form (while form
(let ((key (pop form))) (let ((key (pop form)))
(when (stringp key) (when (stringp key)
(unless (key-valid-p 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. ;; No improvement.
(push key result)) (push key result))
(when (null form) (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)) (push (pop form) result))
orig-form)) (byte-compile-strip-symbol-positions orig-form)))
(put 'define-keymap--define 'byte-hunk-handler (put 'define-keymap--define 'byte-hunk-handler
#'byte-compile-define-keymap--define) #'byte-compile-define-keymap--define)
@ -5171,24 +5337,26 @@ OP and OPERAND are as passed to `byte-compile-out'."
;;; call tree stuff ;;; call tree stuff
(defun byte-compile-annotate-call-tree (form) (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 ;; annotate the current call
(if (setq entry (assq (car form) byte-compile-call-tree)) (if (setq entry (assq bare-car-form byte-compile-call-tree))
(or (memq byte-compile-current-form (nth 1 entry)) ;callers (or (memq current-form (nth 1 entry)) ;callers
(setcar (cdr entry) (setcar (cdr entry)
(cons byte-compile-current-form (nth 1 entry)))) (cons current-form (nth 1 entry))))
(setq byte-compile-call-tree (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))) byte-compile-call-tree)))
;; annotate the current function ;; annotate the current function
(if (setq entry (assq byte-compile-current-form byte-compile-call-tree)) (if (setq entry (assq current-form byte-compile-call-tree))
(or (memq (car form) (nth 2 entry)) ;called (or (memq bare-car-form (nth 2 entry)) ;called
(setcar (cdr (cdr entry)) (setcar (cdr (cdr entry))
(cons (car form) (nth 2 entry)))) (cons bare-car-form (nth 2 entry))))
(setq byte-compile-call-tree (setq byte-compile-call-tree
(cons (list byte-compile-current-form nil (list (car form))) (cons (list current-form nil (list bare-car-form))
byte-compile-call-tree))) byte-compile-call-tree)))))
))
;; Renamed from byte-compile-report-call-tree ;; Renamed from byte-compile-report-call-tree
;; to avoid interfering with completion of byte-compile-file. ;; to avoid interfering with completion of byte-compile-file.
@ -5213,14 +5381,15 @@ invoked interactively."
(set-buffer "*Call-Tree*") (set-buffer "*Call-Tree*")
(erase-buffer) (erase-buffer)
(message "Generating call tree... (sorting on %s)" (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 " (insert "Call tree for "
(cond ((null byte-compile-current-file) (or filename "???")) (cond ((null byte-compile-current-file) (or filename "???"))
((stringp byte-compile-current-file) ((stringp byte-compile-current-file)
byte-compile-current-file) byte-compile-current-file)
(t (buffer-name byte-compile-current-file))) (t (buffer-name byte-compile-current-file)))
" sorted on " " sorted on "
(prin1-to-string byte-compile-call-tree-sort) (prin1-to-string (remove-pos-from-symbol
byte-compile-call-tree-sort))
":\n\n") ":\n\n")
(if byte-compile-call-tree-sort (if byte-compile-call-tree-sort
(setq byte-compile-call-tree (setq byte-compile-call-tree
@ -5240,7 +5409,8 @@ invoked interactively."
('name ('name
(lambda (x y) (string< (car x) (car y)))) (lambda (x y) (string< (car x) (car y))))
(_ (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" (_ (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode"
byte-compile-call-tree-sort)))))) (remove-pos-from-symbol
byte-compile-call-tree-sort)))))))
(message "Generating call tree...") (message "Generating call tree...")
(let ((rest byte-compile-call-tree) (let ((rest byte-compile-call-tree)
(b (current-buffer)) (b (current-buffer))

22
lisp/emacs-lisp/cconv.el
View file

@ -353,7 +353,8 @@ places where they originally did not directly appear."
(var (if (not (consp binder)) (var (if (not (consp binder))
(prog1 binder (setq binder (list binder))) (prog1 binder (setq binder (list binder)))
(when (cddr binder) (when (cddr binder)
(byte-compile-warn (byte-compile-warn-x
binder
"Malformed `%S' binding: %S" "Malformed `%S' binding: %S"
letsym binder)) letsym binder))
(setq value (cadr binder)) (setq value (cadr binder))
@ -361,9 +362,9 @@ places where they originally did not directly appear."
(cond (cond
;; Ignore bindings without a valid name. ;; Ignore bindings without a valid name.
((not (symbolp var)) ((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)) ((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 (t
(let ((new-val (let ((new-val
(pcase (cconv--var-classification binder form) (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' ;; FIXME: Convert this warning to use `macroexp--warn-wrap'
;; so as to give better position information. ;; so as to give better position information.
(when (byte-compile-warning-enabled-p 'not-unused var) (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)) ((and (let (or 'let* 'let) (car form))
`((,var) ;; (or `(,var nil) : Too many false positives: bug#47080 `((,var) ;; (or `(,var nil) : Too many false positives: bug#47080
t nil ,_ ,_)) t nil ,_ ,_))
@ -618,7 +620,7 @@ FORM is the parent form that binds this var."
;; so as to give better position information and obey ;; so as to give better position information and obey
;; `byte-compile-warnings'. ;; `byte-compile-warnings'.
(unless (not (intern-soft var)) (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 (pcase vardata
(`(,binder nil ,_ ,_ nil) (`(,binder nil ,_ ,_ nil)
(push (cons (cons binder form) :unused) cconv-var-classification)) (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) (dolist (arg args)
(cond (cond
((byte-compile-not-lexical-var-p arg) ((byte-compile-not-lexical-var-p arg)
(byte-compile-warn (byte-compile-warn-x
arg
"Lexical argument shadows the dynamic variable %S" "Lexical argument shadows the dynamic variable %S"
arg)) arg))
((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... ((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)))) (setq forms (cddr forms))))
(`((lambda . ,_) . ,_) ; First element is lambda expression. (`((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))) "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form)))
(dolist (exp `((function ,(car form)) . ,(cdr form))) (dolist (exp `((function ,(car form)) . ,(cdr form)))
(cconv-analyze-form exp env))) (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) (`(condition-case ,var ,protected-form . ,handlers)
(cconv-analyze-form protected-form env) (cconv-analyze-form protected-form env)
(when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) (when (and var (symbolp var) (byte-compile-not-lexical-var-p var))
(byte-compile-warn (byte-compile-warn-x
"Lexical variable shadows the dynamic variable %S" var)) var "Lexical variable shadows the dynamic variable %S" var))
(let* ((varstruct (list var nil nil nil nil))) (let* ((varstruct (list var nil nil nil nil)))
(if var (push varstruct env)) (if var (push varstruct env))
(dolist (handler handlers) (dolist (handler handlers)

4
lisp/emacs-lisp/cl-generic.el
View file

@ -496,7 +496,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
cl--generic-edebug-make-name nil] cl--generic-edebug-make-name nil]
lambda-doc ; documentation string lambda-doc ; documentation string
def-body))) ; part to be debugged def-body))) ; part to be debugged
(let ((qualifiers nil)) (let ((qualifiers nil)
(org-name name))
(while (cl-generic--method-qualifier-p args) (while (cl-generic--method-qualifier-p args)
(push args qualifiers) (push args qualifiers)
(setq args (pop body))) (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)) (byte-compile-warning-enabled-p 'obsolete name))
(let* ((obsolete (get name 'byte-obsolete-info))) (let* ((obsolete (get name 'byte-obsolete-info)))
(macroexp-warn-and-return (macroexp-warn-and-return
;; org-name
(macroexp--obsolete-warning name obsolete "generic function") (macroexp--obsolete-warning name obsolete "generic function")
nil))) nil)))
;; You could argue that `defmethod' modifies rather than defines the ;; You could argue that `defmethod' modifies rather than defines the

42
lisp/emacs-lisp/cl-macs.el
View file

@ -53,6 +53,36 @@
`(prog1 (car (cdr ,place)) `(prog1 (car (cdr ,place))
(setq ,place (cdr (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-safety)
(defvar cl--optimize-speed) (defvar cl--optimize-speed)
@ -2417,10 +2447,12 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
(append bindings venv)) (append bindings venv))
macroexpand-all-environment)))) macroexpand-all-environment))))
(if malformed-bindings (if malformed-bindings
(macroexp-warn-and-return (let ((rev-malformed-bindings (nreverse malformed-bindings)))
(format-message "Malformed `cl-symbol-macrolet' binding(s): %S" (macroexp-warn-and-return
(nreverse malformed-bindings)) ;; rev-malformed-bindings
expansion) (format-message "Malformed `cl-symbol-macrolet' binding(s): %S"
rev-malformed-bindings)
expansion))
expansion))) expansion)))
(unless advised (unless advised
(advice-remove 'macroexpand #'cl--sm-macroexpand))))) (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)) (when (cl-oddp (length desc))
(push (push
(macroexp-warn-and-return (macroexp-warn-and-return
;; (car (last desc))
(format "Missing value for option `%S' of slot `%s' in struct %s!" (format "Missing value for option `%S' of slot `%s' in struct %s!"
(car (last desc)) slot name) (car (last desc)) slot name)
'nil) 'nil)
@ -3113,6 +3146,7 @@ To see the documentation for a defined struct type, use
(let ((kw (car defaults))) (let ((kw (car defaults)))
(push (push
(macroexp-warn-and-return (macroexp-warn-and-return
;; kw
(format " I'll take `%s' to be an option rather than a default value." (format " I'll take `%s' to be an option rather than a default value."
kw) kw)
'nil) 'nil)

1
lisp/emacs-lisp/eieio-core.el
View file

@ -744,6 +744,7 @@ Argument FN is the function calling this verifier."
((and (or `',name (and name (pred keywordp))) ((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names)))) (guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return (macroexp-warn-and-return
;; name
(format-message "Unknown slot `%S'" name) (format-message "Unknown slot `%S'" name)
exp nil 'compile-only)) exp nil 'compile-only))
(_ exp)))) (_ exp))))

1
lisp/emacs-lisp/eieio.el
View file

@ -292,6 +292,7 @@ This method is obsolete."
(if (not (stringp (car slots))) (if (not (stringp (car slots)))
whole whole
(macroexp-warn-and-return (macroexp-warn-and-return
;; (car slots)
(format "Obsolete name arg %S to constructor %S" (format "Obsolete name arg %S to constructor %S"
(car slots) (car whole)) (car slots) (car whole))
;; Keep the name arg, for backward compatibility, ;; Keep the name arg, for backward compatibility,

5
lisp/emacs-lisp/gv.el
View file

@ -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 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 simple PLACEs such as (symbol-function \\='foo) which will also work in dynamic
binding mode." 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 (gv-letplace (getter setter) place
`(cons (lambda () ,getter) `(cons (lambda () ,getter)
(lambda (gv--val) ,(funcall setter 'gv--val)))))) (lambda (gv--val) ,(funcall setter 'gv--val))))))
@ -593,6 +595,7 @@ binding mode."
(eq (car-safe code) 'cons)) (eq (car-safe code) 'cons))
code code
(macroexp-warn-and-return (macroexp-warn-and-return
;; org-place
"Use of gv-ref probably requires lexical-binding" "Use of gv-ref probably requires lexical-binding"
code)))) code))))

8
lisp/emacs-lisp/macroexp.el
View file

@ -138,14 +138,15 @@ Other uses risk returning non-nil value that point to the wrong file."
(defun macroexp--warn-wrap (msg form category) (defun macroexp--warn-wrap (msg form category)
(let ((when-compiled (lambda () (let ((when-compiled (lambda ()
(when (byte-compile-warning-enabled-p category) (when (byte-compile-warning-enabled-p category)
(byte-compile-warn "%s" msg))))) (byte-compile-warn-x form "%s" msg)))))
`(progn `(progn
(macroexp--funcall-if-compiled ',when-compiled) (macroexp--funcall-if-compiled ',when-compiled)
,form))) ,form)))
(define-obsolete-function-alias 'macroexp--warn-and-return (define-obsolete-function-alias 'macroexp--warn-and-return
#'macroexp-warn-and-return "28.1") #'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. "Return code equivalent to FORM labeled with warning MSG.
CATEGORY is the category of the warning, like the categories that CATEGORY is the category of the warning, like the categories that
can appear in `byte-compile-warnings'. can appear in `byte-compile-warnings'.
@ -216,6 +217,7 @@ is executed without being compiled first."
(let* ((fun (car form)) (let* ((fun (car form))
(obsolete (get fun 'byte-obsolete-info))) (obsolete (get fun 'byte-obsolete-info)))
(macroexp-warn-and-return (macroexp-warn-and-return
;; fun
(macroexp--obsolete-warning (macroexp--obsolete-warning
fun obsolete fun obsolete
(if (symbolp (symbol-function fun)) (if (symbolp (symbol-function fun))
@ -330,6 +332,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
(if (null body) (if (null body)
(macroexp-unprogn (macroexp-unprogn
(macroexp-warn-and-return (macroexp-warn-and-return
;; fun
(format "Empty %s body" fun) (format "Empty %s body" fun)
nil nil 'compile-only)) nil nil 'compile-only))
(macroexp--all-forms body)) (macroexp--all-forms body))
@ -367,6 +370,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
(eq 'lambda (car-safe (cadr arg)))) (eq 'lambda (car-safe (cadr arg))))
(setcar (nthcdr funarg form) (setcar (nthcdr funarg form)
(macroexp-warn-and-return (macroexp-warn-and-return
;; (nth 1 f)
(format "%S quoted with ' rather than with #'" (format "%S quoted with ' rather than with #'"
(let ((f (cadr arg))) (let ((f (cadr arg)))
(if (symbolp f) f `(lambda ,(nth 1 f) ...)))) (if (symbolp f) f `(lambda ,(nth 1 f) ...))))

1
lisp/emacs-lisp/pcase.el
View file

@ -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))) (let ((code (pcase--u1 matches code vars rest)))
(if (eq upat '_) code (if (eq upat '_) code
(macroexp-warn-and-return (macroexp-warn-and-return
;; upat
"Pattern t is deprecated. Use `_' instead" "Pattern t is deprecated. Use `_' instead"
code)))) code))))
((eq upat 'pcase--dontcare) :pcase--dontcare) ((eq upat 'pcase--dontcare) :pcase--dontcare)

12
src/.gdbinit
View file

@ -746,6 +746,15 @@ Print $ as a overlay pointer.
This command assumes that $ is an Emacs Lisp overlay value. This command assumes that $ is an Emacs Lisp overlay value.
end end
define xsymwithpos
xgetptr $
print (struct Lisp_Symbol_With_Pos *) $ptr
end
document xsymwithpos
Print $ as a symbol with position.
This command assumes that $ is an Emacs Lisp symbol with position value.
end
define xsymbol define xsymbol
set $sym = $ set $sym = $
xgetsym $sym xgetsym $sym
@ -1011,6 +1020,9 @@ define xpr
if $vec == PVEC_OVERLAY if $vec == PVEC_OVERLAY
xoverlay xoverlay
end end
if $vec == PVEC_SYMBOL_WITH_POS
xsymwithpos
end
if $vec == PVEC_PROCESS if $vec == PVEC_PROCESS
xprocess xprocess
end end

40
src/alloc.c
View file

@ -591,7 +591,7 @@ pointer_align (void *ptr, int alignment)
static ATTRIBUTE_NO_SANITIZE_UNDEFINED void * static ATTRIBUTE_NO_SANITIZE_UNDEFINED void *
XPNTR (Lisp_Object a) XPNTR (Lisp_Object a)
{ {
return (SYMBOLP (a) return (BARE_SYMBOL_P (a)
? (char *) lispsym + (XLI (a) - LISP_WORD_TAG (Lisp_Symbol)) ? (char *) lispsym + (XLI (a) - LISP_WORD_TAG (Lisp_Symbol))
: (char *) XLP (a) - (XLI (a) & ~VALMASK)); : (char *) XLP (a) - (XLI (a) & ~VALMASK));
} }
@ -3598,13 +3598,13 @@ static struct Lisp_Symbol *symbol_free_list;
static void static void
set_symbol_name (Lisp_Object sym, Lisp_Object name) set_symbol_name (Lisp_Object sym, Lisp_Object name)
{ {
XSYMBOL (sym)->u.s.name = name; XBARE_SYMBOL (sym)->u.s.name = name;
} }
void void
init_symbol (Lisp_Object val, Lisp_Object name) init_symbol (Lisp_Object val, Lisp_Object name)
{ {
struct Lisp_Symbol *p = XSYMBOL (val); struct Lisp_Symbol *p = XBARE_SYMBOL (val);
set_symbol_name (val, name); set_symbol_name (val, name);
set_symbol_plist (val, Qnil); set_symbol_plist (val, Qnil);
p->u.s.redirect = SYMBOL_PLAINVAL; p->u.s.redirect = SYMBOL_PLAINVAL;
@ -3667,6 +3667,21 @@ make_misc_ptr (void *a)
return make_lisp_ptr (p, Lisp_Vectorlike); return make_lisp_ptr (p, Lisp_Vectorlike);
} }
/* Return a new symbol with position with the specified SYMBOL and POSITION. */
Lisp_Object
build_symbol_with_pos (Lisp_Object symbol, Lisp_Object position)
{
Lisp_Object val;
struct Lisp_Symbol_With_Pos *p
= (struct Lisp_Symbol_With_Pos *) allocate_vector (2);
XSETVECTOR (val, p);
XSETPVECTYPESIZE (XVECTOR (val), PVEC_SYMBOL_WITH_POS, 2, 0);
p->sym = symbol;
p->pos = position;
return val;
}
/* Return a new overlay with specified START, END and PLIST. */ /* Return a new overlay with specified START, END and PLIST. */
Lisp_Object Lisp_Object
@ -5210,7 +5225,7 @@ valid_lisp_object_p (Lisp_Object obj)
if (PURE_P (p)) if (PURE_P (p))
return 1; return 1;
if (SYMBOLP (obj) && c_symbol_p (p)) if (BARE_SYMBOL_P (obj) && c_symbol_p (p))
return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0; return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0;
if (p == &buffer_defaults || p == &buffer_local_symbols) if (p == &buffer_defaults || p == &buffer_local_symbols)
@ -5638,12 +5653,12 @@ purecopy (Lisp_Object obj)
vec->contents[i] = purecopy (vec->contents[i]); vec->contents[i] = purecopy (vec->contents[i]);
XSETVECTOR (obj, vec); XSETVECTOR (obj, vec);
} }
else if (SYMBOLP (obj)) else if (BARE_SYMBOL_P (obj))
{ {
if (!XSYMBOL (obj)->u.s.pinned && !c_symbol_p (XSYMBOL (obj))) if (!XBARE_SYMBOL (obj)->u.s.pinned && !c_symbol_p (XBARE_SYMBOL (obj)))
{ /* We can't purify them, but they appear in many pure objects. { /* We can't purify them, but they appear in many pure objects.
Mark them as `pinned' so we know to mark them at every GC cycle. */ Mark them as `pinned' so we know to mark them at every GC cycle. */
XSYMBOL (obj)->u.s.pinned = true; XBARE_SYMBOL (obj)->u.s.pinned = true;
symbol_block_pinned = symbol_block; symbol_block_pinned = symbol_block;
} }
/* Don't hash-cons it. */ /* Don't hash-cons it. */
@ -6268,7 +6283,10 @@ For further details, see Info node `(elisp)Garbage Collection'. */)
if (garbage_collection_inhibited) if (garbage_collection_inhibited)
return Qnil; return Qnil;
ptrdiff_t count = SPECPDL_INDEX ();
specbind (Qsymbols_with_pos_enabled, Qnil);
garbage_collect (); garbage_collect ();
unbind_to (count, Qnil);
struct gcstat gcst = gcstat; struct gcstat gcst = gcstat;
Lisp_Object total[] = { Lisp_Object total[] = {
@ -6407,7 +6425,7 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype)
Lisp_Object val = ptr->contents[i]; Lisp_Object val = ptr->contents[i];
if (FIXNUMP (val) || if (FIXNUMP (val) ||
(SYMBOLP (val) && symbol_marked_p (XSYMBOL (val)))) (BARE_SYMBOL_P (val) && symbol_marked_p (XBARE_SYMBOL (val))))
continue; continue;
if (SUB_CHAR_TABLE_P (val)) if (SUB_CHAR_TABLE_P (val))
{ {
@ -6809,7 +6827,7 @@ mark_object (Lisp_Object arg)
case Lisp_Symbol: case Lisp_Symbol:
{ {
struct Lisp_Symbol *ptr = XSYMBOL (obj); struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj);
nextsym: nextsym:
if (symbol_marked_p (ptr)) if (symbol_marked_p (ptr))
break; break;
@ -6930,7 +6948,7 @@ survives_gc_p (Lisp_Object obj)
break; break;
case Lisp_Symbol: case Lisp_Symbol:
survives_p = symbol_marked_p (XSYMBOL (obj)); survives_p = symbol_marked_p (XBARE_SYMBOL (obj));
break; break;
case Lisp_String: case Lisp_String:
@ -7347,7 +7365,7 @@ arenas. */)
static bool static bool
symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj) symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj)
{ {
struct Lisp_Symbol *sym = XSYMBOL (symbol); struct Lisp_Symbol *sym = XBARE_SYMBOL (symbol);
Lisp_Object val = find_symbol_value (symbol); Lisp_Object val = find_symbol_value (symbol);
return (EQ (val, obj) return (EQ (val, obj)
|| EQ (sym->u.s.function, obj) || EQ (sym->u.s.function, obj)

81
src/data.c
View file

@ -216,6 +216,7 @@ for example, (type-of 1) returns `integer'. */)
case PVEC_NORMAL_VECTOR: return Qvector; case PVEC_NORMAL_VECTOR: return Qvector;
case PVEC_BIGNUM: return Qinteger; case PVEC_BIGNUM: return Qinteger;
case PVEC_MARKER: return Qmarker; case PVEC_MARKER: return Qmarker;
case PVEC_SYMBOL_WITH_POS: return Qsymbol_with_pos;
case PVEC_OVERLAY: return Qoverlay; case PVEC_OVERLAY: return Qoverlay;
case PVEC_FINALIZER: return Qfinalizer; case PVEC_FINALIZER: return Qfinalizer;
case PVEC_USER_PTR: return Quser_ptr; case PVEC_USER_PTR: return Quser_ptr;
@ -316,6 +317,26 @@ DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
return Qt; return Qt;
} }
DEFUN ("bare-symbol-p", Fbare_symbol_p, Sbare_symbol_p, 1, 1, 0,
doc: /* Return t if OBJECT is a symbol, but not a symbol together with position. */
attributes: const)
(Lisp_Object object)
{
if (BARE_SYMBOL_P (object))
return Qt;
return Qnil;
}
DEFUN ("symbol-with-pos-p", Fsymbol_with_pos_p, Ssymbol_with_pos_p, 1, 1, 0,
doc: /* Return t if OBJECT is a symbol together with position. */
attributes: const)
(Lisp_Object object)
{
if (SYMBOL_WITH_POS_P (object))
return Qt;
return Qnil;
}
DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
doc: /* Return t if OBJECT is a symbol. */ doc: /* Return t if OBJECT is a symbol. */
attributes: const) attributes: const)
@ -753,6 +774,51 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
return name; return name;
} }
DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0,
doc: /* Extract, if need be, the bare symbol from SYM, a symbol. */)
(register Lisp_Object sym)
{
if (BARE_SYMBOL_P (sym))
return sym;
/* Type checking is done in the following macro. */
return SYMBOL_WITH_POS_SYM (sym);
}
DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1, 1, 0,
doc: /* Extract the position from a symbol with position. */)
(register Lisp_Object ls)
{
/* Type checking is done in the following macro. */
return SYMBOL_WITH_POS_POS (ls);
}
DEFUN ("position-symbol", Fposition_symbol, Sposition_symbol, 2, 2, 0,
doc: /* Create a new symbol with position.
SYM is a symbol, with or without position, the symbol to position.
POS, the position, is either a fixnum or a symbol with position from which
the position will be taken. */)
(register Lisp_Object sym, register Lisp_Object pos)
{
Lisp_Object bare;
Lisp_Object position;
if (BARE_SYMBOL_P (sym))
bare = sym;
else if (SYMBOL_WITH_POS_P (sym))
bare = XSYMBOL_WITH_POS (sym)->sym;
else
wrong_type_argument (Qsymbolp, sym);
if (FIXNUMP (pos))
position = pos;
else if (SYMBOL_WITH_POS_P (pos))
position = XSYMBOL_WITH_POS (pos)->pos;
else
wrong_type_argument (Qfixnum_or_symbol_with_pos_p, pos);
return build_symbol_with_pos (bare, position);
}
DEFUN ("fset", Ffset, Sfset, 2, 2, 0, DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */) doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
(register Lisp_Object symbol, Lisp_Object definition) (register Lisp_Object symbol, Lisp_Object definition)
@ -3929,6 +3995,8 @@ syms_of_data (void)
DEFSYM (Qlistp, "listp"); DEFSYM (Qlistp, "listp");
DEFSYM (Qconsp, "consp"); DEFSYM (Qconsp, "consp");
DEFSYM (Qbare_symbol_p, "bare-symbol-p");
DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p");
DEFSYM (Qsymbolp, "symbolp"); DEFSYM (Qsymbolp, "symbolp");
DEFSYM (Qfixnump, "fixnump"); DEFSYM (Qfixnump, "fixnump");
DEFSYM (Qintegerp, "integerp"); DEFSYM (Qintegerp, "integerp");
@ -3954,6 +4022,7 @@ syms_of_data (void)
DEFSYM (Qchar_table_p, "char-table-p"); DEFSYM (Qchar_table_p, "char-table-p");
DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p"); DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p");
DEFSYM (Qfixnum_or_symbol_with_pos_p, "fixnum-or-symbol-with-pos-p");
DEFSYM (Qsubrp, "subrp"); DEFSYM (Qsubrp, "subrp");
DEFSYM (Qunevalled, "unevalled"); DEFSYM (Qunevalled, "unevalled");
@ -4038,6 +4107,7 @@ syms_of_data (void)
DEFSYM (Qstring, "string"); DEFSYM (Qstring, "string");
DEFSYM (Qcons, "cons"); DEFSYM (Qcons, "cons");
DEFSYM (Qmarker, "marker"); DEFSYM (Qmarker, "marker");
DEFSYM (Qsymbol_with_pos, "symbol-with-pos");
DEFSYM (Qoverlay, "overlay"); DEFSYM (Qoverlay, "overlay");
DEFSYM (Qfinalizer, "finalizer"); DEFSYM (Qfinalizer, "finalizer");
DEFSYM (Qmodule_function, "module-function"); DEFSYM (Qmodule_function, "module-function");
@ -4089,6 +4159,8 @@ syms_of_data (void)
defsubr (&Snumber_or_marker_p); defsubr (&Snumber_or_marker_p);
defsubr (&Sfloatp); defsubr (&Sfloatp);
defsubr (&Snatnump); defsubr (&Snatnump);
defsubr (&Sbare_symbol_p);
defsubr (&Ssymbol_with_pos_p);
defsubr (&Ssymbolp); defsubr (&Ssymbolp);
defsubr (&Skeywordp); defsubr (&Skeywordp);
defsubr (&Sstringp); defsubr (&Sstringp);
@ -4119,6 +4191,9 @@ syms_of_data (void)
defsubr (&Sindirect_function); defsubr (&Sindirect_function);
defsubr (&Ssymbol_plist); defsubr (&Ssymbol_plist);
defsubr (&Ssymbol_name); defsubr (&Ssymbol_name);
defsubr (&Sbare_symbol);
defsubr (&Ssymbol_with_pos_pos);
defsubr (&Sposition_symbol);
defsubr (&Smakunbound); defsubr (&Smakunbound);
defsubr (&Sfmakunbound); defsubr (&Sfmakunbound);
defsubr (&Sboundp); defsubr (&Sboundp);
@ -4201,6 +4276,12 @@ This variable cannot be set; trying to do so will signal an error. */);
Vmost_negative_fixnum = make_fixnum (MOST_NEGATIVE_FIXNUM); Vmost_negative_fixnum = make_fixnum (MOST_NEGATIVE_FIXNUM);
make_symbol_constant (intern_c_string ("most-negative-fixnum")); make_symbol_constant (intern_c_string ("most-negative-fixnum"));
DEFSYM (Qsymbols_with_pos_enabled, "symbols-with-pos-enabled");
DEFVAR_BOOL ("symbols-with-pos-enabled", symbols_with_pos_enabled,
doc: /* Non-nil when "symbols with position" can be used as symbols.
Bind this to non-nil in applications such as the byte compiler. */);
symbols_with_pos_enabled = false;
DEFSYM (Qwatchers, "watchers"); DEFSYM (Qwatchers, "watchers");
DEFSYM (Qmakunbound, "makunbound"); DEFSYM (Qmakunbound, "makunbound");
DEFSYM (Qunlet, "unlet"); DEFSYM (Qunlet, "unlet");

12
src/fns.c
View file

@ -2569,6 +2569,13 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
} }
} }
/* A symbol with position compares the contained symbol, and is
`equal' to the corresponding ordinary symbol. */
if (SYMBOL_WITH_POS_P (o1))
o1 = SYMBOL_WITH_POS_SYM (o1);
if (SYMBOL_WITH_POS_P (o2))
o2 = SYMBOL_WITH_POS_SYM (o2);
if (EQ (o1, o2)) if (EQ (o1, o2))
return true; return true;
if (XTYPE (o1) != XTYPE (o2)) if (XTYPE (o1) != XTYPE (o2))
@ -4479,7 +4486,10 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash)
{ {
ptrdiff_t start_of_bucket, i; ptrdiff_t start_of_bucket, i;
Lisp_Object hash_code = h->test.hashfn (key, h); Lisp_Object hash_code;
if (SYMBOL_WITH_POS_P (key))
key = SYMBOL_WITH_POS_SYM (key);
hash_code = h->test.hashfn (key, h);
if (hash) if (hash)
*hash = hash_code; *hash = hash_code;

2
src/keyboard.c
View file

@ -688,6 +688,8 @@ recursive_edit_1 (void)
{ {
specbind (Qstandard_output, Qt); specbind (Qstandard_output, Qt);
specbind (Qstandard_input, Qt); specbind (Qstandard_input, Qt);
specbind (Qsymbols_with_pos_enabled, Qnil);
specbind (Qprint_symbols_bare, Qnil);
} }
#ifdef HAVE_WINDOW_SYSTEM #ifdef HAVE_WINDOW_SYSTEM

216
src/lisp.h
View file

@ -364,18 +364,38 @@ typedef EMACS_INT Lisp_Word;
# endif # endif
#endif #endif
#define lisp_h_PSEUDOVECTORP(a,code) \
(lisp_h_VECTORLIKEP((a)) && \
((XUNTAG ((a), Lisp_Vectorlike, union vectorlike_header)->size \
& (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \
== (PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS))))
#define lisp_h_CHECK_FIXNUM(x) CHECK_TYPE (FIXNUMP (x), Qfixnump, x) #define lisp_h_CHECK_FIXNUM(x) CHECK_TYPE (FIXNUMP (x), Qfixnump, x)
#define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x) #define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x)
#define lisp_h_CHECK_TYPE(ok, predicate, x) \ #define lisp_h_CHECK_TYPE(ok, predicate, x) \
((ok) ? (void) 0 : wrong_type_argument (predicate, x)) ((ok) ? (void) 0 : wrong_type_argument (predicate, x))
#define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons) #define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons)
#define lisp_h_EQ(x, y) (XLI (x) == XLI (y)) #define lisp_h_BASE_EQ(x, y) (XLI (x) == XLI (y))
/* #define lisp_h_EQ(x, y) (XLI (x) == XLI (y)) */
#define lisp_h_EQ(x, y) ((XLI ((x)) == XLI ((y))) \
|| (symbols_with_pos_enabled \
&& (SYMBOL_WITH_POS_P ((x)) \
? BARE_SYMBOL_P ((y)) \
? (XSYMBOL_WITH_POS((x)))->sym == (y) \
: SYMBOL_WITH_POS_P((y)) \
&& ((XSYMBOL_WITH_POS((x)))->sym \
== (XSYMBOL_WITH_POS((y)))->sym) \
: (SYMBOL_WITH_POS_P ((y)) \
&& BARE_SYMBOL_P ((x)) \
&& ((x) == ((XSYMBOL_WITH_POS ((y)))->sym))))))
#define lisp_h_FIXNUMP(x) \ #define lisp_h_FIXNUMP(x) \
(! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \ (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \
- (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) \ - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) \
& ((1 << INTTYPEBITS) - 1))) & ((1 << INTTYPEBITS) - 1)))
#define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float) #define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float)
#define lisp_h_NILP(x) EQ (x, Qnil) #define lisp_h_NILP(x) /* x == Qnil */ /* ((XLI (x) == XLI (Qnil))) */ /* EQ (x, Qnil) */ BASE_EQ (x, Qnil)
#define lisp_h_SET_SYMBOL_VAL(sym, v) \ #define lisp_h_SET_SYMBOL_VAL(sym, v) \
(eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), \ (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), \
(sym)->u.s.val.value = (v)) (sym)->u.s.val.value = (v))
@ -384,7 +404,10 @@ typedef EMACS_INT Lisp_Word;
#define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_write) #define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_write)
#define lisp_h_SYMBOL_VAL(sym) \ #define lisp_h_SYMBOL_VAL(sym) \
(eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), (sym)->u.s.val.value) (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), (sym)->u.s.val.value)
#define lisp_h_SYMBOLP(x) TAGGEDP (x, Lisp_Symbol) #define lisp_h_SYMBOL_WITH_POS_P(x) PSEUDOVECTORP ((x), PVEC_SYMBOL_WITH_POS)
#define lisp_h_BARE_SYMBOL_P(x) TAGGEDP ((x), Lisp_Symbol)
#define lisp_h_SYMBOLP(x) ((BARE_SYMBOL_P ((x)) || \
(symbols_with_pos_enabled && (SYMBOL_WITH_POS_P ((x))))))
#define lisp_h_TAGGEDP(a, tag) \ #define lisp_h_TAGGEDP(a, tag) \
(! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \
- (unsigned) (tag)) \ - (unsigned) (tag)) \
@ -429,11 +452,12 @@ typedef EMACS_INT Lisp_Word;
# define XLI(o) lisp_h_XLI (o) # define XLI(o) lisp_h_XLI (o)
# define XIL(i) lisp_h_XIL (i) # define XIL(i) lisp_h_XIL (i)
# define XLP(o) lisp_h_XLP (o) # define XLP(o) lisp_h_XLP (o)
# define BARE_SYMBOL_P(x) lisp_h_BARE_SYMBOL_P (x)
# define CHECK_FIXNUM(x) lisp_h_CHECK_FIXNUM (x) # define CHECK_FIXNUM(x) lisp_h_CHECK_FIXNUM (x)
# define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x) # define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x)
# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x) # define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x)
# define CONSP(x) lisp_h_CONSP (x) # define CONSP(x) lisp_h_CONSP (x)
# define EQ(x, y) lisp_h_EQ (x, y) # define BASE_EQ(x, y) lisp_h_BASE_EQ (x, y)
# define FLOATP(x) lisp_h_FLOATP (x) # define FLOATP(x) lisp_h_FLOATP (x)
# define FIXNUMP(x) lisp_h_FIXNUMP (x) # define FIXNUMP(x) lisp_h_FIXNUMP (x)
# define NILP(x) lisp_h_NILP (x) # define NILP(x) lisp_h_NILP (x)
@ -441,7 +465,7 @@ typedef EMACS_INT Lisp_Word;
# define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym) # define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym)
# define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym) # define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym)
# define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym) # define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym)
# define SYMBOLP(x) lisp_h_SYMBOLP (x) /* # define SYMBOLP(x) lisp_h_SYMBOLP (x) */ /* X is accessed more than once. */
# define TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag) # define TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag)
# define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x) # define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x)
# define XCAR(c) lisp_h_XCAR (c) # define XCAR(c) lisp_h_XCAR (c)
@ -600,6 +624,7 @@ extern Lisp_Object char_table_ref (Lisp_Object, int) ATTRIBUTE_PURE;
extern void char_table_set (Lisp_Object, int, Lisp_Object); extern void char_table_set (Lisp_Object, int, Lisp_Object);
/* Defined in data.c. */ /* Defined in data.c. */
extern bool symbols_with_pos_enabled;
extern AVOID args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object); extern AVOID args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object);
extern AVOID wrong_type_argument (Lisp_Object, Lisp_Object); extern AVOID wrong_type_argument (Lisp_Object, Lisp_Object);
extern Lisp_Object default_value (Lisp_Object symbol); extern Lisp_Object default_value (Lisp_Object symbol);
@ -984,57 +1009,12 @@ union vectorlike_header
ptrdiff_t size; ptrdiff_t size;
}; };
INLINE bool struct Lisp_Symbol_With_Pos
(SYMBOLP) (Lisp_Object x)
{ {
return lisp_h_SYMBOLP (x); union vectorlike_header header;
} Lisp_Object sym; /* A symbol */
Lisp_Object pos; /* A fixnum */
INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED } GCALIGNED_STRUCT;
XSYMBOL (Lisp_Object a)
{
eassert (SYMBOLP (a));
intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol);
void *p = (char *) lispsym + i;
return p;
}
INLINE Lisp_Object
make_lisp_symbol (struct Lisp_Symbol *sym)
{
/* GCC 7 x86-64 generates faster code if lispsym is
cast to char * rather than to intptr_t. */
char *symoffset = (char *) ((char *) sym - (char *) lispsym);
Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset);
eassert (XSYMBOL (a) == sym);
return a;
}
INLINE Lisp_Object
builtin_lisp_symbol (int index)
{
return make_lisp_symbol (&lispsym[index]);
}
INLINE bool
c_symbol_p (struct Lisp_Symbol *sym)
{
char *bp = (char *) lispsym;
char *sp = (char *) sym;
if (PTRDIFF_MAX < INTPTR_MAX)
return bp <= sp && sp < bp + sizeof lispsym;
else
{
ptrdiff_t offset = sp - bp;
return 0 <= offset && offset < sizeof lispsym;
}
}
INLINE void
(CHECK_SYMBOL) (Lisp_Object x)
{
lisp_h_CHECK_SYMBOL (x);
}
/* In the size word of a vector, this bit means the vector has been marked. */ /* In the size word of a vector, this bit means the vector has been marked. */
@ -1059,6 +1039,7 @@ enum pvec_type
PVEC_MARKER, PVEC_MARKER,
PVEC_OVERLAY, PVEC_OVERLAY,
PVEC_FINALIZER, PVEC_FINALIZER,
PVEC_SYMBOL_WITH_POS,
PVEC_MISC_PTR, PVEC_MISC_PTR,
PVEC_USER_PTR, PVEC_USER_PTR,
PVEC_PROCESS, PVEC_PROCESS,
@ -1117,6 +1098,92 @@ enum More_Lisp_Bits
values. They are macros for use in #if and static initializers. */ values. They are macros for use in #if and static initializers. */
#define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS) #define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS)
#define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM) #define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM)
INLINE bool
PSEUDOVECTORP (Lisp_Object a, int code)
{
return lisp_h_PSEUDOVECTORP (a, code);
}
INLINE bool
(BARE_SYMBOL_P) (Lisp_Object x)
{
return lisp_h_BARE_SYMBOL_P (x);
}
INLINE bool
(SYMBOL_WITH_POS_P) (Lisp_Object x)
{
return lisp_h_SYMBOL_WITH_POS_P (x);
}
INLINE bool
(SYMBOLP) (Lisp_Object x)
{
return lisp_h_SYMBOLP (x);
}
INLINE struct Lisp_Symbol_With_Pos *
XSYMBOL_WITH_POS (Lisp_Object a)
{
eassert (SYMBOL_WITH_POS_P (a));
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
}
INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
(XBARE_SYMBOL) (Lisp_Object a)
{
eassert (BARE_SYMBOL_P (a));
intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol);
void *p = (char *) lispsym + i;
return p;
}
INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
(XSYMBOL) (Lisp_Object a)
{
eassert (SYMBOLP ((a)));
if (!symbols_with_pos_enabled || BARE_SYMBOL_P (a))
return XBARE_SYMBOL (a);
return XBARE_SYMBOL (XSYMBOL_WITH_POS (a)->sym);
}
INLINE Lisp_Object
make_lisp_symbol (struct Lisp_Symbol *sym)
{
/* GCC 7 x86-64 generates faster code if lispsym is
cast to char * rather than to intptr_t. */
char *symoffset = (char *) ((char *) sym - (char *) lispsym);
Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset);
eassert (XSYMBOL (a) == sym);
return a;
}
INLINE Lisp_Object
builtin_lisp_symbol (int index)
{
return make_lisp_symbol (&lispsym[index]);
}
INLINE bool
c_symbol_p (struct Lisp_Symbol *sym)
{
char *bp = (char *) lispsym;
char *sp = (char *) sym;
if (PTRDIFF_MAX < INTPTR_MAX)
return bp <= sp && sp < bp + sizeof lispsym;
else
{
ptrdiff_t offset = sp - bp;
return 0 <= offset && offset < sizeof lispsym;
}
}
INLINE void
(CHECK_SYMBOL) (Lisp_Object x)
{
lisp_h_CHECK_SYMBOL (x);
}
/* True if the possibly-unsigned integer I doesn't fit in a fixnum. */ /* True if the possibly-unsigned integer I doesn't fit in a fixnum. */
@ -1248,7 +1315,14 @@ make_fixed_natnum (EMACS_INT n)
} }
/* Return true if X and Y are the same object. */ /* Return true if X and Y are the same object. */
INLINE bool
(BASE_EQ) (Lisp_Object x, Lisp_Object y)
{
return lisp_h_BASE_EQ (x, y);
}
/* Return true if X and Y are the same object, reckoning a symbol with
position as being the same as the bare symbol. */
INLINE bool INLINE bool
(EQ) (Lisp_Object x, Lisp_Object y) (EQ) (Lisp_Object x, Lisp_Object y)
{ {
@ -1714,21 +1788,6 @@ PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, enum pvec_type code)
== (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))); == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS)));
} }
/* True if A is a pseudovector whose code is CODE. */
INLINE bool
PSEUDOVECTORP (Lisp_Object a, int code)
{
if (! VECTORLIKEP (a))
return false;
else
{
/* Converting to union vectorlike_header * avoids aliasing issues. */
return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike,
union vectorlike_header),
code);
}
}
/* A boolvector is a kind of vectorlike, with contents like a string. */ /* A boolvector is a kind of vectorlike, with contents like a string. */
struct Lisp_Bool_Vector struct Lisp_Bool_Vector
@ -2627,6 +2686,22 @@ XOVERLAY (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay); return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay);
} }
INLINE Lisp_Object
SYMBOL_WITH_POS_SYM (Lisp_Object a)
{
if (!SYMBOL_WITH_POS_P (a))
wrong_type_argument (Qsymbol_with_pos_p, a);
return XSYMBOL_WITH_POS (a)->sym;
}
INLINE Lisp_Object
SYMBOL_WITH_POS_POS (Lisp_Object a)
{
if (!SYMBOL_WITH_POS_P (a))
wrong_type_argument (Qsymbol_with_pos_p, a);
return XSYMBOL_WITH_POS (a)->pos;
}
INLINE bool INLINE bool
USER_PTRP (Lisp_Object x) USER_PTRP (Lisp_Object x)
{ {
@ -4030,6 +4105,7 @@ extern bool gc_in_progress;
extern Lisp_Object make_float (double); extern Lisp_Object make_float (double);
extern void display_malloc_warning (void); extern void display_malloc_warning (void);
extern ptrdiff_t inhibit_garbage_collection (void); extern ptrdiff_t inhibit_garbage_collection (void);
extern Lisp_Object build_symbol_with_pos (Lisp_Object, Lisp_Object);
extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object);
extern void free_cons (struct Lisp_Cons *); extern void free_cons (struct Lisp_Cons *);
extern void init_alloc_once (void); extern void init_alloc_once (void);

126
src/lread.c
View file

@ -647,12 +647,12 @@ struct subst
}; };
static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object, static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object,
Lisp_Object); Lisp_Object, bool);
static Lisp_Object read0 (Lisp_Object); static Lisp_Object read0 (Lisp_Object, bool);
static Lisp_Object read1 (Lisp_Object, int *, bool); static Lisp_Object read1 (Lisp_Object, int *, bool, bool);
static Lisp_Object read_list (bool, Lisp_Object); static Lisp_Object read_list (bool, Lisp_Object, bool);
static Lisp_Object read_vector (Lisp_Object, bool); static Lisp_Object read_vector (Lisp_Object, bool, bool);
static Lisp_Object substitute_object_recurse (struct subst *, Lisp_Object); static Lisp_Object substitute_object_recurse (struct subst *, Lisp_Object);
static void substitute_in_interval (INTERVAL, void *); static void substitute_in_interval (INTERVAL, void *);
@ -2280,7 +2280,7 @@ readevalloop (Lisp_Object readcharfun,
Qnil, false); Qnil, false);
if (!NILP (Vpurify_flag) && c == '(') if (!NILP (Vpurify_flag) && c == '(')
{ {
val = read_list (0, readcharfun); val = read_list (0, readcharfun, false);
} }
else else
{ {
@ -2302,7 +2302,7 @@ readevalloop (Lisp_Object readcharfun,
else if (! NILP (Vload_read_function)) else if (! NILP (Vload_read_function))
val = call1 (Vload_read_function, readcharfun); val = call1 (Vload_read_function, readcharfun);
else else
val = read_internal_start (readcharfun, Qnil, Qnil); val = read_internal_start (readcharfun, Qnil, Qnil, false);
} }
/* Empty hashes can be reused; otherwise, reset on next call. */ /* Empty hashes can be reused; otherwise, reset on next call. */
if (HASH_TABLE_P (read_objects_map) if (HASH_TABLE_P (read_objects_map)
@ -2460,7 +2460,35 @@ STREAM or the value of `standard-input' may be:
return call1 (intern ("read-minibuffer"), return call1 (intern ("read-minibuffer"),
build_string ("Lisp expression: ")); build_string ("Lisp expression: "));
return read_internal_start (stream, Qnil, Qnil); return read_internal_start (stream, Qnil, Qnil, false);
}
DEFUN ("read-positioning-symbols", Fread_positioning_symbols,
Sread_positioning_symbols, 0, 1, 0,
doc: /* Read one Lisp expression as text from STREAM, return as Lisp object.
Convert each occurrence of a symbol into a "symbol with pos" object.
If STREAM is nil, use the value of `standard-input' (which see).
STREAM or the value of `standard-input' may be:
a buffer (read from point and advance it)
a marker (read from where it points and advance it)
a function (call it with no arguments for each character,
call it with a char as argument to push a char back)
a string (takes text from string, starting at the beginning)
t (read text line using minibuffer and use it, or read from
standard input in batch mode). */)
(Lisp_Object stream)
{
if (NILP (stream))
stream = Vstandard_input;
if (EQ (stream, Qt))
stream = Qread_char;
if (EQ (stream, Qread_char))
/* FIXME: ?! When is this used !? */
return call1 (intern ("read-minibuffer"),
build_string ("Lisp expression: "));
return read_internal_start (stream, Qnil, Qnil, true);
} }
DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0, DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
@ -2476,14 +2504,17 @@ the end of STRING. */)
Lisp_Object ret; Lisp_Object ret;
CHECK_STRING (string); CHECK_STRING (string);
/* `read_internal_start' sets `read_from_string_index'. */ /* `read_internal_start' sets `read_from_string_index'. */
ret = read_internal_start (string, start, end); ret = read_internal_start (string, start, end, false);
return Fcons (ret, make_fixnum (read_from_string_index)); return Fcons (ret, make_fixnum (read_from_string_index));
} }
/* Function to set up the global context we need in toplevel read /* Function to set up the global context we need in toplevel read
calls. START and END only used when STREAM is a string. */ calls. START and END only used when STREAM is a string.
LOCATE_SYMS true means read symbol occurrences as symbols with
position. */
static Lisp_Object static Lisp_Object
read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end,
bool locate_syms)
{ {
Lisp_Object retval; Lisp_Object retval;
@ -2523,7 +2554,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end)
read_from_string_limit = endval; read_from_string_limit = endval;
} }
retval = read0 (stream); retval = read0 (stream, locate_syms);
if (EQ (Vread_with_symbol_positions, Qt) if (EQ (Vread_with_symbol_positions, Qt)
|| EQ (Vread_with_symbol_positions, stream)) || EQ (Vread_with_symbol_positions, stream))
Vread_symbol_positions_list = Fnreverse (Vread_symbol_positions_list); Vread_symbol_positions_list = Fnreverse (Vread_symbol_positions_list);
@ -2542,12 +2573,12 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end)
are not allowed. */ are not allowed. */
static Lisp_Object static Lisp_Object
read0 (Lisp_Object readcharfun) read0 (Lisp_Object readcharfun, bool locate_syms)
{ {
register Lisp_Object val; register Lisp_Object val;
int c; int c;
val = read1 (readcharfun, &c, 0); val = read1 (readcharfun, &c, 0, locate_syms);
if (!c) if (!c)
return val; return val;
@ -2971,10 +3002,12 @@ read_integer (Lisp_Object readcharfun, int radix,
in *PCH and the return value is not interesting. Else, we store in *PCH and the return value is not interesting. Else, we store
zero in *PCH and we read and return one lisp object. zero in *PCH and we read and return one lisp object.
FIRST_IN_LIST is true if this is the first element of a list. */ FIRST_IN_LIST is true if this is the first element of a list.
LOCATE_SYMS true means read symbol occurrences as symbols with
position. */
static Lisp_Object static Lisp_Object
read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms)
{ {
int c; int c;
bool uninterned_symbol = false; bool uninterned_symbol = false;
@ -2994,10 +3027,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
switch (c) switch (c)
{ {
case '(': case '(':
return read_list (0, readcharfun); return read_list (0, readcharfun, locate_syms);
case '[': case '[':
return read_vector (readcharfun, 0); return read_vector (readcharfun, 0, locate_syms);
case ')': case ')':
case ']': case ']':
@ -3016,7 +3049,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
/* Accept extended format for hash tables (extensible to /* Accept extended format for hash tables (extensible to
other types), e.g. other types), e.g.
#s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
Lisp_Object tmp = read_list (0, readcharfun); Lisp_Object tmp = read_list (0, readcharfun, false);
Lisp_Object head = CAR_SAFE (tmp); Lisp_Object head = CAR_SAFE (tmp);
Lisp_Object data = Qnil; Lisp_Object data = Qnil;
Lisp_Object val = Qnil; Lisp_Object val = Qnil;
@ -3105,7 +3138,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
if (c == '[') if (c == '[')
{ {
Lisp_Object tmp; Lisp_Object tmp;
tmp = read_vector (readcharfun, 0); tmp = read_vector (readcharfun, 0, false);
if (ASIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS) if (ASIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS)
error ("Invalid size char-table"); error ("Invalid size char-table");
XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE); XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE);
@ -3118,7 +3151,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
{ {
/* Sub char-table can't be read as a regular /* Sub char-table can't be read as a regular
vector because of a two C integer fields. */ vector because of a two C integer fields. */
Lisp_Object tbl, tmp = read_list (1, readcharfun); Lisp_Object tbl, tmp = read_list (1, readcharfun, false);
ptrdiff_t size = list_length (tmp); ptrdiff_t size = list_length (tmp);
int i, depth, min_char; int i, depth, min_char;
struct Lisp_Cons *cell; struct Lisp_Cons *cell;
@ -3156,7 +3189,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
if (c == '&') if (c == '&')
{ {
Lisp_Object length; Lisp_Object length;
length = read1 (readcharfun, pch, first_in_list); length = read1 (readcharfun, pch, first_in_list, false);
c = READCHAR; c = READCHAR;
if (c == '"') if (c == '"')
{ {
@ -3165,7 +3198,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
unsigned char *data; unsigned char *data;
UNREAD (c); UNREAD (c);
tmp = read1 (readcharfun, pch, first_in_list); tmp = read1 (readcharfun, pch, first_in_list, false);
if (STRING_MULTIBYTE (tmp) if (STRING_MULTIBYTE (tmp)
|| (size_in_chars != SCHARS (tmp) || (size_in_chars != SCHARS (tmp)
/* We used to print 1 char too many /* We used to print 1 char too many
@ -3193,7 +3226,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
build them using function calls. */ build them using function calls. */
Lisp_Object tmp; Lisp_Object tmp;
struct Lisp_Vector *vec; struct Lisp_Vector *vec;
tmp = read_vector (readcharfun, 1); tmp = read_vector (readcharfun, 1, locate_syms);
vec = XVECTOR (tmp); vec = XVECTOR (tmp);
if (! (COMPILED_STACK_DEPTH < ASIZE (tmp) if (! (COMPILED_STACK_DEPTH < ASIZE (tmp)
&& (FIXNUMP (AREF (tmp, COMPILED_ARGLIST)) && (FIXNUMP (AREF (tmp, COMPILED_ARGLIST))
@ -3243,7 +3276,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
int ch; int ch;
/* Read the string itself. */ /* Read the string itself. */
tmp = read1 (readcharfun, &ch, 0); tmp = read1 (readcharfun, &ch, 0, false);
if (ch != 0 || !STRINGP (tmp)) if (ch != 0 || !STRINGP (tmp))
invalid_syntax ("#", readcharfun); invalid_syntax ("#", readcharfun);
/* Read the intervals and their properties. */ /* Read the intervals and their properties. */
@ -3251,14 +3284,14 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
{ {
Lisp_Object beg, end, plist; Lisp_Object beg, end, plist;
beg = read1 (readcharfun, &ch, 0); beg = read1 (readcharfun, &ch, 0, false);
end = plist = Qnil; end = plist = Qnil;
if (ch == ')') if (ch == ')')
break; break;
if (ch == 0) if (ch == 0)
end = read1 (readcharfun, &ch, 0); end = read1 (readcharfun, &ch, 0, false);
if (ch == 0) if (ch == 0)
plist = read1 (readcharfun, &ch, 0); plist = read1 (readcharfun, &ch, 0, false);
if (ch) if (ch)
invalid_syntax ("Invalid string property list", readcharfun); invalid_syntax ("Invalid string property list", readcharfun);
Fset_text_properties (beg, end, plist, tmp); Fset_text_properties (beg, end, plist, tmp);
@ -3369,7 +3402,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
if (c == '$') if (c == '$')
return Vload_file_name; return Vload_file_name;
if (c == '\'') if (c == '\'')
return list2 (Qfunction, read0 (readcharfun)); return list2 (Qfunction, read0 (readcharfun, locate_syms));
/* #:foo is the uninterned symbol named foo. */ /* #:foo is the uninterned symbol named foo. */
if (c == ':') if (c == ':')
{ {
@ -3452,7 +3485,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
hash_put (h, number, placeholder, hash); hash_put (h, number, placeholder, hash);
/* Read the object itself. */ /* Read the object itself. */
Lisp_Object tem = read0 (readcharfun); Lisp_Object tem = read0 (readcharfun, locate_syms);
/* If it can be recursive, remember it for /* If it can be recursive, remember it for
future substitutions. */ future substitutions. */
@ -3508,6 +3541,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
else if (c == 'b' || c == 'B') else if (c == 'b' || c == 'B')
return read_integer (readcharfun, 2, stackbuf); return read_integer (readcharfun, 2, stackbuf);
char acm_buf[15]; /* FIXME!!! 2021-11-27. */
sprintf (acm_buf, "#%c", c);
invalid_syntax (acm_buf, readcharfun);
UNREAD (c); UNREAD (c);
invalid_syntax ("#", readcharfun); invalid_syntax ("#", readcharfun);
@ -3516,10 +3552,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
goto retry; goto retry;
case '\'': case '\'':
return list2 (Qquote, read0 (readcharfun)); return list2 (Qquote, read0 (readcharfun, locate_syms));
case '`': case '`':
return list2 (Qbackquote, read0 (readcharfun)); return list2 (Qbackquote, read0 (readcharfun, locate_syms));
case ',': case ',':
{ {
@ -3535,7 +3571,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
comma_type = Qcomma; comma_type = Qcomma;
} }
value = read0 (readcharfun); value = read0 (readcharfun, locate_syms);
return list2 (comma_type, value); return list2 (comma_type, value);
} }
case '?': case '?':
@ -3842,6 +3878,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
result = intern_driver (name, obarray, tem); result = intern_driver (name, obarray, tem);
} }
} }
if (locate_syms
&& !NILP (result)
)
result = build_symbol_with_pos (result,
make_fixnum (start_position));
if (EQ (Vread_with_symbol_positions, Qt) if (EQ (Vread_with_symbol_positions, Qt)
|| EQ (Vread_with_symbol_positions, readcharfun)) || EQ (Vread_with_symbol_positions, readcharfun))
@ -4100,9 +4141,9 @@ string_to_number (char const *string, int base, ptrdiff_t *plen)
static Lisp_Object static Lisp_Object
read_vector (Lisp_Object readcharfun, bool bytecodeflag) read_vector (Lisp_Object readcharfun, bool bytecodeflag, bool locate_syms)
{ {
Lisp_Object tem = read_list (1, readcharfun); Lisp_Object tem = read_list (1, readcharfun, locate_syms);
ptrdiff_t size = list_length (tem); ptrdiff_t size = list_length (tem);
Lisp_Object vector = make_nil_vector (size); Lisp_Object vector = make_nil_vector (size);
@ -4174,10 +4215,12 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag)
return vector; return vector;
} }
/* FLAG means check for ']' to terminate rather than ')' and '.'. */ /* FLAG means check for ']' to terminate rather than ')' and '.'.
LOCATE_SYMS true means read symbol occurrencess as symbols with
position. */
static Lisp_Object static Lisp_Object
read_list (bool flag, Lisp_Object readcharfun) read_list (bool flag, Lisp_Object readcharfun, bool locate_syms)
{ {
Lisp_Object val, tail; Lisp_Object val, tail;
Lisp_Object elt, tem; Lisp_Object elt, tem;
@ -4195,7 +4238,7 @@ read_list (bool flag, Lisp_Object readcharfun)
while (1) while (1)
{ {
int ch; int ch;
elt = read1 (readcharfun, &ch, first_in_list); elt = read1 (readcharfun, &ch, first_in_list, locate_syms);
first_in_list = 0; first_in_list = 0;
@ -4239,10 +4282,10 @@ read_list (bool flag, Lisp_Object readcharfun)
if (ch == '.') if (ch == '.')
{ {
if (!NILP (tail)) if (!NILP (tail))
XSETCDR (tail, read0 (readcharfun)); XSETCDR (tail, read0 (readcharfun, locate_syms));
else else
val = read0 (readcharfun); val = read0 (readcharfun, locate_syms);
read1 (readcharfun, &ch, 0); read1 (readcharfun, &ch, 0, locate_syms);
if (ch == ')') if (ch == ')')
{ {
@ -5120,6 +5163,7 @@ void
syms_of_lread (void) syms_of_lread (void)
{ {
defsubr (&Sread); defsubr (&Sread);
defsubr (&Sread_positioning_symbols);
defsubr (&Sread_from_string); defsubr (&Sread_from_string);
defsubr (&Slread__substitute_object_in_subtree); defsubr (&Slread__substitute_object_in_subtree);
defsubr (&Sintern); defsubr (&Sintern);

33
src/print.c
View file

@ -1416,6 +1416,30 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
printchar ('>', printcharfun); printchar ('>', printcharfun);
break; break;
case PVEC_SYMBOL_WITH_POS:
{
struct Lisp_Symbol_With_Pos *sp = XSYMBOL_WITH_POS (obj);
if (print_symbols_bare)
print_object (sp->sym, printcharfun, escapeflag);
else
{
print_c_string ("#<symbol ", printcharfun);
if (BARE_SYMBOL_P (sp->sym))
print_object (sp->sym, printcharfun, escapeflag);
else
print_c_string ("NOT A SYMBOL!!", printcharfun);
if (FIXNUMP (sp->pos))
{
print_c_string (" at ", printcharfun);
print_object (sp->pos, printcharfun, escapeflag);
}
else
print_c_string (" NOT A POSITION!!", printcharfun);
printchar ('>', printcharfun);
}
}
break;
case PVEC_OVERLAY: case PVEC_OVERLAY:
print_c_string ("#<overlay ", printcharfun); print_c_string ("#<overlay ", printcharfun);
if (! XMARKER (OVERLAY_START (obj))->buffer) if (! XMARKER (OVERLAY_START (obj))->buffer)
@ -1921,7 +1945,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
error ("Apparently circular structure being printed"); error ("Apparently circular structure being printed");
for (i = 0; i < print_depth; i++) for (i = 0; i < print_depth; i++)
if (EQ (obj, being_printed[i])) if (BASE_EQ (obj, being_printed[i]))
{ {
int len = sprintf (buf, "#%d", i); int len = sprintf (buf, "#%d", i);
strout (buf, len, len, printcharfun); strout (buf, len, len, printcharfun);
@ -2425,6 +2449,13 @@ priorities. Values other than nil or t are also treated as
`default'. */); `default'. */);
Vprint_charset_text_property = Qdefault; Vprint_charset_text_property = Qdefault;
DEFVAR_BOOL ("print-symbols-bare", print_symbols_bare,
doc: /* A flag to control printing of symbols with position.
If the value is nil, print these objects complete with position.
Otherwise print just the bare symbol. */);
print_symbols_bare = false;
DEFSYM (Qprint_symbols_bare, "print-symbols-bare");
/* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */ /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
staticpro (&Vprin1_to_string_buffer); staticpro (&Vprin1_to_string_buffer);